我想在R中创建一个类似于 dplyr 的 group_by 函数的函数，当与 summarise 结合使用时，可以为组成员资格不相互排斥的数据集提供汇总统计信息 . 即，观察可以属于多个组 . 考虑它的一种方法可能是考虑标签;观察可能属于可能重叠的一个或多个标签 .

例如，采用R的 esoph 数据集（https://stat.ethz.ch/R-manual/R-devel/library/datasets/html/esoph.html）记录食管癌的病例对照研究 . 假设我将数据集转换为长格式（每行一个参与者），然后将这些标记（逻辑列）添加到数据集中：http：// 117196977_ tag ', where the tags are: 65+ years old; 80+ gm/day alcohol; 20+ gm/day tobacco; and a '

library('dplyr')
data(esoph)
esophlong = bind_rows(esoph %>% .[rep(seq_len(nrow(.)), .$ncases), 1:3] %>% mutate(case=1),
                      esoph %>% .[rep(seq_len(nrow(.)), .$ncontrols), 1:3] %>% mutate(case=0)
            ) %>% 
            mutate(highage=(agegp %in% c('65-74','75+')),
                   highalc=(alcgp %in% c('80-119','120+')),
                   hightob=(tobgp %in% c('20-29','30+')),
                   highrisk=(highage & highalc & hightob)
            )

我通常的方法是创建一个数据集，其中每个观察对于它所属的每个标记都是重复的，然后 summarise 这个数据集：

esophdup = bind_rows(esophlong %>% filter(highage) %>% mutate(tag='age>=65'),
                     esophlong %>% filter(highalc) %>% mutate(tag='alc>=80'),
                     esophlong %>% filter(hightob) %>% mutate(tag='tob>=20'),
                     esophlong %>% filter(highrisk) %>% mutate(tag='high risk'),
                     esophlong %>% filter() %>% mutate(tag='all')
           ) %>%
           mutate(tag=factor(tag, levels = unique(.$tag)))

summary = esophdup %>%
          group_by(tag) %>%
          summarise(n=n(), ncases=sum(case), case.rate=mean(case))

对于大型数据集或大量标签，这种方法效率低下，而且我经常会耗尽内存来存储它 .

另一种方法是单独使用 summarise 每个标记，然后将这些摘要数据集绑定，如下所示：

summary.age = esophlong %>%
              filter(highage) %>%
              summarise(n=n(), ncases=sum(case), case.rate=mean(case)) %>%
              mutate(tag='age>=65')

summary.alc = esophlong %>%
              filter(highalc) %>%
              summarise(n=n(), ncases=sum(case), case.rate=mean(case)) %>%
              mutate(tag='alc>=80')

summary.tob = esophlong %>%
              filter(hightob) %>%
              summarise(n=n(), ncases=sum(case), case.rate=mean(case)) %>%
              mutate(tag='tob>=20')

summary.highrisk = esophlong %>%
              filter(highrisk) %>%
              summarise(n=n(), ncases=sum(case), case.rate=mean(case)) %>%
              mutate(tag='high risk')

summary.all = esophlong %>%
              summarise(n=n(), ncases=sum(case), case.rate=mean(case)) %>%
              mutate(tag='all')

summary=bind_rows(summary.age,summary.alc,summary.tob,summary.highrisk,summary.all)

当我有大量标签或者我想在整个项目中经常重复使用标签以进行不同的汇总测量时，这种方法既费时又乏味 .

我想到的函数，例如 group_by_tags(data, key, ...) ，它包含一个指定分组列名称的参数，应该是这样的：

summary = esophlong %>% 
          group_by_tags(key='tags',
                        'age>=65'=highage,
                        'alc>=80'=highalc,
                        'tob>=20'=hightob,
                        'high risk'=highrisk,
                        'all ages'=1
          ) %>%
          summarise(n=n(), ncases=sum(case), case.rate=mean(case))

使用如下所示的摘要数据集：

> summary
       tags     n ncases case.rate
