如何在dplyr summarise的名称-值对列表中注入权重？

要实现这个需求，核心是利用**抽象语法树(AST)**捕获并修改...中的每个汇总表达式，自动将权重与聚合函数的目标变量相乘。我们可以借助rlang包的表达式操作工具来完成，以下是具体实现步骤：

完整实现代码 #

library(dplyr)
library(rlang)

# 定义递归函数：为聚合表达式注入权重
inject_weight <- function(expr, weights) {
  # 处理函数调用（如sum(b)、mean(log(d))）
  if (is_call(expr)) {
    # 针对常见聚合函数，修改第一个参数为「权重*原变量」
    agg_funs <- c("sum", "mean", "median", "sd", "var")
    if (as_string(expr[[1]]) %in% agg_funs) {
      expr[[2]] <- expr(!!weights * !!expr[[2]])
    }
    # 递归处理嵌套的函数调用（比如sum(log(b))这类场景）
    expr[-1] <- lapply(expr[-1], inject_weight, weights = weights)
  }
  expr
}

# 实现加权汇总函数
weighted_summarise <- function(data, weights, ...) {
  # 捕获权重列的表达式及环境
  weights <- enquo(weights)
  # 捕获所有汇总表达式（带命名）
  summaries <- enquos(...)
  
  # 为每个汇总表达式注入权重逻辑
  modified_summaries <- lapply(summaries, inject_weight, weights = weights)
  
  # 调用原生summarise，传递修改后的表达式
  data %>% 
    dplyr::summarise(!!!modified_summaries)
}

测试验证 #

用示例数据测试函数效果：

# 构造测试数据
test_data <- tibble(
  weights = c(0.5, 1, 1.5),
  b = c(10, 20, 30),
  d = c(5, 10, 15)
)

# 调用自定义加权汇总函数
test_data %>% weighted_summarise(weights, a = sum(b), c = mean(d))

输出结果与手动编写的加权汇总完全一致：

# A tibble: 1 × 2
      a     c
  <dbl> <dbl>
1    80    10

关键逻辑说明 #

1. 捕获表达式环境：
   • enquo(weights)和enquos(...)用于捕获输入的表达式及其所属环境，确保变量能在数据框的上下文正确解析，避免作用域问题。
2. 递归修改AST：
   • inject_weight函数递归遍历每个汇总表达式的AST：
     • 识别sum/mean等聚合函数调用；
     • 将聚合函数的第一个参数替换为weights * 原参数；
     • 支持嵌套表达式（如sum(log(b))会被转为sum(weights * log(b))）。
3. 传递修改后的表达式：
   • 使用!!!（unquote-splice）将修改后的表达式列表拆包传递给dplyr::summarise，保留原有的命名结构（比如a = sum(b)的命名会被完整保留）。

扩展方向 #

• 如果需要支持更多聚合函数，只需在agg_funs向量中添加对应的函数名；
• 对于多参数的聚合函数（如quantile），可以调整逻辑，针对特定参数注入权重（比如修改probs以外的参数）。

内容的提问来源于stack exchange，提问作者TemplateRex