shinydashboard与shiny_史上最全（二）

作者：李誉辉  

四川大学在读研究生

前言

这是shinydashboard与shiny_史上最全第二篇，上一篇：shinydashboard与shiny_史上最全（一）

第一部分：

• 1 简介

• 2 shiny文件的创建和运行

• 3 shinydashboard

         3.1 标题栏(Header)

第二部分：

       3.2 输入与输出

       3.3 侧边栏

       3.4 主体(Body)

       3.5 布局(Layouts)

       4 shiny框架

第三部分：

• 5 选项卡(tabset)

• 6 美化

• 7 CSS语法

• 8 与leaflet结合

• 9 web部署

3.1

输入与输出

shinydashboard()支持shiny自带的所有~Input()对象,
这些对象同样也能放入box中。
所有Input对象：

• actionButton(), 激活按钮。
  

• actionLink(), 激活链接。
  

• checkboxInpu()， 勾选框。
  

• checkboxGroupInput(), 勾选组合框。
  

• dateInput(), 日期选择框。
  

• dateRangeInput(), 日期范围选择框。
  

• fileInput()，上传文件框。

• downloadButton(), 下载数据。
  

• numericInput(), 数字选择框。
  

• passwordInput(), 密码输入框。
  

• radioButtons(), 单选按钮。
  

• selectInput(), 选择框。
  

• sliderInput(), 滑动条。
  

• submitButton(), 提交按钮。
  

• textInput(), 文本输入框。

输出需要一对组合函数，在UI端使用~Output(), 在server端使用render~(),
2者通过变量名进行匹配。shinydashboard同样支持所有shiny自带的输出组合。

所有输出组合:

• renderPlot() 与 plotOutput(), 绘图输出。
  

• renderText() 与 textOutput(), 文本输出。
  

• renderPrint() 与 verbatimTextOutput(), 打印输出。
  

• renderTable() 与 tableOutput(), 以HTML表格形式输出。
  

• renderImage() 与 imageOutput(), 读取图片输出。
  

• renderDataTable() 与 dataTableOutput(), 交互式表格输出，来自DT包。
  

• renderUI() 与 uiOutput()/htmlOutput(), 当作html语法输出。

3.2.1 滑动条(slider)

UI端代码如下：

 1library(shiny)
 2library(shinydashboard)
 3
 4dashboardPage(
 5  dashboardHeader(title = "滑动条传入参数"),
 6  dashboardSidebar(
 7    # 第1个滑动条：传入简单的整数
 8    sliderInput("integer", "整数：", 
 9                min=0, max=1000, value=500), # 最下值为0，最大值为1000，默认为500
10
11    # 第2个滑动条，传入小数
12    sliderInput("decimal", "小数：", 
13                min = 0, max = 1, value = 0.5, step= 0.1), # 步长为0.1
14
15    # 第3个滑动条，传入区间范围
16    sliderInput("range", "范围：",
17                min = 1, max = 1000, value = c(200,500)), # 默认范围为200到500
18
19    # 第4个滑动条，传入货币格式，并附带动画按钮
20    sliderInput("format", "货币格式:", 
21                min = 0, max = 10000, value = 0, step = 2500, # 步长为2500
22                format="$#,##0", locale="us", animate=TRUE), # 格式为千分位数字，locale美元
23
24    # 第5个滑动条，用于控制动画速度
25    sliderInput("animation", "循环动画", 
26                1, 2000, 1, step = 10, # 最小1，最大2000，步长10，单位ms(毫秒)
27                animate=animationOptions(interval=300, loop=T)) # 设定动画选项
28    ),
29  dashboardBody( # box内同样可以插入shiny的输出函数
30    fluidRow(box(tableOutput("values"))) # 以HTML表格形式输出变量values
31  )
32)

server端代码如下：

这里涉及到反应表达式，通常是先计算反应表达式，生成output对象需要的变量。
后面的output直接使用变量。调用反应表达式需要加括号。

 1library(shiny)
 2
 3# 自定义服务器脚本
 4shinyServer(function(input, output) {
 5  # 反应表达式：创建一个数据框，用来存放所有输入值。  
 6  sliderValues <- reactive({
 7    # Compose data frame
 8    data.frame(
 9      Name = c("整数", 
10               "小数",
11               "范围",
12               "货币格式",
13               "动画"),
14      Value = as.character(c(input$integer, 
15                             input$decimal,
16                             paste(input$range, collapse=' '),
17                             input$format,
18                             input$animation)), 
19      stringsAsFactors=FALSE)
20  }) 
21
22  # 输出组件，新增变量values
23  output$values <- renderTable({ # 以表格的形式输出
24    sliderValues() # 调用反应表达式需要加括号()
25  })
26})

