15  交互应用

一个简单示例,介绍一个 Shiny 应用的各个常见组成部分。一个快速改变风格的主题包。介绍交互表格、交互图形与 Shiny 集成,如 DTplotlyleaflet 等。介绍 Shiny 工业化应用的开发过程。

15.1 简单示例

library(shiny)

ui <- fluidPage(
  sliderInput(inputId = "n", label = "观测记录的数目", 
              min = 1, max = nrow(faithful), value = 100),
  plotOutput("plot")
)

server <- function(input, output) {
  output$plot <- renderPlot({
    hist(faithful$eruptions[seq_len(input$n)],
      breaks = 40,
      main = "美国黄石公园喷泉",
      xlab = "喷发持续时间"
    )
  })
}

shinyApp(ui, server)

15.1.1 UI 前端

15.1.2 Server 后端

15.2 Shiny 组件

组件又很多,下面想重点介绍 4 个,它们使用频次很高,很有代表性。

15.2.1 筛选器

单个筛选器、独立筛选器、筛选器联动

15.2.2 输入框

数值型、文本型

15.2.3 动作按钮

提交按钮、响应按钮

15.2.4 书签

书签记录输入状态,链接可以指向页面状态

library(shiny)

ui <- fluidPage(
  sliderInput(inputId = "n", label = "观测记录的数目", 
              min = 1, max = nrow(faithful), value = 100),
  plotOutput("plot"),
  bookmarkButton(id = "bookmark1", label = "书签", title = "记录、分享此时应用的状态")
)

server <- function(input, output) {
  output$plot <- renderPlot({
    hist(faithful$eruptions[seq_len(input$n)],
      breaks = 40,
      main = "美国黄石公园喷泉",
      xlab = "喷发持续时间"
    )
  })
}

enableBookmarking(store = "url")
shinyApp(ui, server)

15.3 Shiny 扩展

页面布局

交互表格

  • DT
  • reactable

交互图形

  • plotly
  • ggiraph

15.3.1 页面布局

15.3.2 交互表格

下面在 Shiny 应用中插入 DT 包制作的交互表格

# 前端
library(shiny)
ui <- fluidPage(
  # 应用的标题名称
  titlePanel("鸢尾花数据集"),
  # 边栏
  fluidRow(
    column(12, DT::dataTableOutput("table"))
  )
)

# 服务端
server <- function(input, output, session) {
  output$table <- DT::renderDataTable(iris,
    options = list(
      pageLength = 5, # 每页显示5行
      initComplete = I("function(settings, json) {alert('Done.');}")
    ), server = F
  )
}

shinyApp(ui, server)
重要

加载 shiny 包后再加载 DT 包,函数 dataTableOutput()renderDataTable() 显示冲突,因为两个 R 包都有这两个函数。在创建 shiny 应用的过程中,如果我们需要呈现动态表格,就需要使用 DT 包的 DT::dataTableOutput()DT::renderDataTable() ,否则会报错,详见 https://github.com/rstudio/shiny/issues/2653

reactable 基于 JS 库 React Table 提供交互式表格渲染,和 shiny 无缝集成,是替代 DT 的不二选择,在 app.R 用 reactable 包的 reactableOutput()renderReactable() 函数替代 shiny 里面的 dataTableOutput()renderDataTable()。 再也不用忍受 DTshiny 的函数冲突了,且其覆盖测试达到 99%。

library(shiny)

下面在 Shiny 应用中插入 reactable 包制作的交互表格

library(shiny)
library(reactable)

ui <- fluidPage(
  reactableOutput("table")
)

server <- function(input, output) {
  output$table <- renderReactable({
    reactable(iris,
      filterable = TRUE, # 过滤
      searchable = TRUE, # 搜索
      showPageSizeOptions = TRUE, # 页面大小
      pageSizeOptions = c(5, 10, 15), # 页面大小可选项
      defaultPageSize = 10, # 默认显示10行
      highlight = TRUE, # 高亮选择
      striped = TRUE, # 隔行高亮
      fullWidth = FALSE, # 默认不要全宽填充,适应数据框的宽度
      defaultSorted = list(
        Sepal.Length = "asc", # 由小到大排序
        Petal.Length = "desc" # 由大到小
      ),
      columns = list(
        Sepal.Width = colDef(style = function(value) { 
          # Sepal.Width 添加颜色标记
          if (value > 3.5) {
            color <- "#008000"
          } else if (value > 2) {
            color <- "#e00000"
          } else {
            color <- "#777"
          }
          list(color = color, fontWeight = "bold") # 字体加粗
        })

      )
    )
  })
}

shinyApp(ui, server)

除了 DTreactable 包,其它支持 Shiny 集成的 R 包还有 gtformattablekableExtra 等。

15.3.3 交互图形

