R Shiny: nested observe functions

Question

For the sample data set mtcars, we want to use "cyl","am","carb","gear" to be the candidate filters(selectInput widgets). Users should be able to select the filter they want.

And for each filter picked, there is an '(un)select all' button associated with it.

My issue is, since the number of filters is not fixed, so the loop statement to generate the observeEvent statements has to be in another observe function.

Please run the following reproducible code.

Any suggestions to make the '(un)select all' botton work? thanks.

library(ggplot2)
library(shiny)
server <- function(input, output, session) {
  R = mtcars[,c("cyl","am","carb","gear")]

  output$FILTERS = renderUI({
    selectInput("filters","Filters",choices = names(R),multiple = TRUE)
  })

  #this observe generates filters(selectInput widgets) dynamically, not important
  observe({
    req(input$filters)
    filter_names = input$filters

    # count how many filters I selected
    n = length(filter_names)     

    # to render n selectInput    
    lapply(1:n,function(x){
      output[[paste0("FILTER_",x)]] = renderUI({
        req(input$filters)
        div(
          selectInput(paste0("filter_",x),
                      paste0(filter_names[x]),
                      choices = unique(R[,filter_names[x]]),
                      multiple = TRUE,
                      selected = unique(R[,filter_names[x]])
                      ),
          actionButton(paste0("filter_all_",x),"(Un)Select All")
        )
      })
    })

    # this renders all the selectInput widgets
    output$FILTER_GROUP = renderUI({
      lapply(1:n, function(i){
        uiOutput(paste0("FILTER_",i))
      })
    })
  })
####################   issue begins ##################### 
  observe(

  n = length(input$filters)

  lapply(
    1:n,
    FUN = function(i){
      Filter = paste0("filter_",i)
      botton = paste0("filter_all_",i)

      observeEvent(botton,{
        NAME = input$filters[i]
        choices = unique(mtcars[,NAME])

        if (is.null(input[[Filter]])) {

          updateCheckboxGroupInput(
            session = session, inputId = Filter, selected = as.character(choices)
          )
        } else {
          updateCheckboxGroupInput(
            session = session, inputId = Filter, selected = ""
          )
        }
      })
    }
  )
  )
####################   issue ends #####################
})

ui <- fluidPage(
  uiOutput("FILTERS"),
  hr(),
  uiOutput("FILTER_GROUP")
)

shinyApp(ui = ui, server = server)

Take a look to this answer http://stackoverflow.com/questions/40631788/shiny-observe-triggered-by-dynamicaly-generated-inputs/40643541#40643541 — Geovany, Nov 22 '16 at 02:57

score 2 · Accepted Answer · edited May 23 '17 at 12:02

Your code has many problems, 1) You are evaluating the number of elements in a selectInput using is.null instead of length. 2) You are using updateCheckboxGroupInput instead of updateSelectInput. 3) If you a put an observer inside another observer, you will be creating multiple observers for the same event. And 4) you have some missing {} in your last observer and a extra ) in the server function.

The idea on the recommended answer is to keep track of the last button clicked to avoid multiple observers. In your problem, in addition to have only one observer (and avoid nested observers), the idea is to know the id of the corresponding selectInput next to the (Un)Select All button. The goal is to only update that specific select input. In your code, the update will be applied to all the selectInput's.

We need to add to each actionButton the id of the selectInput and the column name of the mtcars dataset associated with that selectInput. For that purpose, we can add the attributes: data for the id, and name for the column name. With JavaScript we can retrieve that attributes and send them back to the Server as the input's lastSelectId and lastSelectName respectively.

Below is your code modified to have a JavaScript function to handle the click event for the selector button. Please note that we also need to wrap each selectInput and actionButton in a div with class = "dynamicSI" to distinguish from others buttons.

library(ggplot2)
library(shiny)

server <- function(input, output, session) {

  R = mtcars[,c("cyl","am","carb","gear")]

  output$FILTERS = renderUI({
    selectInput("filters","Filters",choices = names(R),multiple = TRUE)
  })

  observe({

    req(input$filters)
    filter_names = input$filters

    # count how many filters I selected
    n = length(filter_names)     

    # to render n selectInput    
    lapply(1:n,function(x){
      output[[paste0("FILTER_",x)]] = renderUI({
        req(input$filters)
        div( class = "dynamicSI",
          selectInput(paste0("filter_",x),
                      paste0(filter_names[x]),
                      choices = unique(R[,filter_names[x]]),
                      multiple = TRUE,
                      selected = unique(R[,filter_names[x]])
                      ),
          actionButton(paste0("filter_all_",x),"(Un)Select All", 
                       data = paste0("filter_",x), # selectInput id
                       name = paste0(filter_names[x])) # name of column
        )
      })
    })

    output$FILTER_GROUP = renderUI({
      div(class="dynamicSI",
        lapply(1:n, function(i){
          uiOutput(paste0("FILTER_",i))
        })
      )

    })

  })


  observeEvent(input$lastSelect, {

    if (!is.null(input$lastSelectId)) {
      cat("lastSelectId:", input$lastSelectId, "\n")
      cat("lastSelectName:", input$lastSelectName, "\n")
    }  
    # selectInput id
    Filter = input$lastSelectId
    # column name of dataset, (label on select input)
    NAME = input$lastSelectName
    choices = unique(mtcars[,NAME])

    if (length(input[[Filter]]) == 0) {
      # in corresponding selectInput has no elements selected
      updateSelectInput(
        session = session, inputId = Filter, selected = as.character(choices)
      )
    } else {
      # has at least one element selected
      updateSelectInput(
        session = session, inputId = Filter, selected = ""
      )
    }

  })

  output$L = renderPrint({
    input$lastSelectId
  })
}


