嵌套在导航栏页面中时仪表板页面的主题

Question

我使用

dashboardpage

创建了一个 R 闪亮应用程序，但现在我想将多个仪表板页应用程序合并到一个应用程序中，并尝试使用

navbarpage

来实现这一目标。它似乎有效，但添加

navbarpage

似乎完全改变了

dashboardpage

的风格。

下面是基本

dashboardpage

的最小工作示例：

library(shiny)
library(shinydashboard)

ui <- 
  dashboardPage(
  dashboardHeader(title = "dash board header"),
  dashboardSidebar(
    sidebarMenu(
      actionButton("refreshBtn", "Refresh", icon = icon("refresh"), onclick = "refreshPage()"), # Refresh button
      menuItem("Data Upload", tabName = "uploadView", icon = icon("file")),
      menuItem("Averages", tabName = "Averages", icon = icon("list"))
    )
  ),
  dashboardBody(
    tabItems(
      tabItem(tabName = "uploadView",
              fluidRow(
                column(4,
                       fileInput("file1", "Choose CSV File 1",
                                 accept = c("text/csv",
                                            "text/comma-separated-values,text/plain",
                                            ".csv")),
                       fileInput("file2", "Choose CSV file 1",
                                 accept = c("text/csv",
                                            "text/comma-separated-values,text/plain",
                                            ".csv")),
                       hr(),
                       downloadButton("downloadData", "Download Data"),
                       checkboxGroupInput("SelectOption", label = "Select Box", 
                                          choices = c("Option 1", "Option 2"))
                )
              )
      )
    )
  )
  )

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

shinyApp(ui = ui, server = server)

给出：

但是，当我尝试将其放入

navbarpage

中时，格式会发生变化。即，

ui <- 
  navbarPage(
    "Test App",
    tabPanel(
      "Tab 1",
      dashboardPage(
        dashboardHeader(title = "dash board header"),
        dashboardSidebar(
          sidebarMenu(
            actionButton("refreshBtn", "Refresh", icon = icon("refresh"), onclick = "refreshPage()"), # Refresh button
            menuItem("Data Upload", tabName = "uploadView", icon = icon("file")),
            menuItem("Averages", tabName = "Averages", icon = icon("list"))
          )
        ),
        dashboardBody(
          tabItems(
            tabItem(tabName = "uploadView",
                    fluidRow(
                      column(4,
                             fileInput("file1", "Choose CSV File 1",
                                       accept = c("text/csv",
                                                  "text/comma-separated-values,text/plain",
                                                  ".csv")),
                             fileInput("file2", "Choose CSV file 1",
                                       accept = c("text/csv",
                                                  "text/comma-separated-values,text/plain",
                                                  ".csv")),
                             hr(),
                             downloadButton("downloadData", "Download Data"),
                             checkboxGroupInput("SelectOption", label = "Select Box", 
                                                choices = c("Option 1", "Option 2"))
                      )
                    )
            )
          )
        )
      )
      ),
      tabPanel(
        "Tab 2",
        dashboardPage(
          dashboardHeader(title = "dash board header 2"),
          dashboardSidebar(disable = TRUE),
          dashboardBody(tabItem(tabName = "Test"))
        )
      )
  )


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

shinyApp(ui = ui, server = server)

给出：

有没有办法更改仪表板组件的格式以恢复到原始图片中的方式。我不确定我是否尝试以不符合设计目的的方式使用

shinydashboard

和

navbarpage

。欢迎向其他人提出这样做的建议。

Answer 1

如果您想要选项卡式导航并保留

dashboard

，您可以构建导航。

您必须非常密切地关注事物的名称，并在可以选择的情况下使用独特的

id

。不同仪表板上的所有内容都需要有唯一的名称。在我的示例代码中，已经存在错误。我使用您问题中的仪表板作为第一个选项卡。任何时候按下any按钮，都认为按下了下载数据按钮。 （例如，刷新按钮、选项卡以及页面中的任何其他按钮）

