R Shiny：无法访问存储在反应元素列表中的变量

Question

我想 select 在下拉菜单中从我的数据集中抽取一个样本。

由于有很多样本可供选择，我想通过在复选框下拉菜单中选择附加数据列的值来缩小可选择样本的范围。

我可以成功创建复选框下拉菜单并打印在那里所做的选择。

我正在努力将这些相同的选定值输入到选择样本的下拉菜单中。 我想使 selectInput 的选择成为反应式的，但不能像在 renderText() 中那样访问变量。

请参阅代码中的注释以了解我被卡住的地方。

谢谢！

library(shiny)
library(dplyr)


##################################
#### checkbox dropdown module ####
##################################

mod_ui_checkbox_dropdown_ui <- function(id){
  ns <- NS(id)
  
  tagList(
    uiOutput(ns("choice_dropdown"))
    
  )
}


mod_ui_checkbox_dropdown_server <- function(id, dropdown_label = "Items", menu_choices = c("item1", "item2", "item3"), dropdown_status = "default"){
  
  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 = "max-width: 300px;",
      #style = if (!is.null(width))
      #  paste0("width: ", validateCssUnit(width), ";"),
      lapply(X = list(...), FUN = tags$li, style = "margin-left: 10px; margin-right: 10px;")
    )
    # dropdown button appearance
    html_button <- list(
      class = paste0("btn btn-", status," dropdown-toggle"),
      style = "width: 100%; max-width: 300px; display: flex; justify-content: space-between;",
      type = "button",
      `data-toggle` = "dropdown"
    )
    html_button <- c(html_button, list(label))
    html_button <- c(html_button, list(tags$span(class = "caret", style = "margin-top: 8px;")))
    # final result
    tags$div(
      class = "dropdown",
      do.call(tags$button, html_button),
      do.call(tags$ul, html_ul),
      tags$script(
        "$('.dropdown-menu').click(function(e) {
      e.stopPropagation();
});")
    )
  }
  
  
  moduleServer( id, function(input, output, session){
    ns <- session$ns
    
    
    # output$selected_items <- renderPrint({
    #   input$dropdown_checkboxes
    # })
    
    
    output$choice_dropdown <- renderUI({
      dropdownButton(
        label = dropdown_label, status = dropdown_status, width = "100%",
        actionButton(inputId = ns("all"), label = "all/none", class = "btn btn-sm", style = "margin-bottom: 8px;"),
        checkboxGroupInput(inputId = ns("dropdown_checkboxes"), label = NULL, choices = menu_choices, selected = menu_choices)
      )
    })
    
    
    
    
    # Select all / Unselect all
    observeEvent(input$all, {
      if (is.null(input$dropdown_checkboxes)) {
        updateCheckboxGroupInput(
          session = session, inputId = "dropdown_checkboxes", selected = menu_choices
        )
      } else {
        updateCheckboxGroupInput(
          session = session, inputId = "dropdown_checkboxes", selected = ""
        )
      }
    })
    
    
    # return selected values
    return(reactive(input$dropdown_checkboxes))
    
  })
}









##################
#### main app ####
##################

ui <- fluidPage(
  
  textOutput("text"),
  uiOutput("sample_dropdown"),
  #uiOutput("manual_checks"),
  br(),
  br(),
  uiOutput("sample_filters"),
  
)

