Shinydashboard动态TabPanel

Question

我有一个类似于我最近提出的关于动态要点的问题：ShinyDashboard Dynamic Bullet Points

但这一次是关于动态平板的。基本上，我想要生成符合某些标准的数据的动态表面板。下面是一个简单的示例，说明我正在试图解决的问题：

nba_teams <- data.frame(team = c("Bulls", "Nuggets", "Celtics", "Lakers"),
                    conference = c("Eastern", "Western", "Eastern", 
                                   "Western"),
                    player_over_30 = c("Y","N","N","Y"),
                    date_team_formed = c(1966-01-01,1967-01-01,1946-06- 
                                         06,1947-01-01))

有了这些虚拟数据，我想为西方会议团队创建两个基于数据的表格。然后，要显示他们形成的日期，如果他们有一个玩家超过30:显示一个字体可怕的图标，并将数据引用到他们的团队页面。

如果我要硬编码，我可以通过以下代码来完成：

library(shinydashboard)
UI <- dashboardPage(
      dashboardHeader(),
      dashboardSidebar(),
      dashboardBody(

fluidRow(
 tabBox(
 title = "Western Conference Details",
 id = "tabset2", height = "200px", width = 12,
 tabPanel("Nuggets", "Nuggets Details", 
     dateInput("date1_val", label = h3("Formation Date"), value = "1967-01- 
      01")),
 tabPanel("Lakers", "Lakers Details", uiOutput("Lakers"),icon = 
 icon("sticky-note"),
     dateInput("date1_val", label = h3("Formation Date"), value = "1947-10- 
  01"))
  ))))

server <- function(input,output,session) {

 Lakers_URL <- a("Lakers Player Detail",
              href = "https://www.nba.com/lakers")
 output$Lakers <- renderUI({
   tagList("Lakers",Lakers_URL)
 })
}
shinyApp(UI, server)

但是，随着表中数据的变化，代码也必须不断更新，以反映无法维护的更改。

对于代码的UI部分，我开始沿着这条路走下去，但是在每个观察都不需要UI输出时，如何引用UI输出就陷入了困境，即使删除了这些输出，它也不能完全呈现日期信息：

UI <- dashboardPage(
    dashboardHeader(),
    dashboardSidebar(),
    dashboardBody(

      fluidRow(
        tabBox(
          title = "Western Conference Details",
          id = "tabset2", height = "200px", width = 12,
          lapply(1:nrow(nba_teams), function(x){
            if(nba_teams$conference[x]=="Western"){


return(tabPanel(nba_teams$team[x],paste(nba_teams$team[x],"Formation Date"),
                          dateInput("date1_val", label = 
h3("Formation_Date"),
                                    value = 
nba_teams$date_team_formed[x])))}})))))

对如何进行有什么想法吗？谢谢!

Answer 1

如果可以将data.frame转换为嵌套的列表结构，则可以使用lapply和do.call动态生成tabPanels。也许这能帮你：

nba_teams <- list(list(Title = "Bulls", Content = list("Eastern",
                                                       dateInput("date1_val",
                                                                 label = h3("Formation Date"), 
                                                                 value = "1967-01-01"))),
                  list(Title = "Nuggets", Content = "Western"),
                  list(Title = "Celtics", Content = "Eastern"),
                  list(Title = "Lakers", Content = list("Western", 
                                                        dateInput("date1_val1", 
                                                                  label = h3("Formation Date"), 
                                                                  value = "1947-10-01"),
                                                        icon = icon("sticky-note")))
)

library(shinydashboard)
library(shiny)

UI <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(),
  dashboardBody(
    uiOutput("panels")
  )
)

server <- function(input,output,session) {

  output$panels <- renderUI({
    pan = lapply(1:length(nba_teams), function(i) 
        tabPanel(nba_teams[[i]]$Title, nba_teams[[i]]$Content))
    do.call(tabBox,pan)
  })

}
shinyApp(UI, server)