R Shiny：嵌套的观察函数答案

【问题标题】：R Shiny: nested observe functionsR Shiny：嵌套的观察函数
【发布时间】：2017-04-05 14:12:00
【问题描述】：

对于样本数据集mtcars，我们希望使用"cyl","am","carb","gear" 作为候选过滤器（selectInput 小部件）。用户应该能够选择他们想要的过滤器。

对于选择的每个过滤器，都有一个与之关联的“（取消）全选”按钮。

我的问题是，由于过滤器的数量不固定，所以生成observeEvent 语句的循环语句必须在另一个observe 函数中。

请运行以下可重现的代码。

有什么建议可以让“（取消）全选”按钮起作用吗？谢谢。

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)

【问题讨论】：

看看这个答案stackoverflow.com/questions/40631788/…

标签： r shiny

【解决方案1】：

您的代码有很多问题，1) 您正在使用is.null 而不是length 评估selectInput 中的元素数量。 2) 您使用的是updateCheckboxGroupInput 而不是updateSelectInput。 3）如果您将一个观察者放在另一个观察者中，您将为同一事件创建多个观察者。并且 4) 您在最后一个观察者中缺少一些 {}，而在服务器函数中还有一个额外的 )。

推荐的answer 的想法是跟踪最后一次单击的按钮以避免多个观察者。在你的问题中，除了只有一个观察者（并避免嵌套观察者）之外，想法是知道(Un)Select All按钮旁边的对应selectInput的id。目标是仅更新特定的选择输入。在您的代码中，更新将应用于所有selectInput。

我们需要为每个actionButton 添加selectInput 的ID 和与selectInput 关联的mtcars 数据集的列名。为此，我们可以添加属性：data 用于 id，name 用于列名。使用 JavaScript，我们可以检索该属性并将它们分别作为input 的lastSelectId 和lastSelectName 发送回服务器。

以下是修改后的代码，使其具有一个 JavaScript 函数来处理选择器 button 的 click 事件。请注意，我们还需要将每个 selectInput 和 actionButton 包装在 div 和 class = "dynamicSI" 中，以与其他按钮区分开来。

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)

【讨论】：

如果我们使用此链接stackoverflow.com/questions/34530142/… 中定义的dropdownButton 小部件，那么我们应该将div(class = "dynamicSI", ...) 语句放在哪里。
尽可能靠近操作按钮选择所有元素。
我更新了我的代码。我尝试了几个 div 类的地方，但没有一个工作。自定义小部件dropdownButton 是否阻塞了定义类...
似乎只更改div 位置更复杂。我对如何解决这个问题有一些想法。请使用您更新的代码打开另一个问题，这样我们就不会在这里造成混乱。
如果我的措辞没问题，但链接在这里stackoverflow.com/questions/40759834/…

【解决方案2】：

@Geovany

更新

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)

【讨论】：