运行结果如下：

3.2.2 选择框(selectInput)及勾选框

与shiny中用法一致，UI端代码如下：

 1library(shiny)
 2library(shinydashboard)
 3
 4dashboardPage(
 5  dashboardHeader(title = "选择框传入参数"),
 6  dashboardSidebar(
 7    # 定义选择框
 8    selectInput("variable",  # 传入变量名称
 9                "选择变量：", # 提示文字
10                # 选项内容，左边是显示字符，右边是传入变量名称，若是向量传递则字符与变量相同
11                list("气缸数" = "cyl",  
12                     "变速箱类型" = "am", # 列表传递，可以修改显示
13                     "档位数" = "gear")),
14    # 定义勾选框
15    checkboxInput("outliers",  # 传入变量名称
16                  "显示离群值", # 勾选框提示文字
17                  FALSE)  # 默认状态
18    ),
19  dashboardBody(
20    fluidRow(box(plotOutput("mpgPlot"), # 以图片形式输出mpgPlot变量
21                 title = h3(textOutput("caption")))) # 以三级标题形式输出caption变量
22  )
23)

server端代码如下：

 1library(shiny)
 2library(datasets)
 3
 4# 数据初始化：将不依赖用户输入的数据，先在服务器脚本中计算出来
 5mpgData <- mtcars
 6## 变速箱变量因子化，增加标签：自动挡和手动挡
 7mpgData$am <- factor(mpgData$am, labels = c("Automatic", "Manual"))
 8
 9# 自定义服务器脚本：反应mpg与其它3个变量之间的关系并绘图
10shinyServer(function(input, output) {
11  # 首先定义反应表达式，后面的output对象都会用到该表达式
12  formulaText <- reactive({
13    paste("mpg ~", input$variable)
14  })
15
16  # 打印caption标题，以文本形式输出
17  output$caption <- renderText({
18    formulaText()
19  })
20  # 根据公式输出图形，仅仅当勾选离群值时，才包含离群值
21  output$mpgPlot <- renderPlot({
22    boxplot(as.formula(formulaText()), 
23            data = mpgData,
24            outline = input$outliers)
25  })
26})

运行结果如下：

3.2.3 文本框(textInput)

对于上面的例子，稍微改一下，使用文本框手动插入标题，UI端代码如下：

 1library(shiny)
 2library(shinydashboard)
 3
 4dashboardPage(
 5  dashboardHeader(title = "文本框输入"),
 6  dashboardSidebar(
 7    # 定义选择框
 8    selectInput("variable",  # 传入变量名称
 9                "选择变量：", # 提示文字
10                # 选项内容，左边是显示字符，右边是传入变量名称，若是向量传递则字符与变量相同
11                list("气缸数" = "cyl",  
12                     "变速箱类型" = "am", # 列表传递，可以修改显示
13                     "档位数" = "gear")),
14    # 定义勾选框
15    checkboxInput("outliers",  # 传入变量名称
16                  "显示离群值", # 勾选框提示文字
17                  FALSE),  # 默认状态
18    # 定义文本框
19    textInput("text", # 传入变量名称
20              "自定义标题：") # 文本框提示字符
21    ),
22  dashboardBody(
23    fluidRow(box(plotOutput("mpgPlot", height = 250), # 以图片形式输出mpgPlot变量
24                 title = h3(textOutput("text")))) # 以三级标题形式输出text变量
25  )
26)

server端代码如下：

 1library(shiny)
 2library(datasets)
 3
 4# 数据初始化：将不依赖用户输入的数据，先在服务器脚本中计算出来
 5mpgData <- mtcars
 6## 变速箱变量因子化，增加标签：自动挡和手动挡
 7mpgData$am <- factor(mpgData$am, labels = c("Automatic", "Manual"))
 8
 9# 自定义服务器脚本：反应mpg与其它3个变量之间的关系并绘图
10shinyServer(function(input, output) {
11  # 首先定义反应表达式，后面的output对象都会用到该表达式
12  formulaText <- reactive({
13    paste("mpg ~", input$variable)
14  })
15
16  # 打印caption标题，以文本形式输出
17  output$text <- renderText({
18    input$text
19  })
20  # 根据公式输出图形，仅仅当勾选离群值时，才包含离群值
21  output$mpgPlot <- renderPlot({
22    boxplot(as.formula(formulaText()), 
23            data = mpgData,
24            outline = input$outliers)
25  })
26})

运行结果如下：

3.2.4 上传文件(fileInput)

