R Shiny：嵌套观察功能

Question

对于样本数据集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)

Answer 1

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

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

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

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

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)

Answer 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)