对于示例数据集mtcars，我们希望使用"cyl","am","carb","gear"作为候选过滤器（selectInput小部件）。用户应该能够选择他们想要的过滤器。
对于每个选中的过滤器，都有一个与其关联的“（取消）全选”按钮。
我的问题是，由于过滤器的数量没有固定，因此生成observeEvent语句的循环语句必须在另一个observe函数中。
请运行以下可重现的代码。
任何建议'（联合国）选择所有'botton工作？感谢。
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)
答案 0 :(得分：2)
您的代码存在许多问题，1）您正在使用selectInput而不是is.null评估length中的元素数量。 2）您使用updateCheckboxGroupInput代替updateSelectInput。 3）如果你将一个观察者放在另一个观察者中，你将为同一个事件创建多个观察者。 4）你在上一个观察者中有一些{}，在服务器函数中有一个额外的)。
推荐answer的想法是跟踪点击的最后一个按钮以避免多个观察者。在您的问题中，除了只有一个观察者（并避免使用嵌套观察者）之外，我们的想法是知道id按钮旁边相应selectInput的{{1}}。目标是仅更新特定的选择输入。在您的代码中，更新将应用于所有(Un)Select All。
我们需要向每个selectInput添加actionButton的ID以及与该selectInput相关联的mtcars数据集的列名称。为此，我们可以为id添加属性selectInput，为列名添加data。使用JavaScript，我们可以检索这些属性，并将它们分别作为name input和lastSelectId发送回服务器。
以下代码已修改为具有JavaScript函数来处理选择器lastSelectName的{{1}}事件。请注意，我们还需要将每个click和button打包在selectInput actionButton中，以区别于其他按钮。
div答案 1 :(得分：1)
@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)