5.4 分组聚合

methods("aggregate")
## [1] aggregate.data.frame aggregate.default*   aggregate.formula*  
## [4] aggregate.ts        
## see '?methods' for accessing help and source code
args("aggregate.data.frame")
## function (x, by, FUN, ..., simplify = TRUE, drop = TRUE) 
## NULL
args("aggregate.ts")
## function (x, nfrequency = 1, FUN = sum, ndeltat = 1, ts.eps = getOption("ts.eps"), 
##     ...) 
## NULL
# getAnywhere(aggregate.formula)

按 Species 分组,对 Sepal.Length 中大于平均值的数取平均

aggregate(Sepal.Length ~ Species, iris, function(x) mean(x[x > mean(x)]))
##      Species Sepal.Length
## 1     setosa     5.313636
## 2 versicolor     6.375000
## 3  virginica     7.159091
library(data.table)

dt <- data.table(
  x = rep(1:3, each = 3), y = rep(1:3, 3),
  z = rep(c("A", "B", "C"), 3), w = rep(c("a", "b", "a"), each = 3)
)

dt[, .(x_sum = sum(x), y_sum = sum(y)), by = .(z, w)]
##    z w x_sum y_sum
## 1: A a     4     2
## 2: B a     4     4
## 3: C a     4     6
## 4: A b     2     1
## 5: B b     2     2
## 6: C b     2     3
dt[, .(x_sum = sum(x), y_sum = sum(y)), by = mget(c("z", "w"))]
##    z w x_sum y_sum
## 1: A a     4     2
## 2: B a     4     4
## 3: C a     4     6
## 4: A b     2     1
## 5: B b     2     2
## 6: C b     2     3

shiny 前端传递字符串向量,借助 mget() 函数根据选择的变量分组统计计算,只有一个变量可以使用 get() 传递变量给 data.table

library(shiny)

ui <- fluidPage(
  fluidRow(
    column(
      6,
      selectInput("input_vars",
        label = "变量", # 给筛选框取名
        choices = c(z = "z", w = "w"), # 待选的值
        selected = "z", # 指定默认值
        multiple = TRUE # 允许多选
      ),
      DT::dataTableOutput("output_table")
    )
  )
)

library(data.table)
library(magrittr)

dt <- data.table(
  x = rep(1:3, each = 3), y = rep(1:3, 3),
  z = rep(c("A", "B", "C"), 3), w = rep(c("a", "b", "a"), each = 3)
)

server <- function(input, output, session) {
  output$output_table <- DT::renderDataTable(
    {
      dt[, .(x_sum = sum(x), y_sum = sum(y)), by = mget(input$input_vars)] %>%
        DT::datatable()
    },
    server = FALSE
  )
}

# 执行
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)
# 修改自 Code: https://gist.github.com/jthomasmock/f085dce3e70e42ca49b052bbe25de49f
library(magrittr)
library(reactable)
library(htmltools)

# barchart function from: https://glin.github.io/reactable/articles/building-twitter-followers.html
bar_chart <- function(label, width = "100%", height = "14px", fill = "#00bfc4", background = NULL) {
  bar <- div(style = list(background = fill, width = width, height = height))
  chart <- div(style = list(flexGrow = 1, marginLeft = "6px", background = background), bar)
  div(style = list(display = "flex", alignItems = "center"), label, chart)
}

data <- mtcars %>% 
  subset(select = c("cyl", "mpg")) %>%
  subset(subset = sample(x = c(TRUE, FALSE), size = 6, replace = T))


reactable(
  data,
  defaultPageSize = 20,
  columns = list(
    cyl = colDef(align = "center"),
    mpg = colDef(
      name = "mpg",
      defaultSortOrder = "desc",
      minWidth = 250,
      cell = function(value, index) {
        width <- paste0(value * 100 / max(mtcars$mpg), "%")
        value <- format(value, width = 9, justify = "right", nsmall = 1)
        
        # output the value of another column 
        # that aligns with current value
        cyl_val <- data$cyl[index]

        # Color based on the row's cyl value
        color_fill <- if (cyl_val == 4) {
          "#3686d3" # blue
        } else if (cyl_val == 6) {
          "#88398a" # purple
        } else {
          "#fcab27" # orange
        }
        bar_chart(value, width = width, fill = color_fill, background = "#e1e1e1")
      },
      align = "left",
      style = list(fontFamily = "monospace", whiteSpace = "pre")
    )
  )
)