Reactively updating sidebar in modular Shiny app

问题

I have a modularized Golem app using bs4Dash. I want to update the active sidebar tab from an actionBttn that is dynamically generated from renderUI. While updatebs4ControlbarMenu works as expected as shown here, it does not work in the modularized version of the application. What am I doing wrong? I suspect it is related to input[[btnID]] management across modules but I struggle to find the solution.

Working example without modules 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"
          )
        })
      })
    })
    
  }
)

Modularized attempt not working:

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)

回答1:

After exploring the example of function updatebs4TabSetPanel() that is in the same family, it seems that the selected value needs to be a number.
Hence, you can use this code with CRAN version 0.5.0:

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

来源：https://stackoverflow.com/questions/65262056/reactively-updating-sidebar-in-modular-shiny-app