5.10 数据仪表盘

shiny中制作仪表盘的有两个包：flexdashboard包和shinydashboard包。

flexdashboard shinydashboard
R Markdown Shiny
Super easy Not quite as easy
Static or dynamic Dynamic
CSS flexbox layout Bootstrap grid layout

flexdashboard在rmarkdown中创建仪表盘，并且官网介绍非常清晰明了，上手简单，完全可以现学现用

shinydashboard依旧需要编写一个shiny应用程序

下面的内容着重介绍shinydashboard。

部分细节处可使用HTML和CSS来调整

5.10.1 整体框架

使用dashboardPage()去创建经典的数据看板——顶部标题行，左侧边栏，右侧主板。

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

当然，你也可以分开创建各个部分，在传递给dashboardPage()

header <- dashboardHeader()

sidebar <- dashboardSidebar()

body <- dashboardBody()

dashboardPage(header, sidebar, body)

5.10.1.1 标题行

如果你不想设置标题行，则dashboardHeader(disable = TRUE)。

标题行除了可以有标题外，直接用dashboardHeader(title = "My Dashboard")赋值，还可以添加下拉菜单。

下拉菜单用dropdownMenu()创建，可以包含消息、通知和任务三种元素。

记得给这三个元素匹配合适的图标

这三种类型的下拉菜单都由dropdownMenu()函数创建，利用参数type指定菜单类型消息message、通知notifications、任务tasks，参数badgeStatus设置小气泡的颜色，然后再由各自的item项来创建具体的条目。

“小气泡”指的是类似手机app右上角显示消息数量的那个小气泡 status设置参加这里

  1. messageItem()

    from参数表示消息来源，message参数表示消息内容，icon=icon()设置图标，time设置消息时间

icon设置参见这里，默认为“用户形状”

  1. notificationItem()

    text参数表示通知内容，icon设置图标，status设置通知的颜色

  2. taskItem()

    text参数设置说明性文字，value参数设置任务进度，color设置进度条颜色，href设置超链接

示例如下：

library(shiny)
library(shinydashboard)

header <- dashboardHeader(
  title = "下拉通知菜单",
  dropdownMenu(
    type = "messages",
    badgeStatus = "success",  # 气泡颜色
    messageItem(
      from = "系统通知",
      message = "数据更新已完成",
      time = "10:30"
    ),
    messageItem(
      from = "用户反馈",
      message = "发现新问题",
      icon = icon("file"),
      time = "11:45"
    )
  ),
  
  dropdownMenu(
    type = "notifications",
    badgeStatus = "danger",  # 气泡颜色
    notificationItem(
      text = "您有新的粉丝"
    )
  ),
  
  dropdownMenu(
    type = "tasks",
    taskItem(
      text = "工作进度",
      value = 73,
      color = "green"
    )
  )
)

ui <- dashboardPage(
  header,
  dashboardSidebar(),
  dashboardBody())

server <- function(input, output) {
}

shinyApp(ui, server)

当然，这些信息的更新应该是实时的，上面的示例只提供了一个静态的菜单，下面设置动态更新的菜单。

在UI的dashboardHeader()中，直接添加dropdownMenuOutput("ID")，然后再在server处用renderMenu()渲染你要实时更新的菜单内容。

例如

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

5.10.1.2 侧边栏

如果你不想显示侧边栏，则dashboardSidebar(disable = TRUE)

侧边栏隶属于sidebarMenu()，用menuItem()往里面增加条目。menuItem()的一般用法如下所示：

menuItem(
  text,                  # 菜单项显示的文本（必填）
  tabName = NULL,        # 关联的tab名称（对应tabItem的tabName）
  icon = NULL,           # Font Awesome图标（如icon("dashboard")）
  badgeLabel = NULL,     # 气泡标签（显示在菜单文本右侧）
  badgeColor = "green",  # 气泡颜色（"green", "red", "blue"等）
  href = NULL,           # 外部链接URL（如果设置，会覆盖tabName）
  newtab = TRUE,         # 是否在新标签页打开外部链接
  selected = NULL,       # 初始是否选中
  expandedName = text,   # 展开时显示的文本
  startExpanded = FALSE, # 初始是否展开（用于带子菜单的情况）
  ...                    # 子菜单项（menuSubItem）
)

非常重要的一点，如果该条目没有子条目的话，那么它一定要与对应的tabItem匹配，这样才能将选项与对应的主板页面匹配起来。

在menuItem()中也可继续添加子条目menuSubItem，其用法如下所示：

menuSubItem(
  text, 
  tabName = NULL, 
  href = NULL, 
  newtab = TRUE,
  icon = shiny::icon("angle-double-right"), 
  selected = NULL
)

对应主板中的内容用tabItems()与tabItem()表示，并用tabName与侧边栏中的选项匹配。如

sidebar <- dashboardSidebar(
  sidebarMenu(
    menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
    menuItem("Widgets", icon = icon("th"), tabName = "widgets",
             badgeLabel = "new", badgeColor = "green")
  )
)

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

    tabItem(tabName = "widgets",
      h2("Widgets tab content")
    )
  )
)

同样，侧边栏菜单及其条目也能动态生成，依靠renderMenu()、sidebarMenuOutput()、menuItemOutput()渲染并输出。

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

在侧边栏处，还允许添加shiny的输入组件，以及搜索栏sidebarSearchForm()。

搜索栏技术更加高级，暂且不提

5.10.1.3 主板