1   age>=65   273     68 0.2490842
2   alc>=80   301     96 0.3189369
3   tob>=20   278     64 0.2302158
4 high risk    11      5 0.4545455
5       all  1175    200 0.1702128

更好的是，它可以采用类型“因素”和“逻辑”类型的变量，以便它可以总结，例如，每个年龄组，65岁的人和每个人：

summaryage = esophlong %>% 
          group_by_tags(key='Age.group',
                        agegp,
                        '65+'=(agegp %in% c('65-74','75+')),
                        'all'=1                 
          ) %>%
          summarise(n=n(), ncases=sum(case), case.rate=mean(case))

>summaryage
  Age.group     n ncases case.rate
1     25-34   117      1 0.0085470
2     35-44   208      9 0.0432692
3     45-54   259     46 0.1776062
4     55-64   318     76 0.2389937
5     65-74   216     55 0.2546296
6       75+    57     13 0.2280702
7       65+   273     68 0.2490842
8       all  1175    200 0.1702128

也许用 ... 是不可能的，相反，您可能需要传递标签的列名称的向量/列表 .

有任何想法吗？

编辑：要清楚，解决方案应该将标记/组定义和所需的摘要统计信息作为参数，而不是内置到函数本身 . 作为两步 data %>% group_by_tags(tags) %>% summarise_tags(stats) 或一步 data %>% summary_tags(tags,stats) 过程 .

5 回答

这是@ eddi答案的变体 . 我将 highage 等的定义作为函数工作的一部分：

library(data.table)
custom_summary = function(DT, tags, stats){
    setDT(DT)
    rows = stack(lapply(tags[-1], function(x) DT[eval(x), which=TRUE]))
    DT[rows$values, eval(stats), by=.(tag = rows$ind)]
}

以及一些示例用法：

data(esoph)
library(dplyr)
esophlong = bind_rows(esoph %>% .[rep(seq_len(nrow(.)), .$ncases), 1:3] %>% mutate(case=1),
                      esoph %>% .[rep(seq_len(nrow(.)), .$ncontrols), 1:3] %>% mutate(case=0)
            )

custom_summary(
    DT = esophlong, 
    tags = quote(list(
        'age>=65'   = agegp %in% c('65-74','75+'),
        'alc>=80'   = alcgp %in% c('80-119','120+'),
        'tob>=20'   = tobgp %in% c('20-29','30+'),
        'high risk' = eval(substitute(`age>=65` & `alc>=80` & `tob>=20`, as.list(tags))),
        'all ages'  = TRUE
    )),
    stats = quote(list(
        n           = .N, 
        n_cases     = sum(case), 
        case.rate   = mean(case)
    ))
)

         tag    n n_cases case.rate
1:   age>=65  273      68 0.2490842
2:   alc>=80  301      96 0.3189369
3:   tob>=20  278      64 0.2302158
4: high risk   11       5 0.4545455
5:  all ages 1175     200 0.1702128

在 DT[...] 中使用 eval 的技术解释in the data.table FAQ .

回复于 2024-05-19T17:55:20+08:00

Not a completely functional answer ，更多"WIP"或开始讨论 . 这应该最终进入一个回购和一个额外的包或dplyr PR .

一种方法是从“正常”分组变量模拟属性的结构：

library(dplyr)
esoph %>% group_by(agegp, alcgp) %>% attributes %>% str
# List of 9
#  $ names             : chr [1:5] "agegp" "alcgp" "tobgp" "ncases" ...
#  $ row.names         : int [1:88] 1 2 3 4 5 6 7 8 9 10 ...
#  $ class             : chr [1:4] "grouped_df" "tbl_df" "tbl" "data.frame"
#  $ vars              :List of 2
#   ..$ : symbol agegp
#   ..$ : symbol alcgp
#  $ drop              : logi TRUE
#  $ indices           :List of 24
#   ..$ : int [1:4] 0 1 2 3
#   ..$ : int [1:4] 4 5 6 7
#   ..$ : int [1:3] 8 9 10
#   ...........
#  $ group_sizes       : int [1:24] 4 4 3 4 4 4 4 3 4 4 ...
#  $ biggest_group_size: int 4
#  $ labels            :'data.frame':   24 obs. of  2 variables:
#   ..$ agegp: Ord.factor w/ 6 levels "25-34"<"35-44"<..: 1 1 1 1 2 2 2 2 3 3 ...
#   ..$ alcgp: Ord.factor w/ 4 levels "0-39g/day"<"40-79"<..: 1 2 3 4 1 2 3 4 1 2 ...
#   ..- attr(*, "vars")=List of 2
#   .. ..$ : symbol agegp
#   .. ..$ : symbol alcgp
#   ..- attr(*, "drop")= logi TRUE

