R shinydashboard ——2. 结构

目录

• 1.Shiny和HTML
• 2.结构
• 3. 标题Header
• 4. 侧边栏Siderbar
• 5.主体/正文Body
  • box
  • tabBox
  • infoBox
  • valueBox
  • Layouts

1.Shiny和HTML

Shiny UI的构建方式和网页HTML的对应关系。

div(class = "my-class", "Div content")
对应
<div class="my-class">Div content</div>

div(class = "my-class", p("Paragraph text"))
对应
<div class="my-class">
 <p>Paragraph text</p>
 </div>

textInput("Id", "Label")
对应
<div class="form-group shiny-input-container">
  <label for="Id">Label</label>
  <input id="Id" type="text" class="form-control" value=""/>
</div>

sidebarPanel(
  div("First div"),
  div("Second div")
)
对应
<div class="col-sm-4">
  <form class="well">
    <div>First div</div>
    <div>Second div</div>
  </form>
</div>

Shiny应用程序的UI是基于这些HTML代码构建的，我们顺便拷贝上面一段代码到R控制台中运行，都会得到相应的HTML代码：

2.结构

上一节已经讲了有标题、侧边栏和正文三个结构嵌套在dashboardPage函数中：

dashboardPage(
  dashboardHeader(),
  dashboardSidebar(),
  dashboardBody()
)

有些稍微复杂的程序，为了结构更清晰，可读性更强（层次结构多，括号个数配对以及逗号经常出错），可以将三部分拆开来写：

header <- dashboardHeader()
sidebar <- dashboardSidebar()
body <- dashboardBody()
dashboardPage(header, sidebar, body)

3. 标题Header

dashboardHeader函数主要对标题title和下拉菜单dropdownMenu()函数（包含message/notification/task）进行设置。

## Only run this example in interactive R sessions
if (interactive()) {
  library(shiny)
  
  # A dashboard header with 3 dropdown menus
  header <- dashboardHeader(
    title = "Dashboard Demo",
    
    # Dropdown menu for messages
    dropdownMenu(type = "messages", badgeStatus = "success",
                 messageItem("Support Team",
                             "This is the content of a message.",
                             time = "5 mins"
                 ),
                 messageItem("Support Team",
                             "This is the content of another message.",
                             time = "2 hours"
                 ),
                 messageItem("New User",
                             "Can I get some help?",
                             time = "Today"
                 )
    ),
    
    # Dropdown menu for notifications
    dropdownMenu(type = "notifications", badgeStatus = "warning",
                 notificationItem(icon = icon("users"), status = "info",
                                  "5 new members joined today"
                 ),
                 notificationItem(icon = icon("warning"), status = "danger",
                                  "Resource usage near limit."
                 ),
                 notificationItem(icon = icon("shopping-cart", lib = "glyphicon"),
                                  status = "success", "25 sales made"
                 ),
                 notificationItem(icon = icon("user", lib = "glyphicon"),
                                  status = "danger", "You changed your username"
                 )
    ),
    
    # Dropdown menu for tasks, with progress bar
    dropdownMenu(type = "tasks", badgeStatus = "danger",
                 taskItem(value = 20, color = "aqua",
                          "Refactor code"
                 ),
                 taskItem(value = 40, color = "green",
                          "Design new layout"
                 ),
                 taskItem(value = 60, color = "yellow",
                          "Another task"
                 ),
                 taskItem(value = 80, color = "red",
                          "Write documentation"
                 )
    )
  )
  
  shinyApp(
    ui = dashboardPage(
      header,
      dashboardSidebar(),
      dashboardBody()
    ),
    server = function(input, output) { }
  )
}

右上角分别对应三个下拉菜单，分别为message/notification/task。

如果要对上面的message进行动态显示，需要用数据对它进行渲染：

## ui.R ##
dashboardHeader(dropdownMenuOutput("messageMenu"))

## server.R ##
output$messageMenu <- renderMenu({
  # Code to generate each of the messageItems here, in a list. This assumes
  # that messageData is a data frame with two columns, 'from' and 'message'.
  msgs <- apply(messageData, 1, function(row) {
    messageItem(from = row[["from"]], message = row[["message"]])
  })

  # This is equivalent to calling:
  #   dropdownMenu(type="messages", msgs[[1]], msgs[[2]], ...)
  dropdownMenu(type = "messages", .list = msgs)
})

如果不想显示标题Header，可用：

