我正在寻找一种方法来制作一个汇总表，将 R 中一个因子的每个级别的值与该因子的所有其他级别进行比较。鸢尾花数据集的一个例子——我想将 setosa 与所有其他人（即 versicolor 和 virginica）进行比较，然后将 versicolor 与其他人（setosa 和 virginica）进行比较，最后将 virignica 与其他人（versicolor 和 setosa）进行比较。在我的实际数据集中，我有很多组，所以我不想对每个级别进行硬编码。如果可能的话，我正在寻找一个 tidyverse 解决方案。我想要的结果是一个如下所示的汇总表：
这里 - 'in group' 中的 'yes' 是该组中的物种（因此对于 setosa，它只会是 setosa），而 'no' 是不在该组中的物种（所以对于Setosa - 不，它会是杂色和 virgnicia 的结合）。
【问题讨论】：
1) 我们可以在dplyr 本身内执行此操作。按“物种”分组，summarise 我们需要的列，即“Sepal.length”，通过使用cur_group_id() 连接列的mean 和完整数据列的子集（除@987654325 外没有其他包使用@）
library(dplyr)
iris %>%
group_by(Species) %>%
summarise(InGroup = c('Yes', 'No'), MeanSepalLength = c(mean(Sepal.Length),
mean(.$Sepal.Length[as.numeric(.$Species) != cur_group_id()])),
.groups = 'drop')
# A tibble: 6 x 3
# Species InGroup MeanSepalLength
# <fct> <chr> <dbl>
#1 setosa Yes 5.01
#2 setosa No 6.26
#3 versicolor Yes 5.94
#4 versicolor No 5.80
#5 virginica Yes 6.59
#6 virginica No 5.47
2)如果我们想在多列中执行此操作，请使用across
iris %>%
group_by(Species) %>%
summarise(InGroup = c('Yes', 'No'),
across(where(is.numeric), ~ c(mean(.),
mean(iris[[cur_column()]][
as.numeric(iris$Species) != cur_group_id()])), .names = 'Mean{.col}'),
.groups = 'drop')
-输出
# A tibble: 6 x 6
# Species InGroup MeanSepal.Length MeanSepal.Width MeanPetal.Length MeanPetal.Width
# <fct> <chr> <dbl> <dbl> <dbl> <dbl>
#1 setosa Yes 5.01 3.43 1.46 0.246
#2 setosa No 6.26 2.87 4.91 1.68
#3 versicolor Yes 5.94 2.77 4.26 1.33
#4 versicolor No 5.80 3.20 3.51 1.14
#5 virginica Yes 6.59 2.97 5.55 2.03
#6 virginica No 5.47 3.10 2.86 0.786
3)如果我们需要一个函数，也可以创建它
f1 <- function(dat, grp) {
grp_str <- rlang::as_string(rlang::ensym(grp))
dat %>%
group_by({{grp}}) %>%
summarise(InGroup = c('Yes', 'No'),
across(where(is.numeric), ~ c(mean(.),
mean(dat[[cur_column()]][
as.numeric(dat[[grp_str]]) != cur_group_id()])),
.names = 'Mean{.col}'), .groups = 'drop')
}
-测试
f1(iris, Species)
# A tibble: 6 x 6
# Species InGroup MeanSepal.Length MeanSepal.Width MeanPetal.Length MeanPetal.Width
# <fct> <chr> <dbl> <dbl> <dbl> <dbl>
#1 setosa Yes 5.01 3.43 1.46 0.246
#2 setosa No 6.26 2.87 4.91 1.68
#3 versicolor Yes 5.94 2.77 4.26 1.33
#4 versicolor No 5.80 3.20 3.51 1.14
#5 virginica Yes 6.59 2.97 5.55 2.03
#6 virginica No 5.47 3.10 2.86 0.786
或diamonds
f1(diamonds, cut)
# A tibble: 10 x 9
# cut InGroup Meancarat Meandepth Meantable Meanprice Meanx Meany Meanz
# <ord> <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
# 1 Fair Yes 1.05 64.0 59.1 4359. 6.25 6.18 3.98
# 2 Fair No 0.790 61.7 57.4 3920. 5.72 5.72 3.53
# 3 Good Yes 0.849 62.4 58.7 3929. 5.84 5.85 3.64
# 4 Good No 0.793 61.7 57.3 3933. 5.72 5.72 3.53
# 5 Very Good Yes 0.806 61.8 58.0 3982. 5.74 5.77 3.56
# 6 Very Good No 0.796 61.7 57.3 3919. 5.73 5.72 3.53
# 7 Premium Yes 0.892 61.3 58.7 4584. 5.97 5.94 3.65
# 8 Premium No 0.766 61.9 57.0 3709. 5.65 5.66 3.50
# 9 Ideal Yes 0.703 61.7 56.0 3458. 5.51 5.52 3.40
#10 Ideal No 0.861 61.8 58.5 4249. 5.88 5.88 3.63
4) 或者另一种选择是将sum 的差异除以行数的差异
iris %>%
group_by(Species) %>%
summarise(InGroup = c('Yes', 'No'), across(where(is.numeric),
~ c(mean(.), (sum(iris[[cur_column()]]) -
sum(.))/(nrow(iris) - n())), .names = 'Mean{.col}'), .groups = 'drop')
【讨论】：
在下面的代码中，我们使用map分别对Species的每一层进行操作。对于每次迭代，我们创建一个分组列 in.group 标记一行是否是给定物种的成员。然后我们按组返回所有数字列的平均值：
library(tidyverse)
unique(as.character(iris$Species)) %>%
set_names() %>%
map_df(
~iris %>%
group_by(in.group = Species==.x) %>%
summarise(across(where(is.numeric), mean, .names="mean_{col}")),
.id="Species"
)
#> # A tibble: 6 x 6
#> Species in.group mean_Sepal.Length mean_Sepal.Width mean_Petal.Length
#> <chr> <lgl> <dbl> <dbl> <dbl>
#> 1 setosa FALSE 6.26 2.87 4.91
#> 2 setosa TRUE 5.01 3.43 1.46
#> 3 versicolor FALSE 5.80 3.20 3.51
#> 4 versicolor TRUE 5.94 2.77 4.26
#> 5 virginica FALSE 5.47 3.10 2.86
#> 6 virginica TRUE 6.59 2.97 5.55
#> # … with 1 more variable: mean_Petal.Width <dbl>
您还可以将以下内容添加到链上，以使输出更经济：
mutate(Species = case_when(in.group ~ Species,
!in.group ~ paste("not", Species))) %>%
select(-in.group)
这给出了：
Species mean_Sepal.Length mean_Sepal.Width mean_Petal.Length mean_Petal.Width
1 not setosa 6.26 2.87 4.91 1.68
2 setosa 5.01 3.43 1.46 0.246
3 not versicolor 5.80 3.20 3.51 1.14
4 versicolor 5.94 2.77 4.26 1.33
5 not virginica 5.47 3.10 2.86 0.786
6 virginica 6.59 2.97 5.55 2.03
你可以把它打包成一个函数：
compare.groups = function(data, group) {
group = ensym(group)
# Get levels of group
x = data %>%
distinct(!!group) %>%
pull(!!group) %>%
as.character %>%
set_names()
# Map over each level
x %>%
map_df(
~ data %>%
group_by(in.group = !!group == .x) %>%
summarise(across(where(is.numeric), mean, .names="mean_{col}")),
.id=as_label(enquo(group))
) %>%
mutate(!!group := case_when(in.group ~ !!group,
!in.group ~ paste("not", !!group))) %>%
select(-in.group)
}
# Run the function on a couple of data frames
compare.groups(iris, Species)
compare.groups(diamonds, cut)
您还可以使用该函数获取数据框中所有分类列的结果：
diamonds %>%
select(where(~!is.numeric(.))) %>%
names() %>%
set_names() %>%
map_df(
~compare.groups(diamonds, !!.x) %>%
rename(category = .x),
.id="variable"
)
variable category mean_carat mean_depth mean_table mean_price mean_x mean_y mean_z 1 cut not Ideal 0.861 61.8 58.5 4249. 5.88 5.88 3.63 2 cut Ideal 0.703 61.7 56.0 3458. 5.51 5.52 3.40 3 cut not Premium 0.766 61.9 57.0 3709. 5.65 5.66 3.50 4 cut Premium 0.892 61.3 58.7 4584. 5.97 5.94 3.65 5 cut not Good 0.793 61.7 57.3 3933. 5.72 5.72 3.53 6 cut Good 0.849 62.4 58.7 3929. 5.84 5.85 3.64 7 cut not Very Good 0.796 61.7 57.3 3919. 5.73 5.72 3.53 8 cut Very Good 0.806 61.8 58.0 3982. 5.74 5.77 3.56 9 cut not Fair 0.790 61.7 57.4 3920. 5.72 5.72 3.53 10 cut Fair 1.05 64.0 59.1 4359. 6.25 6.18 3.98 11 color not E 0.829 61.8 57.4 4123. 5.80 5.80 3.58 12 color E 0.658 61.7 57.5 3077. 5.41 5.42 3.34 13 color not I 0.772 61.7 57.4 3803. 5.68 5.68 3.50 14 color I 1.03 61.8 57.6 5092. 6.22 6.22 3.85 15 color not J 0.778 61.7 57.4 3856. 5.69 5.69 3.51 16 color J 1.16 61.9 57.8 5324. 6.52 6.52 4.03 17 color not H 0.777 61.7 57.4 3832. 5.69 5.69 3.51 18 color H 0.912 61.8 57.5 4487. 5.98 5.98 3.70 19 color not F 0.811 61.8 57.5 3977. 5.76 5.76 3.55 20 color F 0.737 61.7 57.4 3725. 5.61 5.62 3.46 # … with 20 more rows
【讨论】：