R Shiny：嵌套观察函数
问题描述：
对于示例数据集mtcars，我们希望使用"cyl","am","carb","gear"作为候选过滤器（selectInput小部件）。用户应该能够选择他们想要的过滤器。R Shiny：嵌套观察函数
对于每个筛选出的筛选器，都有一个与其关联的“（全部）全选”按钮。
我的问题是，由于过滤器的数量不固定，因此生成observeEvent语句的循环语句必须位于另一个observe函数中。
请运行以下可重复的代码。
任何建议，使'（un）全选'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)
答
你的代码有很多问题，1）您使用的is.null代替length评估要素在selectInput数量。 2）您正在使用updateCheckboxGroupInput而不是updateSelectInput。 3）如果你把观察者放在另一个观察者的内部，你将为同一个事件创建多个观察者。 4）你在最后一个观察者中缺少一些{}，并且在服务器功能中有一个额外的)。
推荐answer的想法是跟踪最后一个点击的按钮，以避免多个观察者。在你的问题中，除了只有一个观察者（并且避免嵌套的观察者）之外，想法是知道(Un)Select All按钮旁边对应的selectInput的id。目标是仅更新特定的选择输入。在您的代码中，更新将应用于所有selectInput's。
我们需要为每个actionButton添加selectInput的ID和与该selectInput相关联的mtcars数据集的列名。为此，我们可以添加属性：data为id，name为列名称。使用JavaScript，我们可以检索这些属性并将它们分别发送回服务器，分别为input的lastSelectId和lastSelectName。
下面是您的代码修改为具有JavaScript函数来处理选择器button的click事件。请注意，我们还需要将每个selectInput和actionButton换成div与class = "dynamicSI"以区别于其他按钮。
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)
})
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",
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",
data = paste0("filter_",x), # selectInput id
name = paste0(filter_names[x])) # name of column
)
})
})
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)
答
@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)
如果我们使用'dropdownButton'部件看看这个答案http://*.com/questions/40631788/shiny-observe-triggered-by-dynamicaly-generated-inputs/40643541#40643541 – Geovany