我们可以人工重现这个，看它是否/如何工作：

esoph2 <- esoph
syms <- list(as.symbol("agegp65"), as.symbol("alcgp80"))
attr(esoph2, "vars") <- syms
attr(esoph2, "drop") <- TRUE
# 'agegp' and 'aclgp' are ordered factors, for simplicity here just using ints
# `group_by` indices are 0-based
indices <- list(
  which(as.integer(esoph2$agegp) >= 5) - 1,
  which(as.integer(esoph2$alcgp) >= 3) - 1
)
attr(esoph2, "indices") <- indices
attr(esoph2, "group_sizes") <- lengths(indices)
attr(esoph2, "biggest_group_size") <- max(lengths(indices))
df <- data.frame(agegp65 = "agegp >= 65", alcgp80 = "alcgp >= 80", stringsAsFactors = FALSE)
attr(df, "vars") <- syms
attr(esoph2, "labels") <- df
class(esoph2) <- c("grouped_df", "tbl_df", "tbl", "data.frame")

哪个“看起来”像普通的分组data.frame：

str(esoph2)
# Classes 'grouped_df', 'tbl_df', 'tbl' and 'data.frame':   88 obs. of  5 variables:
#  $ agegp    : Ord.factor w/ 6 levels "25-34"<"35-44"<..: 1 1 1 1 1 1 1 1 1 1 ...
#  $ alcgp    : Ord.factor w/ 4 levels "0-39g/day"<"40-79"<..: 1 1 1 1 2 2 2 2 3 3 ...
#  $ tobgp    : Ord.factor w/ 4 levels "0-9g/day"<"10-19"<..: 1 2 3 4 1 2 3 4 1 2 ...
#  $ ncases   : num  0 0 0 0 0 0 0 0 0 0 ...
#  $ ncontrols: num  40 10 6 5 27 7 4 7 2 1 ...
#  - attr(*, "vars")=List of 2
#   ..$ : symbol agegp65
#   ..$ : symbol alcgp80
#  - attr(*, "drop")= logi TRUE
#  - attr(*, "indices")=List of 2
#   ..$ : num  62 63 64 65 66 67 68 69 70 71 ...
#   ..$ : num  8 9 10 11 12 13 14 23 24 25 ...
#  - attr(*, "group_sizes")= int  26 42
#  - attr(*, "biggest_group_size")= int 42
#  - attr(*, "labels")='data.frame':    1 obs. of  2 variables:
#   ..$ agegp65: chr "agegp >= 65"
#   ..$ alcgp80: chr "alcgp >= 80"
#   ..- attr(*, "vars")=List of 2
#   .. ..$ : symbol agegp65
#   .. ..$ : symbol alcgp80
esoph2
# Source: local data frame [88 x 5]
# Groups: agegp65, alcgp80 [2]
#    agegp     alcgp    tobgp ncases ncontrols
#    <ord>     <ord>    <ord>  <dbl>     <dbl>
# 1  25-34 0-39g/day 0-9g/day      0        40
# 2  25-34 0-39g/day    10-19      0        10
# 3  25-34 0-39g/day    20-29      0         6
# 4  25-34 0-39g/day      30+      0         5
# 5  25-34     40-79 0-9g/day      0        27
# 6  25-34     40-79    10-19      0         7
# 7  25-34     40-79    20-29      0         4
# 8  25-34     40-79      30+      0         7
# 9  25-34    80-119 0-9g/day      0         2
# 10 25-34    80-119    10-19      0         1
# # ... with 78 more rows

