如何使用 `renderUI` 响应式更新 Shiny 应用程序中的活动菜单项?
Posted
技术标签:
【中文标题】如何使用 `renderUI` 响应式更新 Shiny 应用程序中的活动菜单项?【英文标题】:How can I reactively update the active menuItem in a Shiny app using `renderUI`? 【发布时间】:2021-03-21 19:16:17 【问题描述】:我正在构建一个闪亮的应用程序,它可以从数据框中动态创建反应性 bs4Box
元素。我想让用户可以点击这些框,以便自动重定向到不同的 menuItem。我已经阅读并遵循了类似的先前 SO 问题,例如 this one 或 this issue,但没有成功。 javascript 解决方案like this one 也可以工作?
到目前为止,这是我使用 updatebs4ControlbarMenu
函数的尝试:
library(shiny)
#> Warning: package 'shiny' was built under R version 3.6.3
library(shinyWidgets)
#> Warning: package 'shinyWidgets' was built under R version 3.6.3
library(bs4Dash)
#>
#> Attaching package: 'bs4Dash'
#> The following objects are masked from 'package:shiny':
#>
#> column, tabPanel, tabsetPanel, updateTabsetPanel
#> The following object is masked from 'package:graphics':
#>
#> box
library(tidyverse)
#> Warning: package 'ggplot2' was built under R version 3.6.3
#> Warning: package 'tibble' was built under R version 3.6.3
#> Warning: package 'tidyr' was built under R version 3.6.3
#> Warning: package 'readr' was built under R version 3.6.3
#> Warning: package 'purrr' was built under R version 3.6.3
#> Warning: package 'dplyr' was built under R version 3.6.3
shinyApp(
ui = bs4DashPage(
sidebar_collapsed = FALSE,
controlbar_collapsed = TRUE,
enable_preloader = FALSE,
navbar = bs4DashNavbar(skin = "dark"),
sidebar = bs4DashSidebar(
inputId = "sidebarState",
bs4SidebarMenu(
id = "sidebr",
bs4SidebarMenuItem(
"Tab 1",
tabName = "tab1"
),
bs4SidebarMenuItem(
"Tab 2",
tabName = "tab2"
)
)
),
bs4DashBody(
bs4TabItems(
bs4TabItem(
tabName = "tab1",
h1("Welcome!"),
fluidRow(
pickerInput(
inputId = "car",
label = "Car",
choices = row.names(mtcars),
selected = head(row.names(mtcars), 3),
multiple = TRUE,
options = list(
`actions-box` = TRUE)
),
pickerInput(
inputId = "gear",
label = "Gear",
choices = unique(mtcars$gear),
selected = unique(mtcars$gear),
multiple = TRUE,
options = list(
`actions-box` = TRUE)
)
),
fluidRow(
column(6,
uiOutput("uiboxes")
)
)
),
bs4TabItem(
tabName = "tab2",
h4("Yuhuuu! You've been directed automatically in Tab 2!")
)
)
)
),
server = function(input, output, session)
submtcars <- reactive(
req(input$car, input$gear)
mtcars %>%
mutate(
carnames = rownames(mtcars)) %>%
filter(
carnames %in% input$car &
gear %in% input$gear
)
)
observeEvent( submtcars(),
output$uiboxes <- renderUI(
n_ex <- nrow(submtcars())
lapply(1:n_ex, FUN = function(j)
print(paste("j is ", j))
bs4Box(
title = submtcars()$carnames[j],
width = 12,
str_c("Number of gears:", submtcars()$gear[j]),
btnID <- paste0("btnID", j),
print(btnID),
fluidRow(
column(
2,
actionBttn(
inputId = btnID,
icon("search-plus")
)
)
)
)
)
)
)
observeEvent( input$btnID ,
updatebs4ControlbarMenu(
session,
inputId = "sidebr",
selected = "tab2"
)
)
)
#>
#> Listening on http://127.0.0.1:5851
#> [1] "j is 1"
#> [1] "btnID1"
#> [1] "j is 2"
#> [1] "btnID2"
#> [1] "j is 3"
#> [1] "btnID3"
由reprex package (v0.3.0) 于 2020 年 12 月 10 日创建
【问题讨论】:
【参考方案1】:您的问题是如何设置observeEvent
。你只注册一个监听input$btnID
。但是,btnID
只是一个变量,您可以在其中定义操作按钮的不同 ID(在您的情况下为“btnID1”到“btnID3”。因此,您必须使用这些 ID 注册observeEvent
s。为此,您可以再次使用lapply
,如下面的解决方案所示。
library(shiny)
library(shinyWidgets)
library(bs4Dash)
library(tidyverse)
shinyApp(
ui = bs4DashPage(
sidebar_collapsed = FALSE,
controlbar_collapsed = TRUE,
enable_preloader = FALSE,
navbar = bs4DashNavbar(skin = "dark"),
sidebar = bs4DashSidebar(
inputId = "sidebarState",
bs4SidebarMenu(
id = "sidebr",
bs4SidebarMenuItem(
"Tab 1",
tabName = "tab1"
),
bs4SidebarMenuItem(
"Tab 2",
tabName = "tab2"
)
)
),
bs4DashBody(
bs4TabItems(
bs4TabItem(
tabName = "tab1",
h1("Welcome!"),
fluidRow(
pickerInput(
inputId = "car",
label = "Car",
choices = row.names(mtcars),
selected = head(row.names(mtcars), 3),
multiple = TRUE,
options = list(
`actions-box` = TRUE)
),
pickerInput(
inputId = "gear",
label = "Gear",
choices = unique(mtcars$gear),
selected = unique(mtcars$gear),
multiple = TRUE,
options = list(
`actions-box` = TRUE)
)
),
fluidRow(
column(6,
uiOutput("uiboxes")
)
)
),
bs4TabItem(
tabName = "tab2",
h4("Yuhuuu! You've been directed automatically in Tab 2!")
)
)
)
),
server = function(input, output, session)
submtcars <- reactive(
req(input$car, input$gear)
mtcars %>%
mutate(
carnames = rownames(mtcars)) %>%
filter(
carnames %in% input$car &
gear %in% input$gear
)
)
observeEvent( submtcars(),
n_ex <- nrow(submtcars())
output$uiboxes <- renderUI(
lapply(1:n_ex, FUN = function(j)
print(paste("j is ", j))
bs4Box(
title = submtcars()$carnames[j],
width = 12,
str_c("Number of gears:", submtcars()$gear[j]),
btnID <- paste0("btnID", j),
print(btnID),
fluidRow(
column(
2,
actionBttn(
inputId = btnID,
icon("search-plus")
)
)
)
)
)
)
lapply(1:n_ex, function(j)
btnID <- paste0("btnID", j)
observeEvent(input[[btnID]] ,
updatebs4ControlbarMenu(
session,
inputId = "sidebr",
selected = "tab2"
)
)
)
)
)
但是,我认为使用 lapply
和 renderUI
的方法不是很好,因为如果您的输入之一发生变化,所有框都会重新呈现,而有些框可能会保持不变。因此,我推荐使用insertUI
/removeUI
的方法。看看我的一些旧答案,例如https://***.com/a/63758952/12647315
【讨论】:
谢谢@starja。虽然它可以工作,但我的应用程序是模块化的,我正在努力实施这个解决方案,正如这里另一个问题中所解释的那样:***.com/q/65262056/7375944以上是关于如何使用 `renderUI` 响应式更新 Shiny 应用程序中的活动菜单项?的主要内容,如果未能解决你的问题,请参考以下文章
如何使用 Spring 响应式通过增量进度更新逐个处理每个产品?