Shinydashboard Dynamic TabPanel - PullRequest
Новая
       7

Shinydashboard Dynamic TabPanel

0 голосов
/ 29 октября 2018

У меня есть вопрос, аналогичный тому, который я недавно задавал относительно динамических маркеров: 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 <- 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])))}})))))

Есть мысли о том, как поступить? Спасибо!

1 Ответ

0 голосов
/ 31 октября 2018

Если вы можете преобразовать свой data.frame во вложенную структуру списка, вы можете динамически генерировать tabPanels с помощью lapply и do.call. Может быть, это может помочь вам: 

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)
...