shinydashboard与shiny_史上最全（二）
欢迎关注天善智能，我们是专注于商业智能BI，人工智能AI，大数据分析与挖掘领域的垂直社区，学习，问答、求职一站式搞定！
对商业智能BI、大数据分析挖掘、机器学习，python，R等数据领域感兴趣的同学加微信：tstoutiao，邀请你进入数据爱好者交流群，数据爱好者们都在这儿。
作者：李誉辉
四川大学在读研究生
前言
这是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})
运行结果如下：
因正文字数限制，余下此篇内容，下期分享。
往期精彩：
R语言ETL系列：汇总（summarise）
想跟数据分析师说几句话？
R导出可编辑图到ppt：结合使用ggplot2以及officer
R语言中文社区2018年终文章整理（作者篇）
R语言中文社区2018年终文章整理（类型篇）
公众号后台回复关键字即可学习
回复 爬虫 爬虫三大案例实战
回复 Python 1小时破冰入门
回复 数据挖掘 R语言入门及数据挖掘
回复 人工智能 三个月入门人工智能
回复 数据分析师 数据分析师成长之路
回复 机器学习 机器学习的商业应用
回复 数据科学 数据科学实战
回复 常用算法 常用数据挖掘算法