下面是在仪表板之间手动切换选项卡的工作示例。

我创建了两个仪表板，保存在对象

db1

和

db2

中。

db1

是您的初始仪表板。

db1 <- dashboardPage(
  dashboardHeader(title = "dash board header"),
  dashboardSidebar(
    sidebarMenu(
      actionButton("refreshBtn", "Refresh", icon = icon("refresh"), onclick = "refreshPage()"), # Refresh button
      menuItem("Data Upload", tabName = "uploadView", icon = icon("file")),
      menuItem("Averages", tabName = "Averages", icon = icon("list"))
    )
  ),
  dashboardBody(
    tabItems(
      tabItem(tabName = "uploadView",
              fluidRow(
                column(4,
                       fileInput("file1", "Choose CSV File 1",
                                 accept = c("text/csv",
                                            "text/comma-separated-values,text/plain",
                                            ".csv")),
                       fileInput("file2", "Choose CSV file 1",
                                 accept = c("text/csv",
                                            "text/comma-separated-values,text/plain",
                                            ".csv")),
                       hr(),
                       downloadButton("downloadData", "Download Data"),
                       checkboxGroupInput("SelectOption", label = "Select Box", 
                                          choices = c("Option 1", "Option 2"))
                )
              )
      )
    )
  )
)
db2 <- dashboardPage(
  dashboardHeader(title = "dash board header 2"),
  dashboardSidebar(
    sidebarMenu(
      tags$div("not much to see here")
    )
  ),
  dashboardBody(
    tags$div("Nothing to see here")
  )
)

在 UI 中，我创建了导航栏、选项卡控制按钮并添加了仪表板。

对于每个仪表板或选项卡

• tags$button

  内有一个

  tags$nav

  （使用

  tags$nav

  是为了让它继承仪表板的样式）
• 标签$nav

  后有一个

  tags$div

---

请注意，按钮中突出显示的文本

tags$button(onclick = HTML("gimmeTab('

仪表板1

')"),...

必须与保存匹配仪表板的

id

中分配给

tags$div

的内容匹配

tags$div(id = "

仪表板1

",...

---

阅读代码中的注释以获取更多信息，如果您有任何疑问，请告诉我。

ui <- 
  fluidPage(
    tags$head(     # this removes a left and right margin
      tags$style(HTML(    
        "body > div.container-fluid {
          padding: 0;
          margin: 0;
        }"
      )),          # adds tabs' control
      tags$script(HTML(      
        "function gimmeTab(chosenOne){
          let i;
          let x = document.getElementsByClassName('tabber');
          for(i = 0; i < x.length; i++) {
            x[i].style.display = 'none';
          }
          document.getElementById(chosenOne).style.display = 'block';
        }"
      ))
    ),
    tags$body(       # 2 primary elements: navigation bar and that which it controls
      tags$nav(class = "navbar.navbar-static-top", role = "navigation",
               
                    # here a button for each dashboard; must have class = "navBtn" 
                            # must have unique inner text: first is 'Dashboard 1'
               tags$button(onclick = HTML("gimmeTab('Dashboard 1')"), "Dashboard 1", class = "navBtn"),
                            # unique text: 'Dashboard 2'
               tags$button(onclick = "gimmeTab('Dashboard 2')", "Dashboard 2", class = "navBtn")
      ),      
      # for each unique dashboard
            #  a `tags$div` with class 'tabber' 
            # the tags span exactly as shown here
            # id  that matches button inner text EXACTLY
            # content - the dashboard
      tags$div(id = "Dashboard 1", class = "tabber", 
               tags$span(onclick = HTML("this.parentELement.style.display = 'none'")),
               tags$h2("Dashboard 1"), 
               db1
      ),
      tags$div(id = "Dashboard 2", class = "tabber", 
               tags$span(onclick = "this.parentELement.style.display = 'none'"),
               tags$h2("Dashboard 2"), 
               db2
      )
    )
    
  )

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

shinyApp(ui = ui, server = server)