默认shiny上传的每个文件最大不超过5Mb， 可以通过shiny.maxRequestSize选项来修改这个限制。 如在server.R的最前面加上options(shiny.maxRequestSize = 30*1024^2)，
就可以将限制提高到30Mb
这里我们以读取CSV文件作为演示，
CSV文件通常较长，我们使用DT包作为HTML控件进行输出。
DT自带renderDT()和DTOutput()，分别用于UI端和服务器端。
UI端代码如下：

 1library(shiny)
 2library(shinydashboard)
 3library(DT)
 4
 5dashboardPage(
 6  dashboardHeader(title = "上传文件"),
 7  dashboardSidebar(
 8    # 文件选择框
 9    fileInput('file1', '选择CSV文件', multiple = FALSE, 
10              accept=c('text/csv', 'text/comma-separated-values,text/plain')), # CSV文本文件
11    # 水平线条
12    tags$hr(), 
13    # 勾选框
14    checkboxInput('header', '第1行为变量名', TRUE),
15    # 单选按钮：选择分隔符
16    radioButtons('sep', '选择分隔符：',
17                 c("逗号"=',', "分号"=';', "制表符"='\t'), # 选择范围：逗号，分号，制表符
18                 selected = ','), # 默认为逗号
19    # 单选按钮：指定引号
20    radioButtons('quote', '指定引号：',
21                 c("空格"='', "双引号"='"', "单引号"="'"), # 选择范围
22                 selected = ';') # 默认为双引号
23  ),
24  dashboardBody(
25    h2("表格内容："), 
26    fluidRow(width = 8,
27             box(DT::DTOutput("contents"))) # 以DT控件输出
28  )
29)

server端代码如下：

 1library(shiny)
 2library(shiny)
 3library(DT)
 4
 5# 自定义服务器脚本
 6shinyServer(function(input, output) {
 7  # 给output对象新增contents变量
 8  output$contents <- renderDT({ 
 9    inFile <- input$file1 # file属性组成的数据框，包括name, size , type, datapath
10    if (is.null(inFile)) # 初始值应该为NULL
11      return(NULL)  # 空则返回NULL
12    # 非空则作为csv文件进行读取
13    read.csv(inFile$datapath, header=input$header, sep=input$sep, quote=input$quote)
14  })
15})

运行结果如下：

3.2.5 下载数据(download)

下载数据，目前仅仅下载CSV格式的数据比较方便。
UI端代码如下：

 1library(shiny)
 2library(shinydashboard)
 3library(DT)
 4
 5dashboardPage(
 6  dashboardHeader(title = "下载数据"),
 7  dashboardSidebar(
 8    # 选择框
 9    selectInput("dataset", "选择要下载的数据集:", 
10                choices = c("rock", "pressure", "cars")),
11    # 下载按钮
12    downloadButton('downloadData', '下载')
13  ),
14  dashboardBody(
15    h2("表格内容："), 
16    fluidRow(width = 8,
17             box(DTOutput("table"))) # 以DT控件形式输出table
18  )
19)

server端代码如下：

 1library(shiny)
 2library(DT)
 3
 4shinyServer(function(input, output) {
 5  # 定义反应表达式：产生数据集
 6  datasetInput <- reactive({
 7    switch(input$dataset,
 8           "rock" = rock,
 9           "pressure" = pressure,
10           "cars" = cars)
11  })
12  # 给output对象增加变量table
13  output$table <- renderDT({
14    datasetInput()
15  })
16  # 给output对象增加新变量downloadData
17  output$downloadData <- downloadHandler( # 下载处理器
18    filename = function() { paste(input$dataset, '.csv', sep='') },
19    # 将文件写入到临时文件file
20    content = function(file) {write.csv(datasetInput(), file)}
21  )
22})

运行结果如下：

有个小问题，输出文件没有后缀名，当然能用txt打开，期待后续优化。

3.2.6 其它小部件(widgets)

常见的小部件包括:

• helpText()短文本注释,
  

• textAreaInput(), 文本输入区域，
  

• varSelectInput(), varSelectizeInput(),多选框。
  

• sidebarSearchForm(), 搜索框。