ggiraph

15.4 Shiny 仪表盘

dashboard 翻译过来叫仪表盘,就是驾驶仓的那个玩意,形象地表达作为掌舵者应该关注的对象。R 包 shiny 出现后,仪表盘的制作显得非常容易,也很快形成了一个生态,比如 shinydashboardflexdashboard 等,此外 bs4Dash 基于 Bootstrap 4 的仪表盘,目前 shiny 和 rmarkdown 都在向 Bootstrap 4 升级,这是未来的方向。 shinydashboardPlus 主要目的在于扩展 shinydashboard

15.4.1 shinydashboard 包

将如下内容保存为 app.R 文件。

library(shiny)
library(shinydashboard)
ui <- dashboardPage(
  dashboardHeader(title = "Basic dashboard"),
  ## 边栏
  dashboardSidebar(
    sidebarMenu(
      menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
      menuItem("Widgets", tabName = "widgets", icon = icon("th"))
    )
  ),
  ## 主体内容
  dashboardBody(
    tabItems(
      # 第一个 Tab 页内容
      tabItem(
        tabName = "dashboard",
        fluidRow(
          box(plotOutput("plot1", height = 250)),
          box(
            title = "Controls",
            sliderInput("slider", "Number of observations:", 1, 100, 50)
          )
        )
      ),

      # 第二个 Tab 页内容
      tabItem(
        tabName = "widgets",
        h2("Widgets tab content")
      )
    )
  )
)

server <- function(input, output) {
  set.seed(122)
  histdata <- rnorm(500)

  output$plot1 <- renderPlot({
    data <- histdata[seq_len(input$slider)]
    hist(data)
  })
}

shinyApp(ui, server)

15.4.2 shinydashboardPlus 包

shinydashboardPlus 包的函数 descriptionBlock()

library(shiny)
library(shinydashboard)
library(shinydashboardPlus)

shinyApp(
  ui = dashboardPage(
    dashboardHeader(),
    dashboardSidebar(),
    dashboardBody(
      box(
        solidHeader = FALSE,
        title = "状态概览",
        background = NULL,
        width = 4,
        status = "danger",
        footer = fluidRow(
          column(
            width = 6,
            descriptionBlock(
              number = "17%",
              numberColor = "green",
              numberIcon = "fa fa-caret-up",
              header = "$35,210.43",
              text = "总收入",
              rightBorder = TRUE,
              marginBottom = FALSE
            )
          ),
          column(
            width = 6,
            descriptionBlock(
              number = "18%",
              numberColor = "red",
              numberIcon = "fa fa-caret-down",
              header = "1200",
              text = "目标完成",
              rightBorder = FALSE,
              marginBottom = FALSE
            )
          )
        )
      )
    ),
    title = "Description Blocks"
  ),
  server = function(input, output) { }
)

15.4.3 bs4Dash 包

library(bs4Dash)
ui <- dashboardPage(
  dashboardHeader(title = "Basic dashboard"),
  dashboardSidebar(),
  dashboardBody(
    # Boxes need to be put in a row (or column)
    fluidRow(
      box(plotOutput("plot1", height = 250)),
      
      box(
        title = "Controls",
        sliderInput("slider", "Number of observations:", 1, 100, 50)
      )
    )
  )
)

server <- function(input, output) {
  set.seed(122)
  histdata <- rnorm(500)
  
  output$plot1 <- renderPlot({
    data <- histdata[seq_len(input$slider)]
    hist(data)
  })
}

shinyApp(ui, server)

15.4.4 miniUI 包

miniUI 包制作迷你版 Shiny 应用,适用于小屏幕显示。

library(shiny)
library(miniUI)
library(leaflet)
library(ggplot2)

ui <- miniPage(
  gadgetTitleBar("Shiny gadget example"),
  miniTabstripPanel(
    miniTabPanel(title = "参数",
      icon = icon("sliders"),
      miniContentPanel(
        sliderInput("year", "年份", 1978, 2010, c(2000, 2010), sep = "")
      )
    ),
    miniTabPanel(title = "可视化",
      icon = icon("area-chart"),
      miniContentPanel(
        plotOutput("quakes", height = "100%")
      )
    ),
    miniTabPanel(title = "地图",
      icon = icon("map-o"),
      miniContentPanel(
        padding = 0,
        leafletOutput("map", height = "100%")
      ),
      miniButtonBlock(
        actionButton("resetMap", "Reset")
      )
    ),
    miniTabPanel(title = "数据",
      icon = icon("table"),
      miniContentPanel(
        DT::dataTableOutput("table")
      )
    ),
    selected = "Map"
  )
)

