如何使用 `renderUI` 响应式更新 Shiny 应用程序中的活动菜单项？

Question

我正在构建一个闪亮的应用程序，它可以从数据框中动态创建反应性 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 日创建}

Answer 1

您的问题是如何设置observeEvent。你只注册一个监听input$btnID。但是，btnID 只是一个变量，您可以在其中定义操作按钮的不同 ID（在您的情况下为“btnID1”到“btnID3”。因此，您必须使用这些 ID 注册observeEvents。为此，您可以再次使用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://stackoverflow.com/a/63758952/12647315