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

Question

I'm building a shiny app with shinydashboard . Its purpose is to display a set of 'cards' (technically box() elements) within each tabItem() (ie each page of the dashboard). The app is driven by an external.csv file (in this reprex the object dat ) which (1) defines the pages within the app and (2) specifies the number of box() elements within each page.

I have been able to successfully create a set of tabItem 's (ie pages) using category in dat . From here, I can't figure out how to dynamically add the correct number of boxes to each tabItem . If you inspect dat you will see that there are two categories (pages): blue and green. The blue category requires me to render two boxes (Box A and Box B) whereas the green category requires me to render boxes C - E. Thus, the page called 'Blue' should render two boxes, while the page called 'Green' should render three boxes.

Could someone help me with the below code so that the correct boxes are rendered for the correct pages? Extra gratitude if the box_name and box_desc can appear as the box() title and contents, respectively!

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

Is renderUI required?

It works fine (and is faster) without 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)

With renderUI the items are rendered only after switching the tabs - because the boxes are not existing when the dashboardBody is first rendered:

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)