server <- function(input, output, session) {
  output$quakes <- renderPlot({
    ggplot(quakes, aes(long, lat)) +
      geom_point()
  })

  output$map <- renderLeaflet({
    force(input$resetMap)

    leaflet(quakes, height = "100%") |>
      addTiles() |>
      addMarkers(lng = ~long, lat = ~lat)
  })

  output$table <- DT::renderDataTable({
    quakes
  })

  observeEvent(input$done, {
    stopApp(TRUE)
  })
}

shinyApp(ui, server)

15.5 Shiny 主题

15.5.1 bslib 包

15.5.2 shinymaterial 包

shinymaterial 包实现 Material Design

library(shiny)
library(shinymaterial)

ui <- material_page(
  title = "用户画像",
  nav_bar_fixed = TRUE,
  # 每个 sidebar 内容
  material_side_nav(
    fixed = TRUE,
    # Place side-nav tabs within side-nav
    material_side_nav_tabs(
      side_nav_tabs = c(
        "数据汇总" = "tab_1",
        "趋势信息" = "tab_2"
      ),
      icons = c("cast", "insert_chart")
    )
  ),
  # 每个 tab 页面的内容
  material_side_nav_tab_content(
    side_nav_tab_id = "tab_1",
    tags$h2("第一个tab页")
  ),
  material_side_nav_tab_content(
    side_nav_tab_id = "tab_2",
    tags$h2("第二个tab页")
  )
)

server <- function(input, output) {

}
shinyApp(ui = ui, server = server)

15.6 Shiny 部署

15.6.1 promises 并发

shiny 异步编程实现并发访问,多人同时访问 Shiny 应用的情况下,解决必须等另一个人完成访问的情况下才能继续访问的问题。

library(shiny)
library(future)
library(promises)

plan(multiprocess)

ui <- fluidPage(
  h2("测试异步下载"),
  tags$ol(
    tags$li("Verify that plot appears below"),
    tags$li("Verify that pressing Download results in 5 second delay, then rock.csv being downloaded"),
    tags$li("Check 'Throw on download?' checkbox and verify that pressing Download results in 5 second delay, then error, as well as stack traces in console")
  ),
  hr(),
  checkboxInput("throw", "Throw on download?"),
  downloadButton("download", "下载 (等待5秒)"),
  plotOutput("plot")
)

server <- function(input, output, session) {
  output$download <- downloadHandler("rock.csv", function(file) {
    future({Sys.sleep(5)}) %...>%
      {
        if (input$throw) {
          stop("boom")
        } else {
          write.csv(rock, file)
        }
      }
  })

  output$plot <- renderPlot({
    plot(cars)
  })
}

shinyApp(ui, server)

15.7 Shiny 替代品

R Markdown 文档

  • crosstalk 交互
  • flexdashboard 布局
  • DT 交互表格
  • leaflet 交互地图
  • ggiraph 交互图形

Quarto 文档

15.8 Shiny 案例

  • radiant 探索性数据分析解决方案

15.9 总结

图 15.1: Shiny 生态系统
  • 连接数据库。根据数据库的情况选择相应的 R 接口包,比如连接 MySQL 数据库可以用 RMySQL 包,值得一提, odbc 包支持连接相当多的数据库。
  • 数据操作。根据需要处理的数据规模,可以选择 Base R、 data.table 或者 dplyr 做数据操作,推荐和管道操作一起使用,增加代码可读性。
  • 交互表格。推荐 reactable 和 DT 包做数据呈现。
  • 交互图形。推荐功能强大的 plotly 包,可以先用 ggplot2 绘制,然后调用 plotly 包的 ggplotly() 函数将静态图转化为交互图。
  • 针对特定应用场景的其它交互可视化工具包,比如 leaflet 可以将地图嵌入 Shiny 应用, dygraphs 可以将时间序列塞进去。
  • Shiny 组件。shinyFeedback 提供用户输入的反馈。shinyWidgets 提供自定义 widget 的功能。
  • Shiny 主题。比如 shinythemes 包 可以统一配色,dashboardthemes 提供更加深度的主题,shinytableau 提供仿 Tableau 的 dashboard 框架。sass 在 CSS 样式层面重定义风格。
  • Shiny 权限。shinymanager 支持单个 shiny 应用的权限管理,firebase 提供访问权限设置 https://firebase.john-coene.com/
  • Shiny 框架。ShinyStudio 打造基于容器架构的协作开发环境的开源解决方案,golem 构建企业级 shiny 应用的框架,RinteRface 开发的系列 R 包也试图打造一套完整的解决方案,并配有速查小抄 cheatsheets
  • Shiny 部署。shiny-server 以网络服务的方式支持 shiny 应用,shinyproxy 提供企业级部署 shiny 应用的开源解决方案。

Shiny 生态非常庞大,资源非常丰富。

特别值得一提,Shiny 方面的三本专著。