不幸：

esoph2 %>% summarize(n = n())
# Error: corrupt 'grouped_df', contains 88 rows, and 68 rows in groups

我的评论 summarize 假设全面报道;你必须修改dplyr_summarise_impl（在C中），可能是summarise_grouped和summarise_not_grouped的第三个选项 .

回复于 2024-05-19T17:55:20+08:00

library(data.table)
setDT(esophlong)

special.summary = function(dt, vars) {
  rbindlist(lapply(seq_along(vars), function(i) {
      var = vars[[i]]
      if (is.logical(dt[, eval(var)])) {
        dt[eval(var) == TRUE, .(.N, sum(case), mean(case))][, tag := names(vars)[i]][
           , .SD, by = tag] # last step is a lazy version of setcolorder
      } else {
        dt[, .(.N, sum(case), mean(case)), by = .(tag = eval(var))]
      }
    }))
}

special.summary(esophlong, list('age>=65'=quote(highage),
                                'alc>=80'=quote(highalc),
                                'tob>=20'=quote(hightob),
                                'high risk'=quote(highrisk),
                                'all'=quote(TRUE)))

#         tag    N  V2        V3
#1:   age>=65  273  68 0.2490842
#2:   alc>=80  301  96 0.3189369
#3:   tob>=20  278  64 0.2302158
#4: high risk   11   5 0.4545455
#5:       all 1175 200 0.1702128

special.summary(esophlong, list(quote(agegp),
                                '65+'=quote(agegp %in% c('65-74','75+')),
                                'all'=quote(TRUE)))

#     tag    N  V2          V3
#1: 25-34  117   1 0.008547009
#2: 35-44  208   9 0.043269231
#3: 45-54  259  46 0.177606178
#4: 55-64  318  76 0.238993711
#5: 65-74  216  55 0.254629630
#6:   75+   57  13 0.228070175
#7:   65+  273  68 0.249084249
#8:   all 1175 200 0.170212766

当然，这可以更加可定制，这留给读者作为练习 .

回复于 2024-05-19T17:55:20+08:00

在没有任何tidyverse内部知识的情况下，我避免尝试创建 group_by() -type函数，其输出应传递给 summarise() ，而是组合一个结合两者的函数（类似于其他答案，但我希望，更加用户友好和普遍意义） .

由于 group_by() %>% summarise() 返回每个嵌套的分组变量组合的联合摘要信息，因此我选择名称 summarise_marginal() ，因为它将独立返回每个分组变量的边际摘要信息 .

不适用于groups_df对象的解决方案

首先，解决方案不适用于 grouped_df 类，但扩展如下：

summarise_marginal0 <- function(.tbl, .vars, ..., .removeF=FALSE){

  dots <- quos(...)

  .tbl %>% 
    transmute(!!! .vars) %>% 
    map_dfr(
      ~ summarise(group_by(.tbl, 'value'=., add = TRUE), !!! dots) %>%  # piping .tbl %>% group_by() %>% summarise() evaluates in the wrong order for some reason
      filter_at(vars('value'), all_vars(!(.==FALSE & .removeF))) %>%  # to remove rows where a logical group is FALSE.
      mutate_at(vars('value'), as.character)  # standardises 'value' column in case map_dfr tries to convert logical to factor
      , .id='group'
    )
}


mtcars %>% 
  summarise_marginal0(
    vars(cyl, am),
    meanmpg = mean(mpg),
    meanwt = mean(wt)
  )

#> # A tibble: 5 x 4
#>   group value  meanmpg   meanwt
#>   <chr> <chr>    <dbl>    <dbl>
#> 1   cyl     4 26.66364 2.285727
#> 2   cyl     6 19.74286 3.117143
#> 3   cyl     8 15.10000 3.999214
#> 4    am     0 17.14737 3.768895
#> 5    am     1 24.39231 2.411000

使用 vars() 捕获组（与 summarise_at() 或 mutate_at() 一样）可以巧妙地将组与摘要函数分开，并允许在运行中创建新组：

