14.4 基础组件

14.4.1 书签

链接可以指向页面状态

library(shiny)

ui <- function(request) {
  fluidPage(
    plotOutput("plot"),
    sliderInput("n", "Number of observations", 1, nrow(faithful), 100),
    bookmarkButton()
  )
}

server <- function(input, output, session) {
  output$plot <- renderPlot({
    hist(faithful$eruptions[seq_len(input$n)], breaks = 40)
  })
}

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

14.4.2 表格

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

library(shiny)
library(data.table)

gt 高度自定义 gt 表格样式,支持 shiny 集成, data.table 提供高效的数据操作,formattable 支持自定义格子。

kableExtra 包

library(shiny)
library(data.table)
library(magrittr)
library(kableExtra)

ui <- fluidPage(
  title = "mtcars datasets",
  titlePanel("mtcars 数据集"),

  sidebarLayout(
    sidebarPanel(
      sliderInput("mpg", "mpg 范围",
        min = 11, max = 33, value = 15
      )
    ),

    mainPanel(
      tableOutput("mtcars_kable")
    )
  )
)

## 设置列序 https://stackoverflow.com/questions/19619666/change-column-position-of-data-table
server <- function(input, output) {
  output$mtcars_kable <- function() {
    # 转化数据类型
    mtcars_dt <- as.data.table(mtcars)
    # 添加新的列
    mtcars_dt[, car := rownames(mtcars)][mpg <= input$mpg] %>%
    setcolorder(., c("car", setdiff(names(.), "car"))) %>%
      knitr::kable("html") %>%
      kable_styling("striped", full_width = F) %>%
      add_header_above(c(" ", "Group 1" = 5, "Group 2" = 6))
  }
}

# 执行程序
shinyApp(ui = ui, server = server)

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)

下面介绍 DT

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

# server.R 服务端
library(shiny)
shinyServer(function(input, output, session) {
  output$table <- iris %>%
    `colnames<-`(., gsub("\\.", "_", tolower(colnames(.)))) %>%
    DT::renderDataTable(.,
      options = list(
        pageLength = 5, # 每页显示5行
        initComplete = I("function(settings, json) {alert('Done.');}")
      ), server = F
    )
})

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

在 server.R 里我们对数据集 iris 做了重命列名的操作,如果不使用管道操作,通常是下面这样操作。

colnames(iris) <- gsub("\\.", "_", tolower(colnames(iris)))

换成管道操作,函数 colnames() 要换成 colnames<-,这其实类似于 1 + 2 换成 +(1, 2),保持函数在左边,参数值在右边的一致性。

设置页面默认显示的行数和列的宽度

# https://stackoverflow.com/questions/45509501/set-names-of-values-in-lengthmenu-page-length-menu-in-r-dt-datatable
# 相关例子见 https://github.com/rstudio/shiny-examples/tree/master/018-datatable-options
# DT 选项 https://rstudio.github.io/DT/options.html

library(shiny)
library(DT)

ui <- fluidPage(
  DT::dataTableOutput("table")
)

server <- function(input, output) {
  output$table <- DT::renderDataTable({
    DT::datatable(iris, options = list(
      language = list(url = "//cdn.datatables.net/plug-ins/1.10.11/i18n/Chinese.json"),
      pageLength = 24, # 设置页面默认显示的行数
      lengthMenu = list(
        c(24, 48, 72, 96, -1),
        c("24", "48", "72", "96", "All")
      ),
      paging = T,
      # 设置第一列和第三列的宽度 https://rstudio.github.io/DT/options.html
      autoWidth = TRUE, columnDefs = list(list(width = '400px', targets = c(1, 3)))
    ))
  })
}

shinyApp(ui, server)

按指定格式显示数据

# data <- data.frame(x = c(100.0011, 80.0011, -90.0011, -110.0011, -70))
#
# library(shiny)
# runApp(list(
#   ui = fluidPage(dataTableOutput("num")),
#   server = function(input, output) {
#     output$num = renderDataTable(format(round(data, 3), nsmall = 3))
#   }
# ))

library(DT)

dat <- data.frame(x = c(100.0011, 80.0011, -90.0011, -110.0067, -70))

rowCallback <- c(
  "function(row, data, index){",
  "  var N = data.length;",
  "  for(var j=1; j<data.length; j++){",
  "    $('td:eq('+j+')',row)",
  "      .html(parseFloat(data[j]).toFixed(3));", # 四舍五入保留 3 位小数
  "  }",
  "}"
)

# https://github.com/rstudio/shiny/issues/2277
datatable(dat,
  options = list(
    rowCallback = JS(rowCallback)
  )
)