server <- function(input, output, session) {
  
  
  
  data <- tibble::tibble("Sample ID" = c("Sample1", "Sample2", "Sample3", "Sample4", "Sample5", "Sample6"),
                         "Group" = c("group1", "group1", "group2", "group2", "group3", "group3"),
                         "Name" = c("Aime", "Balthasar", "Charlotte", "Daniel", "Emilie", "Fiona"))
  
  ns <- session$ns
 
  
  # helper function. filters dataframe columns for only the entries listed in selected_values
  # selected_values is a list with an entry for each filter dropdown that holds a reactive vector with the selected items from each dropdown
  
  filter_selection <- function(data, selected_values){
    # loop through list by names of the list items
    for (val in names(selected_values)){
      if(!is.null(val)){
        data <- dplyr::filter(data, .data[[val]] %in% selected_values[[val]]())
      }
    }
    return(data)
  }
  
  ### select sample ###
  
  # get selectable samples from study data
  selectable_samples <- reactive({

##### HERE BE DRAGONS 
##### THIS DOES NOT WORK: When I try to access the values from the checkboxes here in this reactive element, I only get the empty list().
##### How do I make this reactive element respond to the selected values?

    ### ONLY PRINTS EMPTY LIST ###
    print(selected_values)
    ### THIS GIVES AN ERROR ###
    #print(selected_values$Name())
    
    data %>%
      
      # filter the choices based on the selected values here
      {if(length(selected_values) != 0) filter_selection(., selected_values) else .} %>%
      
      dplyr::select(any_of("Sample ID")) %>%
      unique() %>%
      pull() %>%
      sort()
   
  })
  
  
  
  output$sample_dropdown <- renderUI({
      selectInput("sample_dropdown", label = NULL, choices = selectable_samples())
  })
  
  
  
  
  ## ---- sample filters ##
  ## this dynamically creates checkbox dropdown menus for selected filter columns
  sample_filter_cols <-  c("Group", "Name")
  
  
  # create filter module UI elements
  output$sample_filters <- renderUI(
    sapply(sample_filter_cols, function(fav){
      mod_ui_checkbox_dropdown_ui(stringr::str_replace_all(fav, " ", "-")) #IDs don't like spaces
    })
  )
  
  # capture filter module outputs in list
  # solution using a list and observe() adapted from here
  # https://stackoverflow.com/questions/57802428/looping-shiny-callmodule-only-exports-last-value
  selected_values <- list()
  observe(
    selected_values <<- sapply(sample_filter_cols, function(x){

      choices <- data %>%
        select(any_of(x)) %>%
        unique() %>%
        pull() %>%
        sort()
        
      mod_ui_checkbox_dropdown_server(stringr::str_replace_all(x, " ", "-"), dropdown_label =  x, menu_choices = choices)
    }, USE.NAMES = TRUE)
  )
  
 
##### THIS WORKS: I can access the selected values of the filter columns here and print them as text.
##### So why won't this propagate to the reactive element above?

output$text <- renderText(paste("selected values:",
                                 paste(selected_values$Name(), collapse = " "),
                                 paste(selected_values$Group(), collapse = " ")
                                 ))



}

shinyApp(ui, server)

Answer 1

试试这段代码。 我在没有模块的情况下构建了它，它有点简单，但它可以工作。

我将第二个样本 ID -> 更改为Sample 3 ，因为我需要用多个组来证明一个样本。

我希望这可以帮助你。

library(shiny)
library(shinyWidgets)
require(tibble)


data_read <<- 
  tibble::tibble(
    "Sample ID" = c("Sample1", "Sample3", "Sample3", "Sample4", "Sample5", "Sample6"),
        "Group" = c("group1", "group1", "group2", "group2", "group3", "group3"),
         "Name" = c("Aime", "Balthasar", "Charlotte", "Daniel", "Emilie", "Fiona"))

if (interactive()) {
  
  
  reactive_data <- reactiveValues(
    data_all = data_read,
    data_sample_filter = data_read[0,],
    vector_groups = NULL,
    group_selected = c(),
    vector_names = NULL,
    
  )
  
  ui <- fluidPage(
    selectInput(
      "sample_dropdown",
      label = NULL,
      choices = data_read$`Sample ID` %>% unique 
      ),
    uiOutput("group_dropdown"),
    uiOutput("names_dropdown"),
    
    verbatimTextOutput("texto"),
    tableOutput("table")
    
  )
  
  
  server <- function(input, output) {

    observe({
      
      data_filter_group <<-
        data_read %>% 
        filter(
          `Sample ID` %in% input$sample_dropdown
        )
      
      
      output$group_dropdown <- renderUI({
        pickerInput(
          inputId = "group_dropdown",
          label   = "select group(s)", 
          choices = isolate(reactive_data$vector_groups),
          options = 
            list(
              `actions-box` = TRUE
            ), 
          multiple = TRUE
        )
      })
      
      # Change reactive values
      reactive_data$data_sample_filter <- data_filter_group
      reactive_data$vector_groups <-    data_filter_group$Group %>% unique

      
    },
    label = "group_dropdown UI"
    )
    
    
    observe({
      # save reactive values input group
      reactive_data$group_selected <- input[["group_dropdown"]]
      
      
      data_filter_names <<-
        isolate(reactive_data$data_sample_filter) %>%
        filter(
          Group %in% isolate(reactive_data$group_selected)
        )
      
      # Change reactive values
      reactive_data$vector_names <-    data_filter_names$Name %>% unique
      
      
      output$names_dropdown <- renderUI({
        pickerInput(
          inputId = "names_dropdown",
          label = "select group(s)", 
          choices = isolate(reactive_data$vector_names),
          options = list(
            `actions-box` = TRUE), 
          multiple = TRUE
        )
      })
      
    },
    label = "names_dropdown UI"
    )
   
  
    
    # example  all data output
    output$table <- 
    renderTable({
      data_read
    })
    
    output$texto <-
      renderText({
        paste("selected values:\n",
              input$sample_dropdown,"\n\t",
              paste( input[["group_dropdown"]],sep="" ,collapse = "\n\t"),"\n\t\t",
              paste( input[["names_dropdown"]],sep="" ,collapse = "\n \t\t")
        )
      })

    
  }
  shinyApp(ui, server)
}

