多列的“就地”组加权平均值答案

【问题标题】：Weighted means by group 'in place' for multiple columns多列的“就地”组加权平均值
【发布时间】：2021-09-21 13:17:07
【问题描述】：

我想为几列中的每一列计算分组加权平均值，但要“就地”执行此操作，我的意思是最终得到与我开始时相同的行数，而不是总结。即，如果有两行属于同一组，则它们各自具有相同的加权平均值，以重复的形式呈现，而不是将它们折叠成一行来代表它们。

我有这个版本可以在基础 R 中运行，但是对于我的实际大型数据集来说非常慢（并且在某些大小下似乎会崩溃而没有产生结果，我认为是由于内存不足）：

# Some dummy data

test_w <- c(0.5, 1, 1.5, 0.5, 1, 1.5)
test_g <- list(g1 = c("Yes", "Yes", "Yes", "No", "No", "No"),
               g2 = c("Yes", "Yes", "No",  "No", "No", "Yes"))
test_x <- matrix(c(1,  2, 3, 4, 5, 6,
                   10, 9, 8, 7, 6, 5),
                 nrow = 6,
                 dimnames = list(rows = c(),
                                 cols = c("x1", "x2")))

# Gives desired answers:
temp_means_by_groups_1 <- apply(
  test_x, 2,
  FUN = function(x) return (
    ave(test_w * x, test_g, FUN = sum) /
      ave(test_w, test_g, FUN = sum)))

我的实际数据集有大约 40 个“x”列和大约 10,000 行。

我从这个 SO 答案中看到 weighted.mean() 不能很好地与 ave() 配合使用：https://stackoverflow.com/a/38509589/4957167

所以我尝试使用 dplyr / tidyverse 做类似的事情：

# A data frame version of the dummy data

test_data <- data.frame(x1 = c(1,  2, 3, 4, 5, 6),
                        x2 = c(10, 9, 8, 7, 6, 5),
                        g1 = c("Yes", "Yes", "Yes", "No", "No", "No"),
                        g2 = c("Yes", "Yes", "No",  "No", "No", "Yes"),
                        w  = c(0.5, 1, 1.5, 0.5, 1, 1.5))

# Doesn't run
temp_means_by_groups_2 <- test_data %>%
  group_by(across(all_of(c("g1", "g2")))) %>%
  mutate(across(all_of(c("x1", "x2")), weighted.mean(w = w))) %>%
  ungroup()

或者滚动我自己的函数：

weighted_means <- function(x) {
  sum(test_w * x) / sum(test_w)
}

w <- test_data$w

# Runs but gives wrong answers (not weighting the means)
temp_means_by_groups_3 <- test_data %>%
  group_by(across(all_of(c("g1", "g2")))) %>%
  mutate(across(all_of(c("x1", "x2")), weighted_means)) %>%
  ungroup()

我的理想答案是在基本 R 中运行的快速解决方案，以最大限度地减少依赖关系。实际上，速度并不是最重要的——如果内存使用率保持足够低以至于不会崩溃，那么运行速度有点慢是可以容忍的。

我的第二个最爱是 tidyverse，因为我对它有点熟悉，并且在我的代码的其他地方使用它。通过搜索似乎相对接近我的目标的答案，我发现 data.table 经常被提及；我从来没有使用过它，所以我不想进入它，但我愿意说服。

我继承的代码恰好将所有内容存储为单独的对象：有一个（数字）权重向量，一个包含作为单独因子对象的每个分组变量的列表，以及一个包含每个 x 变量作为柱子。但我很乐意将它们组合到一个数据框中，或者将它们作为单独的对象传递给执行此操作的代码，或者任何最方便的方法。

在返回的对象中，无论它是什么，我都希望每个“x”变量的列与其输入的名称相同。

【问题讨论】：

标签： r dplyr

【解决方案1】：

对您的代码稍作调整即可。它会产生您想要的结果吗？

library(dplyr, warn.conflicts = FALSE)

test_data <- data.frame(x1 = c(1,  2, 3, 4, 5, 6),
                        x2 = c(10, 9, 8, 7, 6, 5),
                        g1 = c("Yes", "Yes", "Yes", "No", "No", "No"),
                        g2 = c("Yes", "Yes", "No",  "No", "No", "Yes"),
                        w  = c(0.5, 1, 1.5, 0.5, 1, 1.5))

# Now runs
temp_means_by_groups_2 <- test_data %>%
  group_by(across(all_of(c("g1", "g2")))) %>%
  mutate(across(all_of(c("x1", "x2")), ~ weighted.mean(., w = w))) %>%
  ungroup()