mtcars %>% 
  summarise_marginal0(
    vars(cyl, hp_lt100 = hp<100),
    meanmpg = mean(mpg),
    meanwt = mean(wt)
  )

#> # A tibble: 5 x 4
#>      group value  meanmpg   meanwt
#>      <chr> <chr>    <dbl>    <dbl>
#> 1      cyl     4 26.66364 2.285727
#> 2      cyl     6 19.74286 3.117143
#> 3      cyl     8 15.10000 3.999214
#> 4 hp_lt100 FALSE 17.45217 3.569652
#> 5 hp_lt100  TRUE 26.83333 2.316667

我们可以使用 .removeF 参数来删除 FALSE 逻辑值 . 如果您想要汇总某些行而不是它们的赞美，则很有用：

mtcars %>% 
  summarise_marginal0(
    vars(cyl==6, hp_lt100 = hp<100, hp_lt200 = hp<200),
    meanmpg = mean(mpg),
    meanwt = mean(wt),
    .removeF = TRUE
  )

#> # A tibble: 3 x 4
#>      group value  meanmpg   meanwt
#>      <chr> <chr>    <dbl>    <dbl>
#> 1 cyl == 6  TRUE 19.74286 3.117143
#> 2 hp_lt100  TRUE 26.83333 2.316667
#> 3 hp_lt200  TRUE 21.96000 2.911320

请注意，即使没有明确命名 cyl == 6 组，我们仍然会得到一个有用的名称 .

与groups_df对象一起使用的解决方案

summarise_marginal0() 可以扩展为与 group_by() 返回的 grouped_df 对象一起使用：

summarise_marginal <- function(.tbl, .vars, ...){

  dots <- quos(...)

  .tbl %>%
    nest() %>%
    mutate(
      summarised = map(data, ~summarise_marginal0(., .vars, !!! dots))
    ) %>% 
    unnest(summarised) %>%
    purrrlyr::slice_rows(group_vars(.tbl))
}


mtcars %>% 
  group_by(am) %>%
  summarise_marginal(
    vars(cyl, hp_lt100 = hp<100),
    meanmpg = mean(mpg),
    meanwt = mean(wt)
  )

#> # A tibble: 10 x 5
#> # Groups:   am [2]
#>       am    group value  meanmpg   meanwt
#>    <dbl>    <chr> <chr>    <dbl>    <dbl>
#>  1     1      cyl     4 28.07500 2.042250
#>  2     1      cyl     6 20.56667 2.755000
#>  3     1      cyl     8 15.40000 3.370000
#>  4     1 hp_lt100 FALSE 20.61429 2.756857
#>  5     1 hp_lt100  TRUE 28.80000 2.007500
#>  6     0      cyl     4 22.90000 2.935000
#>  7     0      cyl     6 19.12500 3.388750
#>  8     0      cyl     8 15.05000 4.104083
#>  9     0 hp_lt100 FALSE 16.06875 3.925250
#> 10     0 hp_lt100  TRUE 22.90000 2.935000

事实上， summarise_marginal() 将适用于分组和未分组的 data.frame s，因此仅此功能是合适的 .

这是一个有用的解决方案，但是鉴于 group_by() 的使用超出 summarise() ，例如 nest() 或 do() ，我认为 group_by_marginal() （或 group_by_tag() 或其他任何名称最好）的想法值得追求 .

一些剩余的问题：

该函数需要将整数，因子和逻辑列转换为字符，以便它们的值可以很好地放在同一个 values 列中 . 这略微违反了整洁的数据原则，但与 gather() 的行为方式没有什么不同 .
假设 group_by_marginal() 函数是可能的，它的输出不能传递给 mutate() 而不解决从每个组放置值的位置的模糊性 . 从上面的例子中，应该将 meanmpg 的哪一个值赋予 cyl==4 和 am==0 ？ 26.66364 （来自 cyl==4 ）和 17.14737 （来自 am==0 ）都是相关的 . （注意 group_by() %>% mutate() 没有歧义，因为它将返回 cyl==4 & am==0 的联合汇总函数） . group_by_marginal() %>% mutate() 有三种可能的选择：
应该禁止 .
它应该创建多个列，例如 meanmpg_cyl 和 meanmpg_am .
它应该为每个组复制行 .
速度 . 我确信我对这个概念的实现是低效的，可以改进 .