关于主板页面的内容，除了之前提到过的tabItems()以及tabItem()，更为理想的布局方式就是将页面划分为一个个方框，每个区域内放置图、表或输入组件。

1. 普通方框

box(
  title = "Box Title",      # 盒子标题
  status = "primary",       # 边框颜色
  bacjground = NULL,        # 背景颜色
  solidHeader = FALSE,      # 是否使用实心头部
  width = 6,                # 宽度（基于Bootstrap网格系统）
  height = NULL,            # 固定高度
  collapsible = FALSE,      # 是否可折叠
  collapsed = FALSE,        # 初始是否为折叠状态
  closable = FALSE,         # 是否可关闭
  footer = NULL,            # 底部内容
  ...,                      # 盒子主体内容
  id = NULL                 # 盒子ID（用于JS操作）
)

例如

dashboardBody(
  fluidRow(
    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:")
    )
  )
)

背景色可参考这里

2. 选项卡方框

tabBox()与tabPanel()用来组织方框内各个元素的结构。

tabBox(
  ...,                        # tabPanel()元素
  id = NULL, 
  selected = NULL, 
  title = NULL, 
  width = 6,
  height = NULL, 
  side = c("left", "right")
)

tabPanel(
  id = NULL
  title,       # 选项卡标题
  ...,         # 选项卡内容
  icon = NULL  # Font Awesome图标（如 icon("chart-bar"))
)
library(shiny)
library(shinydashboard)

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",   # side="right"表示从右往左放
      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
    })
  }
)

小技巧：可用tagList()来拼接图标和文本

3. 信息方框

类似一个方框里面，加个图标，加个说明性文本，加个指标。

infoBox(
  title, 
  value = NULL, 
  subtitle = NULL,
  icon = shiny::icon("bar-chart"), 
  color = "aqua", 
  width = 4,
  href = NULL, 
  fill = FALSE    # 是否填充方框
)
library(shiny)
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)

4. 数值方框

数值方框和信息方框类似，都是在小方块中有图标、有指标、有文本，都能设置成静态的或者动态的。

个人感觉，数值方框相较信息方框从视觉上凸显了“指标”

library(shiny)
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)

5. 布局

  • 基于行的布局

    使用fluidRow()来组织每一行的内容。注意宽度为12个单位，每个方框的默认宽度为6。

    基于行的布局默认每行内容顶部对齐，因此底部不一定对齐，取决于各个元素的内容。在box()中可设置height来统一高度。

宽度width是基于bootstrap的12单位宽，而高度height的单位是像素

  • 基于列的布局

    在fluidRow()内部使用column()来划分出一列，column()内的box()将会从上到下排列。

    由于column()中指定了宽度width，故box()的宽度得设置为width=NULL，统一使用column()的宽度。

fluidRow(
    column(width = 6,
      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 = 6,
      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"
      )
    )

  • 行列混合布局

    由于列布局是在fluidRow()中加入column()实现，因此，布局的基本单位就是行视角。基于此，就可以任意实现行与列混合布局。

5.10.2 外观

5.10.2.1 皮肤

根据dashboardPage()中的参数skin设置，如dashboardPage(skin=purple)

5.10.2.2 CSS样式

在shiny应用所在的目录中创建名为www的新文件夹，再在里面创建css文件，文件中的内容就是你自定义的css样式。

之后在dashboardBody处引用这个css文件即可。

示例如下：

.main-header .logo {
  font-family: "Georgia", Times, "Times New Roman", serif;
  font-weight: bold;
  font-size: 24px;
}
dashboardPage(
  dashboardHeader(title = "Custom font"),
  dashboardSidebar(),
  dashboardBody(
    tags$head(
      tags$link(rel = "stylesheet", type = "text/css", href = "custom.css")
    )
  )
)

注意在shiny所在的目录中新建www文件夹，该文件夹内包含custom.css文件

或者直接在shiny中输入html语言。

dashboardPage(
  dashboardHeader(title = "Custom font"),
  dashboardSidebar(),
  dashboardBody(
    tags$head(tags$style(HTML('
      .main-header .logo {
        font-family: "Georgia", Times, "Times New Roman", serif;
        font-weight: bold;
        font-size: 24px;
      }
    ')))
  )
)

其余方式详见此处

5.10.2.3 标题宽度

在dashboardHeader()中设置参数titleWidth来调整宽度，单位为像素。同时，也可设置标题处的背景色与标题行的背景色相同。

dashboardPage(
    dashboardHeader(
      title = "Example of a long title that needs more space",
      titleWidth = 450
    ),
    dashboardSidebar(),
    dashboardBody(
      # Also add some custom CSS to make the title background area the same
      # color as the rest of the header.
      tags$head(tags$style(HTML('
        .skin-blue .main-header .logo {
          background-color: #3c8dbc;
        }
        .skin-blue .main-header .logo:hover {
          background-color: #3c8dbc;
        }
      ')))
    )
  )

5.10.2.4 侧边栏宽度

dashboardSidebar()中的参数width可调整宽度，单位为像素。

5.10.2.5 图标

不少函数中有参数icon，你可用icon()来传递对应的图标，如icon = icon('calendar')。

icon()默认使用FontAwesome的图标，也可用参数lib更改来源，使用Glyphicon的图标。

"Calendar from Font-Awesome:", icon("calendar"),
"Cog from Glyphicons:", icon("cog", lib = "glyphicon")

5.10.2.6 配色

函数中涉及到参数status和color的，可以参考

Status

图 5.1: Status

Colors

图 5.2: Colors