dashboardHeader(disable = TRUE)

4. 侧边栏Siderbar

通过使用侧边栏的菜单项sidebarMenu函数来设置，但要注意侧边栏中menuItem的tabName和主体中tabItem的tabName对应起来。

## ui.R ##
sidebar <- dashboardSidebar(
  sidebarMenu(
    menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
    menuItem("Widgets", icon = icon("th"), tabName = "widgets",
             badgeLabel = "new", badgeColor = "green"),
    menuItem("Source code", icon = icon("file-code-o"),   #建立超链接
             href = "https://github.com/rstudio/shinydashboard/")
  )
)

body <- dashboardBody(
  tabItems(
    tabItem(tabName = "dashboard",
            h2("Dashboard tab content")
    ),
    
    tabItem(tabName = "widgets",
            h2("Widgets tab content")
    )
  )
)

shinyApp(
  ui = dashboardPage(
    dashboardHeader(title = "Simple tabs"),
    sidebar,
    body
  ),
  server = function(input, output) { }
)

动态生成侧边栏菜单或者侧边栏中单个项目，做相应的渲染：

## 渲染sidebarMenu ##
ui <- dashboardPage(
  dashboardHeader(title = "Dynamic sidebar"),
  dashboardSidebar(
    sidebarMenuOutput("menu")
  ),
  dashboardBody()
)
server <- function(input, output) {
  output$menu <- renderMenu({
    sidebarMenu(
      menuItem("Menu item", icon = icon("calendar"))
    )
  })
}
shinyApp(ui, server)

## 渲染menuItem ##
ui <- dashboardPage(
  dashboardHeader(title = "Dynamic sidebar"),
  dashboardSidebar(
    sidebarMenu(
      menuItemOutput("menuitem")
    )
  ),
  dashboardBody()
)
server <- function(input, output) {
  output$menuitem <- renderMenu({
    menuItem("Menu item", icon = icon("calendar"))
  })
}
shinyApp(ui, server)

侧边栏的输入包括：

• silderInput
• textInput
• sidebarSearchForm （一种特殊格式的文本输入）

禁用侧边栏：
dashboardSidebar(disable=TRUE)

5.主体/正文Body

可包含任何常规的shiny内容，大部分dashboard的基本单元是box，box可以包含任何内容。

box

一般box放在fuidRow内：

# This is just the body component of a dashboard
dashboardBody(
  fluidRow(
    box(plotOutput("plot1")),
    box(
      "Box content here", br(), "More box content",
      sliderInput("slider", "Slider input:", 1, 100, 50),
      textInput("text", "Text input:")
    )
  )
)

box可添加标题title和标题栏颜色status：

box(title = "Histogram", status = "primary", plotOutput("plot2", height = 250)),
box(
  title = "Inputs", status = "warning",
  "Box content here", br(), "More box content",
  sliderInput("slider", "Slider input:", 1, 100, 50),
  textInput("text", "Text input:")
)

box可固定标题solidHeader=TRUE，可显示折叠按钮collapsible=TRUE：

box(
  title = "Histogram", status = "primary", solidHeader = TRUE,
  collapsible = TRUE,
  plotOutput("plot3", height = 250)
),

box(
  title = "Inputs", status = "warning", solidHeader = TRUE,
  "Box content here", br(), "More box content",
  sliderInput("slider", "Slider input:", 1, 100, 50),
  textInput("text", "Text input:")
)

box还可添加背景background：

box(
  title = "Histogram", background = "maroon", solidHeader = TRUE,
  plotOutput("plot4", height = 250)
),

box(
  title = "Inputs", background = "black",
  "Box content here", br(), "More box content",
  sliderInput("slider", "Slider input:", 1, 100, 50),
  textInput("text", "Text input:")
)

tabBox

与shiny中的tabsetPanel类似，用来显示不同内容块。以tabPanel函数输入，分配一个id，比如id设为tabset1，则访问时使用input$tabset1。还可设置高度，宽度和标题，以及选项卡出现在哪一侧side，当side设为right时选项卡顺序会变得从右到左。