部件太多，不可能全部演示，这里仅仅演示helpText()和submitButton()。
提交按钮，能避免输入与输出实时连接，
而是点击按钮后再更新输出，这在数据很大或计算过程复杂时很有用。
UI端代码如下：

 1library(shiny)
 2library(shinydashboard)
 3
 4dashboardPage(
 5  dashboardHeader(title = "其它部件"),
 6  dashboardSidebar(
 7    selectInput("dataset", "选择一个数据集:", 
 8                choices = c("rock", "pressure", "cars")),
 9    # 数字输入
10    numericInput("obs", "输入观测值数量:", 10),
11    # 增加解释文本
12    helpText("注：表格内只显示指定观测值数量的数据，而概况中包括所有数据"), 
13    # 换行符无效，若需要多段文本，则增加多个文本部件。
14
15    # 增加提交按钮
16    submitButton("提交")
17  ),
18  dashboardBody(
19    h2("表格内容："), 
20    fluidRow(
21      h4("概况"), # 添加4级标题
22      box(width = 11, verbatimTextOutput("summary"))),# 以文本形式打印summary变量
23    fluidRow(
24      h4("观测值"),
25      box(tableOutput("view"))) # 以表格形式输出view变量 
26  )
27)

server端代码如下：

 1library(shiny)
 2library(datasets)
 3
 4# 自定义服务器脚本：显示指定观测值数量的数据，和所有数据的概况
 5shinyServer(function(input, output) {
 6  # 定义反应表达式: 根据选择框输入产生数据集
 7  datasetInput <- reactive({
 8    switch(input$dataset, # 将选择框传入的dataset变量添加到input对象中
 9           "rock" = rock, # 前面是dataset中的变量，后面是数据集中的变量，是真的变量
10           "pressure" = pressure,
11           "cars" = cars)
12  })
13
14  # 打印文本：打印选择数据集的summary
15  output$summary <- renderPrint({
16    dataset <- datasetInput()
17    summary(dataset)
18  })
19
20  # 输出表格，只显示选择数据集内，观测值数量的数据
21  output$view <- renderTable({
22    head(datasetInput(), n = input$obs)
23  })
24})

运行结果如下：

3.3

侧边栏

前面搭配输入输出讲的侧边栏都是静态侧边栏。

3.3.1 动态侧边栏

接下来介绍动态侧边栏。
侧边栏同样可以通过后台数据来产生。
需要在UI端使用sidebarMenuOutput()。
同时在服务器端使用renderMenu()。
UI端代码如下：

 1library(shiny)
 2library(shinydashboard)
 3
 4dashboardPage(
 5  dashboardHeader(title = "动态侧边栏"),
 6  dashboardSidebar(dropdownMenuOutput("myMenu")), # 以下拉菜单形式输出myMenu变量),
 7  dashboardBody(
 8    tabItems(
 9      tabItem(tabName = "dashboard", # 根据menuItem中的tabName进行联动
10              h2("图表页内容")), # 增加2级标题
11      tabItem(tabName = "widgets", # 根据menuItem中的tabName进行联动
12              h2("小部件页内容"))
13    )
14  )
15)

服务器端代码如下：

 1library(shiny)
 2library(shinydashboard)
 3
 4# 获取侧边栏数据
 5menudata <- data.frame(
 6  text = c("图表页", "小部件页"),
 7  tabnames = c("dashboard", "widgets"),
 8  iconname = c("dashboard", "th"),
 9  stringsAsFactors = FALSE
10)
11
12# 定义服务器脚本
13shinyServer(function(input, output) {
14  # 给output对象增加menu变量
15  output$myMenu <- renderMenu({ # 以menu形式输出
16    mymenu_list <- apply(menudata, 1, function(row){
17      menuItem(text = row[["text"]], 
18               tabName = row[["tabnames"]], 
19               icon = icon(row[["iconname"]]))
20    })
21    sidebarMenu(.list = mymenu_list) 
22  })
23})

运行结果如下：

3.3.2 无侧边栏(disable)

使用dashboardSidebar(disable = TRUE)即可。

3.4

主体(Body)

dashboard的主体可以包含任何内容，包括图片，文本，表格，leaflet控件，甚至输入对象。

最常见的主体是~box,~box同样可以包含任何内容。

对象框(Boxes)：
通常将box置于fluidRow()内。
下面的例子中内含2个对象框，对象框内有纯文本，图片，滑动条，文本框。
UI端代码如下：

 1library(shiny)
 2library(shinydashboard)
 3
 4dashboardPage(
 5  dashboardHeader(title = "对象框"),
 6  dashboardSidebar(disable = FALSE), 
 7  dashboardBody(
 8    fluidRow(
 9      box(plotOutput("gplot_1"), width = 8),
10      box(width = 4,
11        "随便打的文本", # 直接插入文本
12        br(), # 换行符
13        "随便码的文字", # 直接插入文本
14        sliderInput("slider", "请输入观测值数量：", 50, 500, 200), # 插入滑动条
15        textInput("text_1", "请输入标题：", value = "我是标题"), # 插入文本框
16        textInput("text_2", "输入横轴名称：", value = "我是x轴"), # 插入文本框
17        textInput("text_3", "输入纵轴名称：", value = "我是y轴"), # 插入文本框
18        submitButton("提交")) # ggplot2运算复杂，需增加提交按钮
19
20    )
21  )
22)