最后，要演示原始示例问题：

bind_rows(
  esoph %>% .[rep(seq_len(nrow(.)), .$ncases), 1:3] %>% mutate(case=1),
  esoph %>% .[rep(seq_len(nrow(.)), .$ncontrols), 1:3] %>% mutate(case=0)
) %>%
summarise_marginal(
  vars(highage = agegp %in% c('65-74','75+'),
       highalc = alcgp %in% c('80-119','120+'),
       hightob = tobgp %in% c('20-29','30+'),
       highrisk = highage & highalc & hightob,
       all = 1),
  n=length(agegp),
  ncases=sum(case),
  case.rate=mean(case),
  .removeF=TRUE
)

#> # A tibble: 5 x 5
#>      group value     n ncases case.rate
#>      <chr> <chr> <int>  <dbl>     <dbl>
#> 1  highage  TRUE   273     68 0.2490842
#> 2  highalc  TRUE   301     96 0.3189369
#> 3  hightob  TRUE   278     64 0.2302158
#> 4 highrisk  TRUE    11      5 0.4545455
#> 5      all     1  1175    200 0.1702128

回复于 2024-05-19T17:55:20+08:00

这是（大多数） dplyr 版本：

给定OP创建的列，标签可以是：

tags = list('age>=65'="highage",
            'alc>=80'="highalc",
            'tob>=20'="hightob",
            'high risk'="highrisk",
            'all'=TRUE)

但最好是像@Frank那样从原始数据创建过滤表达式：

tags1 = list(
  'age>=65'   = ~agegp %in% c('65-74','75+'),
  'alc>=80'   = ~alcgp %in% c('80-119','120+'),
  'tob>=20'   = ~tobgp %in% c('20-29','30+'),
  'high risk' = ~agegp %in% c('65-74','75+') & alcgp %in% c('80-119','120+') & tobgp %in% c('20-29','30+'),
  'all ages'  = TRUE
)

然后创建一个函数，使用 lapply 在 tags1 的每一行上运行 dplyr 摘要：

my_summary = function(dat, groups) {
  bind_rows(lapply(1:length(groups), function(i) {
    dat %>% filter_(groups[[i]]) %>% 
      summarise(tag=names(groups)[i],
                n=n(), 
                ncases=sum(case),
                case.rate=mean(case))
  }))
}

my_summary(esophlong, tags1)

标签n ncases case.rate
1岁> = 65 273 68 0.2490842
2 alc> = 80 301 96 0.3189369
3 tob> = 20 278 64 0.2302158
4高风险11 5 0.4545455
5全部1175 200 0.1702128

我希望创建一种更简单的方法来生成过滤表达式，但是我仍然对如何在 dplyr 函数的标准评估版本中创建复杂表达式感到有些困惑 .

例如，我对如何使用类似下面的方法感兴趣 . filt 函数用于创建过滤表达式，但返回的表达式需要不加引号，并且前面有一个 ~ ，以便 filter_ 正确解释它 . 或者可能有 interp 对于如何使这项工作感兴趣（或建议更好的方法）以及如何通过组合各个过滤器来创建具有多个条件的过滤器（如在'high risk'过滤器中）：

# Create a filtering expression
filt = function(var, cutoff) {
  paste("as.numeric(gsub('([0-9]{1,3})[-+].*','\\1',", var, ")) >= ", cutoff)
}

# Run the summary function with three different filters plus "all"
my_summary(esophlong, c(mapply(filt, c("agegp","alcgp","tobgp"), c(65,80,20)), 'all'=TRUE))

回复于 2024-05-19T17:55:20+08:00

当组不相互驱散时，功能类似于group_by

5 回答

不适用于groups_df对象的解决方案

与groups_df对象一起使用的解决方案

相关问题