body <- dashboardBody(
  fluidRow(
    tabBox(
      title = "First tabBox",
      # The id lets us use input$tabset1 on the server to find the current tab
      id = "tabset1", height = "250px",
      tabPanel("Tab1", "First tab content"),
      tabPanel("Tab2", "Tab content 2")
    ),
    tabBox(
      side = "right", height = "250px",
      selected = "Tab3",
      tabPanel("Tab1", "Tab content 1"),
      tabPanel("Tab2", "Tab content 2"),
      tabPanel("Tab3", "Note that when side=right, the tab order is reversed.")
    )
  ),
  fluidRow(
    tabBox(
      # Title can include an icon
      title = tagList(shiny::icon("gear"), "tabBox status"),
      tabPanel("Tab1",
        "Currently selected tab from first box:",
        verbatimTextOutput("tabset1Selected")
      ),
      tabPanel("Tab2", "Tab content 2")
    )
  )
)

shinyApp(
  ui = dashboardPage(
    dashboardHeader(title = "tabBoxes"),
    dashboardSidebar(),
    body
  ),
  server = function(input, output) {
    # The currently selected tab from the first box
    output$tabset1Selected <- renderText({
      input$tabset1
    })
  }
)

infoBox

一种显示带有图标的简单数字或文本的特殊框，可以是静态也可是动态。我认为用得应该不是很多，但也把代码和示意图贴出，感兴趣可看看infoBox的参数：

library(shinydashboard)

ui <- dashboardPage(
  dashboardHeader(title = "Info boxes"),
  dashboardSidebar(),
  dashboardBody(
    # infoBoxes with fill=FALSE
    fluidRow(
      # A static infoBox
      infoBox("New Orders", 10 * 2, icon = icon("credit-card")),
      # Dynamic infoBoxes
      infoBoxOutput("progressBox"),
      infoBoxOutput("approvalBox")
    ),

    # infoBoxes with fill=TRUE
    fluidRow(
      infoBox("New Orders", 10 * 2, icon = icon("credit-card"), fill = TRUE),
      infoBoxOutput("progressBox2"),
      infoBoxOutput("approvalBox2")
    ),

    fluidRow(
      # Clicking this will increment the progress amount
      box(width = 4, actionButton("count", "Increment progress"))
    )
  )
)

server <- function(input, output) {
  output$progressBox <- renderInfoBox({
    infoBox(
      "Progress", paste0(25 + input$count, "%"), icon = icon("list"),
      color = "purple"
    )
  })
  output$approvalBox <- renderInfoBox({
    infoBox(
      "Approval", "80%", icon = icon("thumbs-up", lib = "glyphicon"),
      color = "yellow"
    )
  })

  # Same as above, but with fill=TRUE
  output$progressBox2 <- renderInfoBox({
    infoBox(
      "Progress", paste0(25 + input$count, "%"), icon = icon("list"),
      color = "purple", fill = TRUE
    )
  })
  output$approvalBox2 <- renderInfoBox({
    infoBox(
      "Approval", "80%", icon = icon("thumbs-up", lib = "glyphicon"),
      color = "yellow", fill = TRUE
    )
  })
}

shinyApp(ui, server)

valueBox

和infoBox类似，除了外观有所不同。

library(shinydashboard)

ui <- dashboardPage(
  dashboardHeader(title = "Value boxes"),
  dashboardSidebar(),
  dashboardBody(
    fluidRow(
      # A static valueBox
      valueBox(10 * 2, "New Orders", icon = icon("credit-card")),

      # Dynamic valueBoxes
      valueBoxOutput("progressBox"),

      valueBoxOutput("approvalBox")
    ),
    fluidRow(
      # Clicking this will increment the progress amount
      box(width = 4, actionButton("count", "Increment progress"))
    )
  )
)

server <- function(input, output) {
  output$progressBox <- renderValueBox({
    valueBox(
      paste0(25 + input$count, "%"), "Progress", icon = icon("list"),
      color = "purple"
    )
  })

  output$approvalBox <- renderValueBox({
    valueBox(
      "80%", "Approval", icon = icon("thumbs-up", lib = "glyphicon"),
      color = "yellow"
    )
  })
}

shinyApp(ui, server)

Layouts

简单理解就是对box进行排布。这里应用的是Bootstrap的网格布局系统，即将主体视为一个划分为12列的区域，这些区域具有相等的宽度和任意数量的行，高度可变。当在网格中放置一个框（或其他项）时，可以指定要占用的12列中有多少列。比如下图中，第一行框的宽度为4列，第二列框的宽度设为6列。

广义上讲，有两种布局框的方法：基于行的布局或基于列的布局。

基于行的布局
上图就是典型的基于行的布局。在基于行的布局中，框box必须位于由创建的行中fluidRow()。行的网格宽度为12，因此具有的框width=4占据宽度的三分之一，具有width=6（默认值）的框占据宽度的一半。

