[英]R Shiny: nested observe functions
For the sample data set mtcars
, we want to use "cyl","am","carb","gear"
to be the candidate filters(selectInput widgets). 对于样本数据集
mtcars
,我们希望使用"cyl","am","carb","gear"
作为候选过滤器(selectInput小部件)。 Users should be able to select the filter they want. 用户应该能够选择他们想要的过滤器。
And for each filter picked, there is an '(un)select all' button associated with it. 对于选择的每个过滤器,都有一个与之关联的“(全部)取消选择”按钮。
My issue is, since the number of filters is not fixed, so the loop statement to generate the observeEvent
statements has to be in another observe
function. 我的问题是,由于过滤器的数量是不固定的,所以循环语句生成
observeEvent
报表必须是在另一个observe
功能。
Please run the following reproducible code. 请运行以下可复制代码。
Any suggestions to make the '(un)select all' botton work? 有什么建议可以使“(取消)全选”按钮起作用? thanks.
谢谢。
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)
Your code has many problems, 1) You are evaluating the number of elements in a selectInput
using is.null
instead of length
. 您的代码有很多问题,1)您正在使用
is.null
而不是length
来评估selectInput
的元素数量。 2) You are using updateCheckboxGroupInput
instead of updateSelectInput
. 2)您正在使用
updateCheckboxGroupInput
而不是updateSelectInput
。 3) If you a put an observer inside another observer, you will be creating multiple observers for the same event. 3)如果将一个观察者放在另一个观察者中,则将为同一事件创建多个观察者。 And 4) you have some missing
{}
in your last observer and a extra )
in the server function. 并且4)您的最后一个观察者中缺少
{}
,而服务器函数中还有一个额外的)
。
The idea on the recommended answer is to keep track of the last button clicked to avoid multiple observers. 推荐答案的主意是跟踪单击的最后一个按钮,以避免多个观察者。 In your problem, in addition to have only one observer (and avoid nested observers), the idea is to know the
id
of the corresponding selectInput
next to the (Un)Select All
button. 在您的问题中,除了只有一个观察者(并避免嵌套的观察者)之外,其想法是知道
(Un)Select All
按钮旁边的相应selectInput
的id
。 The goal is to only update that specific select input. 目标是仅更新特定的选择输入。 In your code, the update will be applied to all the
selectInput
's. 在您的代码中,更新将应用于所有
selectInput
。
We need to add to each actionButton
the id of the selectInput
and the column name of the mtcars
dataset associated with that selectInput
. 我们需要向每个
actionButton
添加selectInput
的ID和与该selectInput
相关联的mtcars
数据集的列名。 For that purpose, we can add the attributes: data
for the id, and name
for the column name. :为此,我们可以添加的属性
data
的ID,并name
为列名。 With JavaScript we can retrieve that attributes and send them back to the Server as the input
's lastSelectId
and lastSelectName
respectively. 使用JavaScript,我们可以检索该属性,并将它们分别作为
input
的lastSelectId
和lastSelectName
发送回服务器。
Below is your code modified to have a JavaScript function to handle the click
event for the selector button
. 下面是修改后的代码,使其具有JavaScript函数来处理选择器
button
的click
事件。 Please note that we also need to wrap each selectInput
and actionButton
in a div
with class = "dynamicSI"
to distinguish from others buttons. 请注意,我们还需要将每个
selectInput
和actionButton
在class = "dynamicSI"
的div
,以区别于其他按钮。
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 @Geovany
Updated 更新
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)
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.