響應式更新模塊化 Shiny 應用程序中的側邊欄

Question

我有一個使用bs4Dash的模塊化Golem應用程序。 我想從從actionBttn動態生成的renderUI更新活動側邊欄選項卡。 雖然updatebs4ControlbarMenu可以按此處所示的預期工作，但它在應用程序的模塊化版本中不起作用。 我究竟做錯了什么？ 我懷疑它與跨模塊的input[[btnID]]管理有關，但我很難找到解決方案。

沒有模塊的工作示例，如下所示：

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)

Answer 1

在探索了function updatebs4TabSetPanel()的例子后，似乎選擇的值需要是一個數字。
因此，您可以將此代碼與 CRAN 版本 0.5.0 一起使用：

         updatebs4ControlbarMenu(
            session,
            inputId = "sidebr",
            selected = "2" #"exdet2"
          )