【发布时间】：2021-03-23 12:01:33
【问题描述】：
我有一个使用bs4Dash 的模块化Golem 应用程序。我想从renderUI 动态生成的actionBttn 更新活动侧边栏选项卡。虽然updatebs4ControlbarMenu 按预期工作as shown here，但它在应用程序的模块化版本中不起作用。我究竟做错了什么？我怀疑它与跨模块的input[[btnID]] 管理有关，但我很难找到解决方案。
没有模块的工作示例as shown here:
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"
)
})
})
})
}
)
模块化尝试不起作用：
library(shiny)
library(shinyWidgets)
library(bs4Dash)
library(tidyverse)
mod_exlib_ui <- function(id){
ns <- NS(id)
tagList(
fluidRow(
pickerInput(
inputId = ns("car"),
label = "Car",
choices = row.names(mtcars),
selected = head(row.names(mtcars), 3),
multiple = TRUE,
options = list(
`actions-box` = TRUE)
),
pickerInput(
inputId = ns("gear"),
label = "Gear",
choices = unique(mtcars$gear),
selected = unique(mtcars$gear),
multiple = TRUE,
options = list(
`actions-box` = TRUE)
)
),
fluidRow(
column(6,
uiOutput(ns("uiboxes"))
)
)
)
}
mod_exlib_server <- function(id){
moduleServer( id, function(input, output, session){
ns <- session$ns
submtcars <- reactive({
# req(input$car, input$gear)
mtcars %>%
dplyr::mutate(
carnames = rownames(mtcars)) %>%
dplyr::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,
paste("Number of gears: ", submtcars()$gear[j]),
btnID <- paste0("btnID", j),
print(btnID),
fluidRow(
column(
2,
actionBttn(
inputId = ns(btnID),
icon("search-plus")
)
)
)
)
})
})
lapply(1:n_ex, function(j) {
btnID <- paste0("btnID", j)
observeEvent(input[[btnID]] , {
print(btnID)
updatebs4ControlbarMenu(
session,
inputId = "sidebr",
selected = "exdet2"
)
})
})
})
})
}
app_ui <- tagList(
bs4DashPage(
navbar = bs4DashNavbar(),
sidebar = bs4DashSidebar(
expand_on_hover = TRUE,
inputId = "sidebarState",
bs4SidebarMenu(
id = "sidebr",
bs4SidebarMenuItem(
"Tab 1",
tabName = "tab1"
),
bs4SidebarMenuItem(
"Tab 2",
tabName = "tab2"
)
)
),
bs4DashBody(
bs4TabItems(
bs4TabItem(
tabName = "tab1",
h1("Welcome!"),
mod_exlib_ui("exlib_ui_1")
),
bs4TabItem(
tabName = "tab2",
h4("Yuhuuu! You've been directed automatically in Tab 2!")
)
)
)
)
)
app_server <- function( input, output, session ) {
# Your application server logic
mod_exlib_server("exlib_ui_1")
}
shinyApp(
ui = app_ui,
server = app_server)
【问题讨论】：