我想在R中创建一个类似于dplyr的{{1}}函数的函数，当与group_by结合使用时，可以为组的数据集提供摘要统计信息成员资格不是互相排斥的。即，观察可以属于多个组。考虑它的一种方法可能是考虑标签;观察可能属于一个或多个可能重叠的标签。
例如，采用R的summarise数据集（https://stat.ethz.ch/R-manual/R-devel/library/datasets/html/esoph.html）记录食管癌的病例对照研究。假设我对癌症病例总数和每个“标签”的数量和比例感兴趣，标签是：65岁以上; 80+克/天的酒精; 20克/天烟草;以及满足前3个标准的“高风险”组。
让我们将数据集转换为长格式（每行一个参与者），然后将这些标记（逻辑列）添加到数据集中：
esoph我通常的做法是创建一个数据集，其中每个观察对于它所属的每个标记都是重复的，然后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))
更好的是，它可以采用“因素”类型和“逻辑”类型的变量，以便它可以总结，例如，每个年龄组，65岁以上的人和每个人：
> 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
使用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)流程。
答案 0 :(得分：3)
这是@ 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
在eval内使用DT[...]的技巧解释为in the data.table FAQ。
答案 1 :(得分：1)
不是一个完全正常的答案 ，更多“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提供第三个选项。
答案 2 :(得分：1)
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
当然，这可以更加可定制，这留给了读者。
答案 3 :(得分：1)
在没有任何tidyverse内部知识的情况下，我避免尝试创建group_by() - 类型的函数，其输出应该传递给summarise()，而是将一个函数组合在一起（类似于其他答案，但我希望，更加用户友好和普遍性。）
由于group_by() %>% summarise()返回每个嵌套的分组变量组合的联合摘要信息，因此我选择名称summarise_marginal()，因为它将独立返回每个分组变量的边际摘要信息。
grouped_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组，我们仍然可以获得一个有用的名称。
grouped_df个对象 summarise_marginal0()可以扩展为使用grouped_df返回的group_by()个对象：
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，因此仅此功能是合适的。
这是一个有用的解决方案，但鉴于group_by()的使用超出summarise()，例如nest()或do()，我认为{{1}的想法（或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答案 4 :(得分：0)
这是（大部分）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在dplyr的每一行上运行tags1摘要的函数：
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)
tag 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
我希望创建一种更简单的方法来生成过滤表达式，但对于如何创建复杂表达式以在dplyr函数的标准评估版本中使用，我仍然有点神秘。
例如，我对如何使用类似下面的方法感兴趣。 filt函数用于创建过滤表达式，但返回的表达式需要不加引号，并且前面有一个~，filter_可以正确解释它。或者可能需要interp进行一些回转。无论如何，我对如何使这项工作感兴趣（或建议更好的方法），以及如何通过组合创建具有多个条件的过滤器（如在高风险＆＃39;过滤器中）个别过滤器：
# 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))