temp_means_by_groups_2
#> # A tibble: 6 x 5
#>      x1    x2 g1    g2        w
#>   <dbl> <dbl> <chr> <chr> <dbl>
#> 1  1.67  9.33 Yes   Yes     0.5
#> 2  1.67  9.33 Yes   Yes     1  
#> 3  3     8    Yes   No      1.5
#> 4  4.67  6.33 No    No      0.5
#> 5  4.67  6.33 No    No      1  
#> 6  6     5    No    Yes     1.5

^{由reprex package (v2.0.0) 于 2021-07-12 创建}

这是dtplyr 版本：

library(dplyr, warn.conflicts = FALSE)
library(dtplyr)
library(data.table)
#> 
#> Attaching package: 'data.table'
#> The following objects are masked from 'package:dplyr':
#> 
#>     between, first, last

test_data <- data.frame(x1 = c(1,  2, 3, 4, 5, 6),
                        x2 = c(10, 9, 8, 7, 6, 5),
                        g1 = c("Yes", "Yes", "Yes", "No", "No", "No"),
                        g2 = c("Yes", "Yes", "No",  "No", "No", "Yes"),
                        w  = c(0.5, 1, 1.5, 0.5, 1, 1.5)) %>%
  as.data.table() %>%
  lazy_dt(immutable = FALSE)

# Now runs
temp_means_by_groups_2 <- test_data %>%
  group_by(across(all_of(c("g1", "g2")))) %>%
  mutate(across(all_of(c("x1", "x2")), ~ weighted.mean(., w = w))) %>%
  ungroup()

temp_means_by_groups_2
#> Source: local data table [6 x 5]
#> Call:   `_DT1`[, `:=`(x1 = weighted.mean(x1, w = w), x2 = weighted.mean(x2, 
#>     w = w)), by = .(g1, g2)]
#> 
#>      x1    x2 g1    g2        w
#>   <dbl> <dbl> <chr> <chr> <dbl>
#> 1  1.67  9.33 Yes   Yes     0.5
#> 2  1.67  9.33 Yes   Yes     1  
#> 3  3     8    Yes   No      1.5
#> 4  4.67  6.33 No    No      0.5
#> 5  4.67  6.33 No    No      1  
#> 6  6     5    No    Yes     1.5
#> 
#> # Use as.data.table()/as.data.frame()/as_tibble() to access results

^{由reprex package (v2.0.0) 于 2021-07-13 创建}

【讨论】：

谢谢。是的，这似乎产生了正确的结果。即使使用我的真实数据集，它也运行良好且快速。
谢谢。如果满足您的需求，您可能希望接受一个答案。进入data.table 的简单途径可能是通过dtplyr（您可以在不学习新语法的情况下进行测试，至少最初是这样）。尽管我怀疑这项任务没有太大的好处（无论哪种方式，您都在进行相同数量的计算）。我在答案中添加了插图。
由于我正在处理继承的代码库，我的理想答案仍然是内存使用率较低（理想情况下更快一点）的基本 R 版本，所以我将把它打开一会儿看看是否有人可以推荐一个。但想承认这个 dplyr 解决方案确实可以满足我的需要，并且可以快速/高效地完成。

【解决方案2】：

data.table 对于较大的数据集通常更快，您可以尝试一下。

library(data.table)

cols <- c('x1', 'x2')
setDT(test_data)
test_data[, (cols) := lapply(.SD, weighted.mean, w = w),.(g1,g2), .SDcols = cols]

#         x1       x2  g1  g2   w
#1: 1.666667 9.333333 Yes Yes 0.5
#2: 1.666667 9.333333 Yes Yes 1.0
#3: 3.000000 8.000000 Yes  No 1.5
#4: 4.666667 6.333333  No  No 0.5
#5: 4.666667 6.333333  No  No 1.0
#6: 6.000000 5.000000  No Yes 1.5

在基础 R 中，您可以使用 split 和 lapply -

do.call(rbind, lapply(split(test_data, test_data[c('g1', 'g2')]), function(x) {
  x[1:2] <- lapply(x[1:2], weighted.mean, w = x$w)
  x
})) -> test_data

或者by-

do.call(rbind, by(test_data, test_data[c('g1', 'g2')], function(x) {
  x[1:2] <- lapply(x[1:2], weighted.mean, w = x$w)
  x
})) -> test_data

【讨论】：

感谢您提供这些选项。有关信息，对于我的真实数据集，split() 版本在用完所有内存 3 多个小时后崩溃，而by() 版本似乎运行正常，大约需要 15 分钟。 @Ian Gow 的 dplyr::mutate() 版本运行时间约为 10 秒。所以使用split 是一个非首发，但by 看起来可能是可行的：比 dplyr 慢得多，但避免了依赖，所以有一个有用的选项。还要感谢 data.table 版本，我没有检查过，但作为一个可用的选项很方便。
啊，by() 方法似乎有一个缺点，因为它似乎重新排序了行。我想可以添加一个指示符列并在之后根据它重新排序，但当然要付出额外的步骤。