server端代码如下：

 1library(shiny)
 2library(ggplot2)
 3library(RColorBrewer)
 4library(showtext)
 5
 6# 自定义服务器脚本，
 7shinyServer(function(input, output) {
 8  # 定义反应表达式，产生数据
 9  datainput <- reactive({
10    data.frame(abc = sample(LETTERS[1:7], size = input$slider, replace = TRUE), 
11               stringsAsFactors = F)
12  })
13  # 添加图片对象
14  output$gplot_1 <- renderPlot({ # 内部可以插入计算代码
15    showtext_auto()
16    ggplot(data = datainput()) + # 注意datainput()括号不能少
17      geom_bar(aes(abc, fill = abc)) +
18      scale_fill_brewer(palette = "Set2") + 
19      labs(title = input$text_1, x = input$text_2, y = input$text_3) + 
20      theme_void() + 
21      theme(
22        plot.title = element_text(colour = "magenta", hjust = 0.5, size = 30),
23        axis.title.x = element_text(colour = "blue", hjust = 0.5, size = 20),
24        axis.title.y = element_text(colour = "blue", hjust = 0.5, angle = 90, size = 20),
25        axis.text = element_text(colour = "black", size = 10)
26        )
27  })
28
29})
30

结果如图：

3.4.1 常规对象框(box)

box()内基本参数：

• ..., 表示放入对象框中的对象，
  

• title, 表示指定对象框的标题，
  

• footer, 表示脚标文本，
  

• status, 表示指定item的状态，决定该对象框title的背景颜色，
  有5种状态及对应的颜色，见?validStatuses。
  

• solidHeader,为逻辑值，表示对象框标题是否为纯色背景。
  

• backgroud, 表示指定对象框背景颜色，NULL则为白色背景。支持的颜色见?validColors。
  

• width, 表示指定对象框的宽度，总的宽度为12，若指定为4则表示1/3主体宽度。
  

• height, 表示指定对象框的高度，shiny::plotOut()内同样有设定长宽的参数。
  

• collapsible, 表示是否给对象框增加最小化按钮(在右上角)。

这次我们在上次的基础上修改代码，UI端代码如下：

 1library(shiny)
 2library(shinydashboard)
 3
 4dashboardPage(
 5  dashboardHeader(title = "对象框"),
 6  dashboardSidebar(disable = FALSE), 
 7  dashboardBody(
 8    fluidRow(
 9      box(plotOutput("gplot_1"), title = textOutput("text_1"), # 文本输出标题
10          width = 8, status = "primary", solidHeader = TRUE, 
11          collapsible = TRUE, background = "fuchsia"), # 最小化按钮，洋红色背景
12      box(width = 4, background = "lime", # 黄绿色背景
13        "随便打的文本", # 直接插入文本
14        br(), # 换行符
15        "随便码的文字", # 直接插入文本
16        sliderInput("slider", "请输入观测值数量：", 50, 500, 200), # 插入滑动条
17        textInput("text_1", "请输入标题：", value = "我是标题"), # 插入文本框
18        textInput("text_2", "输入横轴名称：", value = "我是x轴"), # 插入文本框
19        textInput("text_3", "输入纵轴名称：", value = "我是y轴"), # 插入文本框
20        submitButton("提交")) # ggplot2运算复杂，需增加提交按钮
21
22    )
23  )
24)

server端代码如下：

 1library(shiny)
 2library(ggplot2)
 3library(RColorBrewer)
 4library(showtext)
 5
 6# 自定义服务器脚本，
 7shinyServer(function(input, output) {
 8  # 定义反应表达式，产生数据
 9  datainput <- reactive({
10    data.frame(abc = sample(LETTERS[1:7], size = input$slider, replace = TRUE), 
11               stringsAsFactors = F)
12  })
13  # 添加图片对象
14  output$gplot_1 <- renderPlot({ # 内部可以插入计算代码
15    showtext_auto()
16    ggplot(data = datainput()) + # 注意datainput()括号不能少
17      geom_bar(aes(abc, fill = abc)) +
18      scale_fill_brewer(palette = "Set2") + 
19      labs(x = input$text_2, y = input$text_3) + 
20      theme_void() + 
21      theme(
22        axis.title.x = element_text(colour = "blue", hjust = 0.5, size = 20),
23        axis.title.y = element_text(colour = "blue", hjust = 0.5, angle = 90, size = 20),
24        axis.text = element_text(colour = "black", size = 10)
25        )
26  })
27  # 文本输出
28  output$text_1 <- renderText({
29    input$text_1
30  })
31
32})
33