ui <- fluidPage(
  tags$script("$(document).on('click', '.dynamicSI button', function () {
                var id = document.getElementById(this.id).getAttribute('data');
                var name = document.getElementById(this.id).getAttribute('name');
                Shiny.onInputChange('lastSelectId',id);
                Shiny.onInputChange('lastSelectName',name);
                // to report changes on the same selectInput
                Shiny.onInputChange('lastSelect', Math.random());
                });"),  

  uiOutput("FILTERS"),
  hr(),
  uiOutput("FILTER_GROUP"),
  hr(),
  verbatimTextOutput("L")

)

shinyApp(ui = ui, server = server)

If we use the `dropdownButton` widget defined in this link http://stackoverflow.com/questions/34530142/drop-down-checkbox-input-in-shiny, any idea where we should put the `div(class = "dynamicSI", ...)` statement in. — John, Nov 23 '16 at 03:18
As close as possible to the action button to select all elements. — Geovany, Nov 23 '16 at 04:44
I updated my code. I tried several places to div class but none is working. Is the custom widget `dropdownButton` blocking the class defining... — John, Nov 23 '16 at 05:24
It seems that it is more complex that just changing the `div` location. I have some ideas of how to solve that. Please open another question with your updated code, so we don't create a mess here. — Geovany, Nov 23 '16 at 08:17
Don't if my wording is OK but the link is here http://stackoverflow.com/questions/40759834/r-shiny-trigger-dynamically-created-without-using-nested-observe-function — John, Nov 23 '16 at 08:56

John · Answer 2 · 2016-11-23T05:20:48.837

@Geovany

Updated

library(ggplot2)
library(shiny)


dropdownButton <- function(label = "", status = c("default", "primary", "success", "info", "warning", "danger"), ..., width = NULL) {

  status <- match.arg(status)
  # dropdown button content
  html_ul <- list(
    class = "dropdown-menu",
    style = if (!is.null(width)) 
      paste0("width: ", validateCssUnit(width), ";"),
    lapply(X = list(...), FUN = tags$li, style = "margin-left: 10px; margin-right: 10px;font-size:x-small")
  )
  # dropdown button apparence
  html_button <- list(
    class = paste0("btn btn-", status," dropdown-toggle"),
    type = "button", 
    `data-toggle` = "dropdown",
    style="font-size:x-small;width:135px"
    #    style="font-size:small;width:135px"

  )
  html_button <- c(html_button, list(label))
  html_button <- c(html_button, list(tags$span(class = "caret")))
  # final result
  tags$div(
    class = "dropdown",
    br(),
    do.call(tags$button, html_button),
    do.call(tags$ul, html_ul),
    tags$script(
      "$('.dropdown-menu').click(function(e) {
      e.stopPropagation();
});")
  )
  }


server <- function(input, output, session) {

  R = mtcars[,c("cyl","am","carb","gear")]

  output$FILTERS = renderUI({
    selectInput("filters","Filters",choices = names(R),multiple = TRUE)
  })

  observe({

    req(input$filters)
    filter_names = input$filters

    # count how many filters I selected
    n = length(filter_names)     

    # to render n selectInput    
    lapply(1:n,function(x){
      output[[paste0("FILTER_",x)]] = renderUI({
        req(input$filters)
        div( class = "dynamicSI",

             dropdownButton(
               label = paste0(filter_names[x]), status ="default",width =50,

                   actionButton(inputId = paste0("filter_all_",x), label = "(Un)select all",
                                class="btn btn-primary btn-sm",
                                data = paste0("filter_",x),
                                name = paste(filter_names[x])
                   )

               ,
               checkboxGroupInput(paste0("filter_",x),"",
                                  choices = sort(unique(R[,filter_names[x]])),
                                  selected = unique(R[,filter_names[x]])
                                  )
             )


        )
      })
    })

    output$FILTER_GROUP = renderUI({
      div(class="dynamicSI",
          lapply(1:n, function(i){
            uiOutput(paste0("FILTER_",i))
          })
      )

    })

  })


  observeEvent(input$lastSelect, {

    if (!is.null(input$lastSelectId)) {
      cat("lastSelectId:", input$lastSelectId, "\n")
      cat("lastSelectName:", input$lastSelectName, "\n")
    }  
    # selectInput id
    Filter = input$lastSelectId
    # column name of dataset, (label on select input)
    NAME = input$lastSelectName
    choices = unique(mtcars[,NAME])

    if (length(input[[Filter]]) == 0) {
      # in corresponding selectInput has no elements selected
      updateSelectInput(
        session = session, inputId = Filter, selected = as.character(choices)
      )
    } else {
      # has at least one element selected
      updateSelectInput(
        session = session, inputId = Filter, selected = ""
      )
    }

  })

  output$L = renderPrint({
    input$lastSelectId
  })
}


ui <- fluidPage(
  tags$script("$(document).on('click', '.dynamicSI button', function () {
              var id = document.getElementById(this.id).getAttribute('data');
              var name = document.getElementById(this.id).getAttribute('name');
              Shiny.onInputChange('lastSelectId',id);
              Shiny.onInputChange('lastSelectName',name);
              // to report changes on the same selectInput
              Shiny.onInputChange('lastSelect', Math.random());
              });"),  

  uiOutput("FILTERS"),
  hr(),
  uiOutput("FILTER_GROUP"),
  hr(),
  verbatimTextOutput("L")

)

shinyApp(ui = ui, server = server)

R Shiny: nested observe functions

2 Answers2