Question

我目前有一个带有3个菜单的Shiny应用程序（解决错误后将添加更多菜单）。
我在网上找到了自上而下的菜单过滤方法的示例。意味着用户必须从第一个菜单中选择，然后从第二个菜单中选择，依此类推，但是要按顺序进行。如果他们首先从第二个菜单中进行选择，则它不会过滤第一个菜单，只会过滤其下面的菜单，这显然是个问题。
我希望我的用户能够以任意顺序跳转到菜单并对其进行过滤。
在我的示例中，有3个菜单，而我要尝试的是如果任何菜单上的observeEvent（用户从任何菜单中进行选择），则：

根据所做的选择过滤数据
updateSelectInput用于尚未选择输入的任何菜单

这将确保菜单与数据中的实际内容保持最新，并确保用户不会将数据切成实际不存在的内容。
另外，请注意，步骤2非常重要-仅更新菜单而不进行选择，我对此有疑问，因为如果我仅更新所有其他菜单，那么它将清除用户选择的输入，即仍然是错误的行为。
我知道我需要做的事情，但还无法完成，因此我们感谢您的帮助。

更新我更新了代码以使其与下面发布的一个答案一起使用，但仍然无法正常工作。现在，它确实过滤菜单，但是，一旦创建了子集，就不允许其“过滤”备份。
我的意思是，如果我从第一个菜单3中选择值TreeNumber，那么最后一个菜单将过滤为仅值300-很好。但如果然后我回到第一个菜单并选择值4，我希望Circumference菜单现在将显示值：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)

Answer 1

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

我用Orange替换了数据集tips，以获取更多因子变量。另外，在该示例中我没有使用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)

根据其他菜单中的选择更新其他菜单

1 个答案: