bs4Dash 控制栏行为 - updateSelectInput 仅在绑定到 actionButton 时成功

Question

我有一个解决方法，我希望能更好地了解发生了什么。

我通过将模块 UI 函数拆分为两个函数，在 bs4Dash 中创建了动态控制栏：mod_UI 和 mod_option_ui。我照常调用dashboardBody函数中的mod_UI函数，但我在服务器端渲染controlBar，传递与活动tabName匹配的mod_option_ui函数。

一个选项有一个 selectInput，我使用 updateSelectInput 根据传入模块的数据更新选项（这是通过另一个模块加载的项目的文件路径）。只有将 updateSelectInput() 函数绑定到 actionButton 依赖项，我才能成功。 （我通过尝试强制观察者使用observeEvent运行发现了这一点）

我不必单击按钮，只需将其放在观察者中就足以让 updateSelectInput 按照我期望的方式运行。

这里有一些可以使用的代码。注释掉 input$updateSelect 行会显示问题。

# --- Demo Module ---
basicMod_ui <- function(id){
  ns <- NS(id)
  tagList(
    textOutput(ns("text"))
  )
}

basicMod_options_ui <- function(id){
  ns <- NS(id)
  tagList(
    actionButton(ns("updateSelect"), label = "Update Select"),
    selectInput(ns("column"), "Select Column", choices = NULL, multiple = TRUE)
  )
}

basicMod_server <- function(id, inputData){
  moduleServer(id, function(input, output, session) {
    observe({
      input$updateSelect # Comment to disable updateSelectInput
      updateSelectInput(session, "column", choices = inputData())
    })
    output$text <- renderText({
      paste("Selected Column: ", paste(input$column, collapse = ", "))
    })
  })
} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

app_ui <- function(request) {
  bs4Dash::dashboardPage(
    header = bs4Dash::dashboardHeader(),
    sidebar = bs4Dash::dashboardSidebar(
      bs4Dash::sidebarMenu(
        id = "sidebar",
        bs4Dash::menuItem(
          text = "basicMod",
          tabName = "basicMod"
        )
      )
    ),
    controlbar = bs4Dash::dashboardControlbar(
      uiOutput("controlbar")
    ),
    footer = bs4Dash::dashboardFooter(),
    body = bs4Dash::dashboardBody(
      bs4Dash::tabItems(
        bs4Dash::tabItem(
          tabName = "basicMod",
          basicMod_ui("basicMod")
        )
      )
    )
  )
}

app_server <- function(input, output, session) {
  
  # Setup Module
  basicMod_server("basicMod", inputData = reactive(LETTERS))
  
  # Setup Dynamic Control Bar - switching on tab allows different option menus
  output$controlbar <- renderUI({
    basicMod_options_ui("basicMod")
  })
}

shinyApp(app_ui, app_server)

Answer 1

此问题基于使用

renderUI

。默认情况下，Shiny 不会更新不可见的输出，这就是您的

output$controlbar

的情况。

您可以通过设置选择退出此行为：

outputOptions(output, "controlbar", suspendWhenHidden = FALSE)

选择退出示例：

library(shiny)

# --- Demo Module ---
basicMod_ui <- function(id){
  ns <- NS(id)
  tagList(
    textOutput(ns("text"))
  )
}

basicMod_options_ui <- function(id){
  ns <- NS(id)
  tagList(
    # actionButton(ns("updateSelect"), label = "Update Select"),
    selectInput(ns("column"), "Select Column", choices = NULL, multiple = TRUE)
  )
}

basicMod_server <- function(id, inputData){
  moduleServer(id, function(input, output, session) {
    observe({
      # input$updateSelect # Comment to disable updateSelectInput
      updateSelectInput(session, "column", choices = inputData())
    })
    output$text <- renderText({
      paste("Selected Column: ", paste(input$column, collapse = ", "))
    })
  })
} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

app_ui <- function(request) {
  bs4Dash::dashboardPage(
    header = bs4Dash::dashboardHeader(),
    sidebar = bs4Dash::dashboardSidebar(
      bs4Dash::sidebarMenu(
        id = "sidebar",
        bs4Dash::menuItem(
          text = "basicMod",
          tabName = "basicMod"
        )
      )
    ),
    controlbar = bs4Dash::dashboardControlbar(
      uiOutput("controlbar")
    ),
    footer = bs4Dash::dashboardFooter(),
    body = bs4Dash::dashboardBody(
      bs4Dash::tabItems(
        bs4Dash::tabItem(
          tabName = "basicMod",
          basicMod_ui("basicMod")
        )
      )
    )
  )
}

app_server <- function(input, output, session) {
  
  # Setup Module
  basicMod_server("basicMod", inputData = reactive({
    LETTERS
  })
  )
  
  # Setup Dynamic Control Bar - switching on tab allows different option menus
  output$controlbar <- renderUI({
    basicMod_options_ui("basicMod")
  })
  outputOptions(output, "controlbar", suspendWhenHidden = FALSE)
}

shinyApp(app_ui, app_server)

但是，关于您的用例

renderUI

根本不需要（我建议尽可能避免它）。您可以直接调用您的模块 UI。

推荐方法：

library(shiny)

# --- Demo Module ---
basicMod_ui <- function(id){
  ns <- NS(id)
  tagList(
    textOutput(ns("text"))
  )
}

basicMod_options_ui <- function(id){
  ns <- NS(id)
  tagList(
    # actionButton(ns("updateSelect"), label = "Update Select"),
    selectInput(ns("column"), "Select Column", choices = NULL, multiple = TRUE)
  )
}

basicMod_server <- function(id, inputData){
  moduleServer(id, function(input, output, session) {
    observe({
      print(inputData())
      # input$updateSelect # Comment to disable updateSelectInput
      updateSelectInput(session, "column", choices = inputData())
    })
    output$text <- renderText({
      paste("Selected Column: ", paste(input$column, collapse = ", "))
    })
  })
} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

app_ui <- function(request) {
  bs4Dash::dashboardPage(
    header = bs4Dash::dashboardHeader(),
    sidebar = bs4Dash::dashboardSidebar(
      bs4Dash::sidebarMenu(
        id = "sidebar",
        bs4Dash::menuItem(
          text = "basicMod",
          tabName = "basicMod"
        )
      )
    ),
    controlbar = bs4Dash::dashboardControlbar(
      # uiOutput("controlbar")
      basicMod_options_ui("basicMod")
    ),
    footer = bs4Dash::dashboardFooter(),
    body = bs4Dash::dashboardBody(
      bs4Dash::tabItems(
        bs4Dash::tabItem(
          tabName = "basicMod",
          basicMod_ui("basicMod")
        )
      )
    )
  )
}

app_server <- function(input, output, session) {
  # Setup Module
  basicMod_server("basicMod", inputData =
                    reactive({
                      invalidateLater(3000L) # update choices every 3s for testing
                      LETTERS[seq_len(round(runif(1L, 1L, 10L)))]
                    })
  )
}

shinyApp(app_ui, app_server)