运行结果如图：

修改UI端box参数：
status = "success", solidHeader = TRUE,结果box标题背景颜色变成了绿色：

status = "success", solidHeader = FALSE,看不出有什么变化：

status = NULL, solidHeader = TRUE,,box标题颜色与背景颜色一致。

status = NULL, solidHeader = FALSE,, 看不出变化。

3.4.2 tabBox

给对象框增加选项卡，在同一区域可以切换不同的对象框。
实现方法：

• 在fluidRow()内添加tabBox(),
  

• 在tabBox()内添加tablePanel()。
  

• 在tablePanel()内添加输出对象。

接下来我们我们随便做几个简单的tabBox, UI端代码如下：

 1library(shiny)
 2library(shinydashboard)
 3
 4dashboardPage(
 5  dashboardHeader(title = "tabBox"),
 6  dashboardSidebar(disable = FALSE), # 
 7  dashboardBody(
 8    fluidRow(
 9      tabBox(
10        title = "绘图区域",id = "tabbox1", selected = "Tab1", # 默认显示Tab1
11        # 服务器端根据id号，input$tabset1来匹配
12
13        width = 8, side = "right", # side表示tablePanel的顺序，right表示反向
14        tabPanel(title = "图1", value = "Tab1", # value与tabBox内的selected匹配
15                 "第1个图的内容", br(), plotOutput("plot1")), # 内容
16        tabPanel(title = "图2", value = "Tab2",
17                 "第2个图的内容", br(), plotOutput("plot2"))
18      ),
19      tabBox(
20        title = "表格区域", id = "tabbox2", selected = "Tab3", 
21        width = 4, side = "left",  # 默认显示左起第3个图表
22        tabPanel(title = "表1", value = "Tab1", 
23                 "第1个表的内容", br(), tableOutput("table1")), # 显示内容
24        tabPanel(title = "表2", value = "Tab2", 
25                 "第2个表的内容", br(), tableOutput("table2")),
26        tabPanel(title = "表3", value = "Tab3", 
27                 "第3个表的内容", br(), tableOutput("table3"))
28      )
29    ),
30    fluidRow(
31      tabBox(
32        title = tagList(shiny::icon("gear"), "状态区域"),# 标题也可以包含icon
33        id = "tabbox3", selected = "Tab1",
34        tabPanel(title = "状态1", value = "Tab1", 
35                 "随便码一行文字:",br(), "再码一行文字", br(),
36                 verbatimTextOutput("summary")), # 文本形式输出变量tabset1Selected
37        tabPanel(title = "状态2", value = "Tab2", 
38                 "状态2的内容", br(), verbatimTextOutput("str"))
39    ))
40
41  )
42
43)

server端代码如下：

 1library(shiny)
 2library(ggplot2)
 3
 4# 编造数据集
 5set.seed(123)
 6mydata <- data.frame(abc = sample(letters[1:7], size = 100, replace = TRUE),
 7                     ABC = sample(LETTERS[1:7], size = 100, replace = TRUE),
 8                     numb1 = rnorm(100),
 9                     numb2 = 1:100)
10# 自定义服务器脚本，
11shinyServer(function(input, output) {
12  #
13  output$plot1 <- renderPlot({
14    ggplot(mydata) + 
15      geom_bar(aes(abc, fill = abc)) + 
16      scale_fill_brewer(palette = "Set2") + 
17      theme_classic()
18  })
19
20  output$plot2 <- renderPlot({
21    ggplot(mydata) + 
22      geom_point(aes(x = numb2, y = numb1), color = "magenta") + 
23      theme_bw()
24  })
25
26  output$table1 <- renderTable({
27    head(mydata, 6L)
28  })
29
30  output$table2 <- renderTable({
31    head(mydata[7:12,])
32  })
33
34  output$table3 <- renderTable({
35    head(mydata[13:18,])
36  })
37
38  output$summary <- renderPrint({
39    summary(mydata)
40  })
41
42  output$str <- renderPrint({
43    str(mydata)
44  })
45
46})

运行结果如下：

3.4.3 infoBox

