在 tabItem() 中动态创建 box()

Question

我正在使用 shinydashboard 构建一个 shiny 应用程序。其目的是在每个 tabItem()（即仪表板的每一页）中显示一组 'cards'（技术上 box() 元素）。该应用程序由外部 .csv 文件（在此表示中为 object dat）驱动，该文件 (1) 定义应用程序内的页面，(2) 指定 box() 元素的数量在每个页面中。

我已经能够使用 dat 中的类别成功创建一组 tabItem（即页面）。从这里开始，我无法弄清楚如何动态地向每个 tabItem 添加正确数量的框。如果您检查 dat，您会看到有两个类别（页面）：蓝色和绿色。蓝色类别要求我呈现两个框（框 A 和框 B），而绿色类别要求我呈现框 C - E。因此，名为 'Blue' 的页面应呈现两个框，而名为 'Green' 应该呈现三个框。

有人可以帮助我编写以下代码，以便为正确的页面呈现正确的框吗？ box_name和box_desc能分别作为box()标题和内容出现，不胜感激！

library(shiny)
library(shinydashboard)

dat<-tibble::tibble(category = c("blue", "blue", "green", "green", "green"), 
                    box_name = c("Box A", "Box B", "Box C", "Box D", "Box E"),
                    box_desc = c("Foo", "Bar", "Bar", "Foo", "Foo"))

sidebar <- dashboardSidebar(
  sidebarMenu(
    menuItem("Blue", tabName = "blue", icon = icon("dashboard")),
    menuItem("Green", icon = icon("th"), tabName = "green")
  )
)

body <- dashboardBody(
  uiOutput("render_reports")
)
header<-dashboardHeader()

ui <- dashboardPage(header, sidebar, body)

server <- function(input, output) {
  
  output$render_reports <- renderUI({
    
    pages <- lapply(unique(dat$category), function(name){
      
      tabItem(tabName = name, fluidRow(box(
        title = name, paste0("Something here about ", name), width = 12, solidHeader = TRUE, status = "primary"
      )),

      fluidRow(
        
        box(title = "box_title here", "box_desc here")
        
      ))
    })
    
    items <- c(pages)
    do.call(tabItems, items)
    
  })
  
}


shinyApp(ui, server)

Answer 1

是否需要renderUI？

在没有 renderUI 的情况下工作正常（而且速度更快）：

library(shiny)
library(shinydashboard)

dat <- tibble::tibble(
  category = c("blue", "blue", "green", "green", "green"),
  box_name = c("Box A", "Box B", "Box C", "Box D", "Box E"),
  box_desc = c("Foo", "Bar", "Bar", "Foo", "Foo")
)

sidebar <- dashboardSidebar(sidebarMenu(
  menuItem("Blue", tabName = "blue", icon = icon("dashboard")),
  menuItem("Green", tabName = "green", icon = icon("th"))
))

body <- dashboardBody({
  items <- lapply(unique(dat$category), function(name) {
    tabItem(tabName = name, fluidRow(
      lapply(which(dat$category %in% name), function(i) {
        box(
          dat$box_desc[i],
          title = dat$box_name[i],
          paste0("Something here about ", name),
          width = 12,
          solidHeader = TRUE,
          status = "primary"
        )
      }))
    )})
  do.call(tabItems, items)
})

header <- dashboardHeader()

ui <- dashboardPage(header, sidebar, body)

server <- function(input, output) {}

shinyApp(ui, server)

使用 renderUI 项目仅在切换选项卡后呈现 - 因为在首次呈现 dashboardBody 时框不存在：

library(shiny)
library(shinydashboard)

dat <- tibble::tibble(
  category = c("blue", "blue", "green", "green", "green"),
  box_name = c("Box A", "Box B", "Box C", "Box D", "Box E"),
  box_desc = c("Foo", "Bar", "Bar", "Foo", "Foo")
)

sidebar <- dashboardSidebar(sidebarMenu(
  menuItem("Blue", tabName = "blue", icon = icon("dashboard")),
  menuItem("Green", tabName = "green", icon = icon("th"))
))

body <- dashboardBody(uiOutput("renderReports"))
header <- dashboardHeader()

ui <- dashboardPage(header, sidebar, body)

server <- function(input, output) {
  output$renderReports <- renderUI({
    items <- lapply(unique(dat$category), function(name) {
      tabItem(tabName = name, fluidRow(
        lapply(which(dat$category %in% name), function(i) {
        box(
          dat$box_desc[i],
          title = dat$box_name[i],
          paste0("Something here about ", name),
          width = 12,
          solidHeader = TRUE,
          status = "primary"
        )
      }))
    )})
    do.call(tabItems, items)
  })
}

shinyApp(ui, server)

在 tabItem() 中动态创建 box()

Dynamically Create box() within tabItem()

r

shiny

shinydashboard