使用基于行的布局时，每行中的框的顶部将对齐，但底部可能不对齐（由每个框的内容决定）。

贴出上图的代码：

body <- dashboardBody(
  fluidRow(
    box(title = "Box title", "Box content"),
    box(status = "warning", "Box content")
  ),
  
  fluidRow(
    box(
      title = "Title 1", width = 4, solidHeader = TRUE, status = "primary",
      "Box content"
    ),
    box(
      title = "Title 2", width = 4, solidHeader = TRUE,
      "Box content"
    ),
    box(
      title = "Title 1", width = 4, solidHeader = TRUE, status = "warning",
      "Box content"
    )
  ),
  
  fluidRow(
    box(
      width = 4, background = "black",
      "A box with a solid black background"
    ),
    box(
      title = "Title 5", width = 4, background = "light-blue",
      "A box with a solid light-blue background"
    ),
    box(
      title = "Title 6",width = 4, background = "maroon",
      "A box with a solid maroon background"
    )
  )
)

# We'll save it in a variable `ui` so that we can preview it in the console
ui <- dashboardPage(
  dashboardHeader(title = "Row layout"),
  dashboardSidebar(),
  body
)

# Preview the UI in the console
shinyApp(ui = ui, server = function(input, output) { })

可以强制将框box设为相同的高度（这样更美观），即指定高度height的像素。（不同于Bootstrap，这里高度是以HTML/CSS来处理的），如将所有盒子都设为相同高度：

box(title = "Box title", height = 300, "Box content"),

基于列的布局
首先是创建一列，然后在这列中放置框。即先用column指定列宽，再设置每个框为width=NULL.

body <- dashboardBody(
  fluidRow(
    column(width = 4,
      box(
        title = "Box title", width = NULL, status = "primary",
        "Box content"
      ),
      box(
        title = "Title 1", width = NULL, solidHeader = TRUE, status = "primary",
        "Box content"
      ),
      box(
        width = NULL, background = "black",
        "A box with a solid black background"
      )
    ),

    column(width = 4,
      box(
        status = "warning", width = NULL,
        "Box content"
      ),
      box(
        title = "Title 3", width = NULL, solidHeader = TRUE, status = "warning",
        "Box content"
      ),
      box(
        title = "Title 5", width = NULL, background = "light-blue",
        "A box with a solid light-blue background"
      )
    ),

    column(width = 4,
      box(
        title = "Title 2", width = NULL, solidHeader = TRUE,
        "Box content"
      ),
      box(
        title = "Title 6", width = NULL, background = "maroon",
        "A box with a solid maroon background"
      )
    )
  )
)

# We'll save it in a variable `ui` so that we can preview it in the console
ui <- dashboardPage(
  dashboardHeader(title = "Column layout"),
  dashboardSidebar(),
  body
)

# Preview the UI in the console
shinyApp(ui = ui, server = function(input, output) { })

行列混合布局
也可以混合使用行和列的布局，如上图中最上面两个框按行，其余按列：

body <- dashboardBody(
  fluidRow(
    box(
      title = "Box title", width = 6, status = "primary",
      "Box content"
    ),
    box(
      status = "warning", width = 6,
      "Box content"
    )
  ),
    
  fluidRow(
    column(width = 4,
      box(
        title = "Title 1", width = NULL, solidHeader = TRUE, status = "primary",
        "Box content"
      ),
      box(
        width = NULL, background = "black",
        "A box with a solid black background"
      )
    ),

    column(width = 4,
      box(
        title = "Title 3", width = NULL, solidHeader = TRUE, status = "warning",
        "Box content"
      ),
      box(
        title = "Title 5", width = NULL, background = "light-blue",
        "A box with a solid light-blue background"
      )
    ),

    column(width = 4,
      box(
        title = "Title 2", width = NULL, solidHeader = TRUE,
        "Box content"
      ),
      box(
        title = "Title 6", width = NULL, background = "maroon",
        "A box with a solid maroon background"
      )
    )
  )
)

# We'll save it in a variable `ui` so that we can preview it in the console
ui <- dashboardPage(
  dashboardHeader(title = "Mixed layout"),
  dashboardSidebar(),
  body
)

# Preview the UI in the console
shinyApp(ui = ui, server = function(input, output) { })

Ref：
https://rstudio.github.io/shinydashboard/structure.html