我想从下拉菜单中的数据集中选择一个样本。
由于有许多样本可供选择，我想通过在复选框下拉菜单中选择其他数据列的值来缩小可选样本的范围。
我可以成功地创建复选框下拉菜单，并打印那里所做的选择。
我很难将这些相同的选定值输入到选择样本的下拉菜单中，我想对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)
2条答案
按热度按时间nnvyjq4y1#
试试这段代码。我构建它时没有模块，它有点简单，但它能工作。
我将第2个样品ID -〉更改为
Sample 3，因为我需要证明一个样品具有多个组。希望这能帮到你。
vlju58qv2#
解决：感谢Yeyo使用pickerInput的建议，我能够摆脱我的自定义小部件模块的怪物，并让它用更少的代码很好地工作！