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

Posted

技术标签:

【中文标题】如何使用 `renderUI` 响应式更新 Shiny 应用程序中的活动菜单项?【英文标题】:How can I reactively update the active menuItem in a Shiny app using `renderUI`? 【发布时间】:2021-03-21 19:16:17 【问题描述】:

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

【问题讨论】:

【参考方案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"
          )
        )
      )
    )
    
  
)

但是,我认为使用 lapplyrenderUI 的方法不是很好,因为如果您的输入之一发生变化,所有框都会重新呈现,而有些框可能会保持不变。因此,我推荐使用insertUI/removeUI 的方法。看看我的一些旧答案,例如https://***.com/a/63758952/12647315

【讨论】:

谢谢@starja。虽然它可以工作,但我的应用程序是模块化的,我正在努力实施这个解决方案,正如这里另一个问题中所解释的那样:***.com/q/65262056/7375944

以上是关于如何使用 `renderUI` 响应式更新 Shiny 应用程序中的活动菜单项?的主要内容,如果未能解决你的问题,请参考以下文章

如何使用更新的HTML和CSS函数创建响应式设计

如何使用 Spring 响应式通过增量进度更新逐个处理每个产品?

小丸子看vue如何响应式

如何获取未更新的响应式表单数据?

闪亮的模块和 renderUI 传递 javascript 代码

如何在R Shiny中使用renderUI触发renderDataTable进行输入?