infoBox是一种特殊的对象框, 用于展示一些数字和文字，同时附带icon图标。还可以添加链接。
UI端代码如下：

 1library(shiny)
 2library(shinydashboard)
 3
 4dashboardPage(
 5  dashboardHeader(title = "infoBox"),
 6  dashboardSidebar(disable = FALSE), # 以下拉菜单形式输出myMenu变量
 7  dashboardBody(
 8    # 半填充的infoBox, fill=FALSE
 9    fluidRow(
10      # 静态的infoBox
11      infoBox(title = "定单", value = 10 * 2, icon = icon("credit-card")),
12      # 动态的infoBoxes
13      infoBoxOutput("progressBox"),
14      infoBoxOutput("approvalBox")
15    ),
16
17    # 全填充的infoBox, fill = TRUE
18    fluidRow(
19      infoBox(title = "定单", value = 10 * 2, 
20              icon = icon("credit-card"), fill = TRUE),
21      infoBoxOutput("progressBox2"),
22      infoBoxOutput("approvalBox2")
23    ),
24
25    fluidRow(
26      # 计数按钮：点击这个会增加数量
27      box(width = 4, actionButton("addtion", label = "增加赞", icon = icon("plus"))),
28      box(width = 4, actionButton("minus", label = "减少赞", icon = icon("minus")))
29    )
30  )
31)

server端代码如下：

 1library(shiny)
 2
 3# 自定义服务器脚本，
 4shinyServer(function(input, output) {
 5  # 定义反应表达式：计算点赞量
 6  count_thumbs <- reactive({
 7    comprehensive <- input$addtion - input$minus
 8    if(comprehensive > 0) {
 9      positive <- comprehensive 
10      negative <- 0
11    } else {
12      positive <- 0
13      negative <- comprehensive
14    }
15    thumbs_bind <- c(positive, negative)
16  })
17
18  # 增加infobox
19  output$progressBox <- renderInfoBox({
20    infoBox(
21      title = "变化", value = paste0(25, "%"), 
22      icon = icon("list"), color = "purple")
23  })
24  output$approvalBox <- renderInfoBox({
25    infoBox(
26      title = "赞同", value = 25 + count_thumbs()[1], 
27      icon = icon("thumbs-up"), color = "yellow")
28  })
29
30  # 与上面一样，除了fill=TRUE全填充
31  output$progressBox2 <- renderInfoBox({
32    infoBox(
33      title = "变化", value = paste0(25, "%"), 
34      icon = icon("list"),color = "purple", fill = TRUE)
35  })
36
37  output$approvalBox2 <- renderInfoBox({
38    infoBox(
39      title = "不赞同", value = 25 - count_thumbs()[2], 
40      icon = icon("thumbs-down"), color = "yellow", fill = TRUE)
41  })
42
43})

运行结果如下：

3.4.4 valueBox

valueBox与infobox十分相似，只是外表不一样。我们在上一节的代码上修改即可，
UI端代码如下：

 1library(shiny)
 2library(shinydashboard)
 3
 4dashboardPage(
 5  dashboardHeader(title = "valueBox"),
 6  dashboardSidebar(disable = FALSE), # 
 7  dashboardBody(
 8    fluidRow(
 9      # 静态的valueBox
10      valueBox(value = 10 * 2, subtitle = "新增用户", icon = icon("credit-card")),
11
12      # 动态的valueBoxes
13      valueBoxOutput("progressBox"),
14      valueBoxOutput("approvalBox"),
15      valueBoxOutput("disapprovalBox")
16    ),
17    fluidRow(
18      # 增加计数按钮
19      box(width = 4, actionButton("more", label = "增加", icon = icon("plus"))),
20      box(width = 4, actionButton("less", label = "减少", icon = icon("minus")))
21    )
22  )
23)

server端代码如下：

 1library(shiny)
 2
 3# 自定义服务器脚本，
 4shinyServer(function(input, output) {
 5  # 定义反应表达式：计算点赞量
 6  count_thumbs <- reactive({
 7    comprehensive <- input$more - input$less
 8    if(comprehensive > 0) {
 9      positive <- comprehensive 
10      negative <- 0
11    } else {
12      positive <- 0
13      negative <- comprehensive
14    }
15    thumbs_bind <- c(positive, negative)
16  })
17
18  output$progressBox <- renderValueBox({
19    valueBox(
20      value = paste0(25, "%"), subtitle = "进步", 
21      icon = icon("list"), color = "purple")
22  })
23
24  output$approvalBox <- renderValueBox({
25    valueBox(
26      value = 80 + count_thumbs()[1], subtitle = "赞成", 
27      icon = icon("thumbs-up"), color = "yellow")
28  })
29
30  output$disapprovalBox <- renderValueBox({
31    valueBox(
32      value = 80 + count_thumbs()[2], subtitle = "不赞成", 
33      icon = icon("thumbs-down"), color = "yellow")
34  })
35})

运行结果如下：

3.5

布局(Layouts)

首先我需要了解一下关于网页的网格布局方案，该方案将主体等分为12列，任意行数。

