R 根据从其他菜单中选择的内容更新其他菜单

我目前有一个闪亮的应用程序，有3个菜单，一旦bug解决了，还可以添加更多的菜单。 我在网上找到了自顶向下菜单过滤方法的示例。这意味着用户必须依次从第一个菜单、第二个菜单中进行选择，以此类推。如果他们先从第二个菜单中选择，那么它不会过滤第一个菜单，只过滤它下面的菜单，显然这是一个问题。 我希望我的用户能够以任何顺序跳转到菜单，并对它们进行筛选。 在我的示例中有3个菜单，我试图做的是，如果ObserveeEvent在任何菜单上用户从任何菜单中进行选择，那么：

根据所做的选择筛选数据 为尚未选择输入的任何菜单更新SelectInput 这将确保菜单与数据中实际存在的内容是最新的，并确保用户不会切分到数据中实际不存在的内容。 另外，请注意，第2步非常重要-只更新菜单而不进行选择，我对此有问题，因为如果我只更新所有其他菜单，那么它会清除用户选择的输入，这仍然是错误的行为。 我知道我需要做什么，但我还没能完成，所以非常感谢你的帮助

更新 我更新了我的代码以使用下面发布的一个答案，但它仍然不能正常工作。 现在它确实会过滤菜单，但是，一旦创建了子集，它就不允许对其进行过滤备份。 我的意思是，如果我从第一个菜单TreeNumber中选择值3，那么最后一个菜单只过滤到值300-这很好。但是如果我回到第一个菜单并选择值4，我希望圆周菜单现在会显示值：300和400，但是，它仍然只显示值300

更新代码：

d <- data.frame("TreeNumber" = c(replicate(7, 1), replicate(7, 2), 
                                 replicate(7, 3), replicate(7, 4)),
                "TreeAge" = c(1:28),
                "Circumference" = c(replicate(7, 100), replicate(7, 200), 
                                    replicate(7, 300), replicate(7, 400)))
col_names <- names(d)
# TODO - change these to: "Tree Number", "Tree Age", "Circumference"
user_friendly_names <- c('TreeNumber', 'TreeAge', 'Circumference')

ui <- fluidPage(  
  sidebarLayout(
    sidebarPanel(
      h3("Filters:"),
      uiOutput("filters"),

      # Plot button
      fluidRow(column(2, align = "right",
                      actionButton("plot_graph_button", "Plot")))
    ),
    mainPanel(tableOutput("summary"))
  )
)

server <- function(input, output, session) {
  #### Create the filter lists for UI ####
  output$filters <- renderUI({
    if(is.null(col_names)) return(NULL)
    lapply(1:length(col_names), function(i) {
      col <- paste0(col_names[i])
      alias <- user_friendly_names[i]
      # Populate input with unique values from column
      pickerInput(inputId = alias, label = paste(alias,':'),
                     choices = unique(d[[col]]), multiple = T)
    })
  })


  # lapply(X = vars, FUN = function(x) {
  #   vals <- sort(unique(data[[x]]))
  #   updatePickerInput(session = session, inputId = x, choices = vals)
  # })

  my_filter <- function(data, var) {
    # TODO - Need to convert from user_friendly_names --> col_names in here
    if (length(input[[var]]) == 0) return(data)
    data %>% subset(data[[var]] %in% input[[var]])
  }  

  subsettedData <- reactive({
    d %>% my_filter("TreeNumber") %>% my_filter("TreeAge") %>%
      my_filter("Circumference")
    # TODO - get into for loop versus hard coding this step:
    # for(z in 1:length(col_names)){
    #   d %>% my_filter(col_names[z])
    # }
  })

  observeEvent(subsettedData(), {
    lapply(col_names, function(var) {
      selections <- unique(subsettedData()[[var]])
      if (length(input[[var]]) == 0)
        updatePickerInput(session = session, inputId = var, choices = selections)
    })
  }) 


  observeEvent(input$plot_graph_button, {
    for (j in seq_along(d)) {
      updateSelectInput(session = session, inputId = user_friendly_names[j], 
                        choices = c("All", unique(d[[j]])), selected = "All")
    }
  })


  output$summary <- renderTable({
    # Do not show a plot when the page first loads
    # Wait until the user clicks "Plot" button
    if (input$plot_graph_button == 0){
      return()
    }
    # Update code below everytime the "Plot" button is clicked
    input$plot_graph_button

    isolate({
      # Fresh copy of the full data set every time "Plot" button is clicked
      d <- copy(Orange)

      # Filter data based on UI
      for(f in 1:length(col_names)){

        if(eval(parse(text = paste0('is.null(input$',user_friendly_names[f],')')))){
          # Default to "All" - do not filter
          print("All")
        }else{                
          d <- d[d[[col_names[f]]] == 
                    unlist(eval(parse(text = 
                       paste0('input$',user_friendly_names[f])))), ]
        }
      }
      final_summary_table <<- d
    })
  })
}

shinyApp(ui = ui, server = server)

---

下面是一个应用程序，它基于所有输入应用过滤。我不知道用multiple=TRUE在selectInput中给出一个名为all的选择有多直观。也许最好为每个选择添加一个重置按钮

我用提示替换了数据集橙色，以获得更多的因子变量。另外，我在示例中没有使用data.table，因为它似乎与您的问题无关

library(shiny)
library(dplyr)

data(tips, package = "reshape2")
filter_vars <- c("sex", "smoker", "day", "time")

ui <- fluidPage(
  lapply(filter_vars, function(var) {
    selectInput(var, var, unique(tips[[var]]), multiple = TRUE)
  }),
  tableOutput("table")
)

server <- function(input, output, session) {
  my_filter <- function(data, var) {
    if (length(input[[var]]) == 0) return(data)
    data %>% subset(data[[var]] %in% input[[var]])
  }  

  subsettedData <- reactive({
    tips %>% my_filter("sex") %>% my_filter("smoker") %>% 
      my_filter("day") %>% my_filter("time")
  })

  observeEvent(subsettedData(), {
    lapply(filter_vars, function(var) {
      selections <- unique(subsettedData()[[var]])
      if (length(input[[var]]) == 0)
        updateSelectInput(session, var, choices = selections)
    })
  })   

  output$table <- renderTable({ subsettedData() })
}

shinyApp(ui, server)

---

复制定义在哪里？您能用shiny:：updateSelectizeInput完成此操作吗？@r2evans copy是一个函数。只是复制数据以确保我不会写任何东西。我想在解决方案中将使用update___;，是的。@r2evans copy位于data.table命名空间中，用于创建data.table对象的深度副本。它也可以应用于data.frames，在这种情况下，它的行为类似于as.data.table.My bad。。。我做了一个通用的？？复制，它没有返回数据。table:：copy，我对data.table不太熟悉，但我手动看到它就在那里。谢谢当然，现在，copy正在返回那个函数，所以我需要更多或更少的咖啡因。我使用我的代码示例只是为了使事情简化，但在我更复杂的代码中，我放弃了一切，因为这不是处理菜单的好方法，正如你所指出的。你的代码生成一个文本输入菜单，我的是一个下拉菜单。这段代码与我的示例不太相似，无法以我需要的方式工作。在您的示例中，当某个内容被删除时，它就消失了，这是一个缺陷。请参阅我编辑的解决方案。对我来说，不清楚子设置是否应该是可逆的。对于这一部分：子设置数据%my_FilterEx%>%my_filtersmoker%>%my_filterday%>%my_filtertime}是否有办法避免对每个类别进行硬编码？另外，请查看shinyWidgets:：pickerGroupServer，以获得现成的解决方案