Answer 2

已解决：多亏了 Yeyo 关于使用 pickerInput 的建议，我才能够摆脱自定义小部件模块的怪异，并使用更少的代码让它很好地工作！

library(shiny)
library(shinyWidgets)
library(dplyr)


#' Helper Function
#'
#' @description helper function to filter the choices of a dropdown menu based on selected data
#'
#' @return character vector with choices that remain after filtering the data
#' 
#' @param data data frame to be filtered
#' @param choice_col name of the column that holds all possible values for the dropdown menu. e.g. if the dropdown menu chooses sample ids, this may be the "Sample ID" column
#' @param filter_selections list with selected values from all filter dropdown menus. e.g. list("Group" = c("group1", "group2), "Names" = c("Aime", "Balthasar")), will produce all samples that are in these two groups and belong to these two names.
#'
#' @noRd


filter_choices <- function(data, choice_col, filter_selections){
  
  choices <- data
  
  for (filter_col in names(filter_selections)){
    choices <- choices %>%
      dplyr::filter(., .data[[filter_col]] %in% filter_selections[[filter_col]])
  }
  
  choices <- choices %>%
    dplyr::select(any_of(choice_col)) %>%
    unique() %>%
    pull() %>%
    sort()
  
  return(choices)
}





##################
#### main app ####
##################


ui <- fluidPage(
  
  uiOutput("sample_dropdown"),
  h3("Filters"),
  uiOutput("sample_filters")
)

server <- function(input, output, session) {
  
  
  
  data <- tibble::tibble("Sample ID" = c("Sample1", "Sample2", "Sample3", "Sample4", "Sample5", "Sample6"),
                         "Group" = c("group1", "group1", "group2", "group2", "group3", "group3"),
                         "Name" = c("Aime", "Balthasar", "Charlotte", "Daniel", "Emilie", "Fiona"))
  
  

  ### dropdown to select a sample from the data ###
  selectable_samples <- reactive({
    filter_choices(data, choice_col = "Sample ID", filter_selections = selected_values())
  })
  
  output$sample_dropdown <- renderUI({
    shinyWidgets::pickerInput("sample_dropdown", label = "Select Sample", choices = selectable_samples())
  })
  
  
  ### ---- dropdowns to narrow down choices of samples I am interested in ###
  # specify which data columns you want to be able to filter by
  sample_filter_cols <-  c("Group", "Name")

  # create picker UI elements for these columns
  output$sample_filters <- renderUI(
    div(
      lapply(sample_filter_cols, function(x){
        choices <- data %>%
          select(any_of(x)) %>%
          unique() %>%
          pull() %>%
          sort()
        shinyWidgets::pickerInput(stringr::str_replace_all(x, " ", "-"),
                                  label = x,
                                  choices = choices,
                                  multiple = TRUE,
                                  selected = choices,
                                  options = list(`actions-box` = TRUE))
      })
    )
  )
  
  # collect output of filter dropdown menus in a reactive list
  selected_values <- reactive({
    sapply(sample_filter_cols, function(x){
      input[[stringr::str_replace_all(x, " ", "-")]]
    }, USE.NAMES = TRUE)
  })
  
 
}
 
shinyApp(ui, server)