该方案中，网页的高度是变化的。 当你将1个box放置于主体中，需要指定其占多少个列。
工整的布局主要分为2种：多行布局，多列布局。

3.5.1 多行布局

依次添加多个fluidRow()对象。
fluidRow()内的~box()通常没有height参数。
如添加参数height,同一行height必须相同，即同一个fluidRow内的height必须相同。
height用像素尺寸指定，如height = 300。
下面的代码展示的3行布局多个boxes, UI端代码如下：

 1library(shiny)
 2library(shinydashboard)
 3
 4# 定义body
 5body <- dashboardBody(
 6  # 第1行
 7  fluidRow(
 8    box(title = "第1行第1个", "随便码几个字"),
 9    box(title = "第1行第2个", status = "warning", "warning状态")),
10  # 第2行
11  fluidRow(
12    box(
13      title = "第2行第1个", width = 3, solidHeader = TRUE, 
14      status = "primary", "primary状态", br(), "宽3"),
15    box(
16      title = "第2行第2个", width = 4, solidHeader = TRUE,
17      "随便码几个字", br(), "宽4"),
18    box(
19      title = "第2行第3个", width = 5, solidHeader = TRUE, 
20      status = "warning", "warning状态", br(), "宽5")),
21  # 第3行
22  fluidRow(
23    box(
24      title = "第3行第1个", width = 5, height = 400, 
25      background = "black","黑色背景", br(), "宽5"),
26    box(
27      title = "第3行第2个", width = 4, height = 400, 
28      background = "light-blue","浅蓝色背景", br(), "宽4"),
29    box(
30      title = "第3行第3个", width = 3, height = 400, 
31      background = "maroon", "栗色背景", br(), "宽3"))
32)
33
34# 组合
35dashboardPage(
36  dashboardHeader(title = "多行布局"),
37  dashboardSidebar(disable = TRUE), # 
38  dashboardBody(body)
39)

server端代码如下：

1library(shiny)
2
3# 自定义服务器脚本，
4shinyServer(function(input, output) {})

运行结果如下：

3.5.2 多列布局

在fluidRow()内依次添加多个column()对象。再在column()添加~box()对象。
column()内的~box()通常width=NULL, 默认为6。
而将width参数添加到column()内。 同一个column()内的，各个~box()的height参数可以不同。
column()内可以设定offset偏移参数，表示与前1列之间的间隙，单位与width相同。

 1library(shiny)
 2library(shinydashboard)
 3
 4# 定义body
 5body <- dashboardBody(
 6
 7  fluidRow(
 8    # 第1列
 9    column(width = 3,
10           box(
11             title = "第1列第1个", width = NULL, height = 200, # 必须width = NULL, 因为默认为6
12             status = "primary","primary状态", br(), "高200"),
13           box(
14             title = "第1列第2个", width = NULL, height = 100, solidHeader = TRUE, 
15             status = "primary", "primary状态", br(), "高100"),
16           box(
17             title = "第1列第3个",width = NULL, height = 300, 
18             background = "black", "背景颜色：black", br(), "高300")
19    ),
20    # 第2列
21    column(width = 4, offset = 2, # offset = 2，跟前一列之间增加间隙2个宽度
22           box(
23             title = "第2列第1个", status = "warning", width = NULL, height = 100, 
24             "warning状态", br(), "高100"),
25           box(
26             title = "第2列第2个", width = NULL, height = 200, solidHeader = TRUE, 
27             status = "warning","warning状态", br(), "高200"),
28           box(
29             title = "第2列第3个", width = NULL, height = 300, 
30             background = "light-blue", "背景颜色：light-blue", br(), "高300")
31    ),
32    # 第3列
33    column(width = 3,
34           box(
35             title = "第3列第1个", width = NULL, height = 300, solidHeader = TRUE,
36             "随便码几个字", br(), "高300"),
37           box(
38             title = "第3列第2个", width = NULL, height = 200, 
39             background = "maroon", "背景颜色：maroon", br(), "高200")
40    )
41  )
42)
43
44# 组合
45dashboardPage(
46  dashboardHeader(title = "多列布局"),
47  dashboardSidebar(disable = TRUE), # 
48  dashboardBody(body)
49)

server端代码如下：

1library(shiny)
2
3# 自定义服务器脚本，
4shinyServer(function(input, output) {})

运行结果如下：

因正文字数限制，余下此篇内容，下期分享。

往期精彩：

• R语言ETL系列：汇总（summarise）
  

• 想跟数据分析师说几句话？

• R导出可编辑图到ppt：结合使用ggplot2以及officer
  

• R语言中文社区2018年终文章整理（作者篇）

• R语言中文社区2018年终文章整理（类型篇）