使用purrr::map_dfr循环计算多列加权均值的问题排查

数据准备 #

library(tidyverse)

df <- tribble(
            ~weight,    ~country,  ~thingy_MASTER_s, ~thingy_blue_s, ~thing_red_s,   ~thingy_yellow_s, ~thingy_orange_s, ~thingy_brown_s, ~thingy_pink_s, ~thingy_purple_s,
            1.93218,   "Germany",             1.0,            1.00,           NA,                 NA,               NA,         NA,                  NA,             1.00,
            0.84321,   "Germany",             1.0,            1.00,           NA,                 NA,               NA,         NA,                  NA,             1.00,
            1.11002,   "Germany",             NA,             0.75,           NA,                 NA,               NA,         NA,                  NA,             0.50,
            0.46321,   "Germany",             0.5,            1.00,           NA,                 NA,               NA,         NA,                  0.5,            0.75,
            0.69321,   "Germany",             1.0,            1.00,           NA,                0.5,               NA,         NA,                  NA,             1.00,
            0.77889,   "Germany",             0.5,            0.75,           NA,                 NA,               NA,         NA,                  NA,             0.75,
            1.32321,   "Germany",             NA,             1.00,         0.75,                 NA,               NA,        0.5,                  NA,             0.50,
            1.49493,   "Germany",             1.0,            0.75,           NA,                 NA,               NA,         NA,                  NA,             1.00,
            1.03219,    "Brazil",             0.25,            0.5,         0.25,               0.50,             0.25,         NA,                0.50,             0.25,
            0.48632,    "Brazil",             0.75,             NA,           NA,               0.75,               NA,         NA,                  NA,             1.00,
            0.98981,    "Brazil",             NA,               NA,           NA,                 NA,               NA,         NA,                  NA,               NA,
            0.81818,    "Brazil",             NA,               NA,           NA,                 NA,               NA,         NA,                  NA,             0.75,
            1.22391,    "Brazil",             0.75,             NA,         1.00,                 NA,               NA,         NA,                0.75,             1.00,
            1.70182,    "Brazil",             NA,               NA,           NA,                 NA,               NA,         NA,                  NA,               NA,
            0.90429,    "Brazil",             1.00,            1.0,           NA,               1.00,             1.00,          1,                1.00,             1.00,
            1.01102,    "Brazil",             NA,               NA,          0.5,               0.25,               NA,       0.75,                  NA,               NA
            )

需求说明 #

需要批量处理除thingy_MASTER_s外的所有thingy_前缀列，每列执行以下步骤：

• 筛选出thingy_MASTER_s与当前列均非缺失的行
• 按country和列名分组，计算以weight为权重的加权均值

已实现单列处理，但复制代码多列处理冗余，希望用purrr::map_dfr批量实现。

用户尝试的错误代码 #

vars <- c("thingy_blue_s", "thing_red_s", "thingy_yellow_s", "thingy_orange_s", "thingy_brown_s", "thingy_pink_s", "thingy_purple_s")
names(vars) <- vars

equivalent_values_fcn <- function(sample, .x){
sample %>%
    mutate(master_and_{{.x}} = (!is.na(thingy_MASTER_s) & !is.na({{.x}}))) %>%
    pivot_longer(!c(weight, country, master_and_{{.x}}), names_to = "thingy", values_to = "value") %>%
    filter(thingy %in% c("thingy_MASTER_s", {{.x}}), master_and_{{.x}} == TRUE) %>%
    group_by(thingy, country) %>%
    summarise(mean = weighted.mean(value, weight, na.rm=T)) %>% 
    arrange(country, thingy)
}

purrr::map_dfr(
    .x = tidyselect::all_of(vars),
    .f = ~equivalent_values_fcn(df, .x)
)

问题排查与修正方案 #

错误原因 #

1. 动态列名生成错误：mutate(master_and_{{.x}})的写法无法正确生成动态列名，且生成布尔列属于冗余操作
2. 列引用方式错误：当.x是字符串形式的列名时，{{.x}}无法正确引用数据框中的列，需用.data[[.x]]或all_of()
3. 冗余的pivot操作：原代码pivot所有列再过滤，效率低下

正确实现代码 #

library(tidyverse)

# 定义要处理的目标列
target_cols <- c("thingy_blue_s", "thing_red_s", "thingy_yellow_s", 
                 "thingy_orange_s", "thingy_brown_s", "thingy_pink_s", 
                 "thingy_purple_s")

# 定义批量处理函数
calc_weighted_mean <- function(data, col) {
  data %>%
    # 直接筛选MASTER列和当前列均非缺失的行
    filter(!is.na(thingy_MASTER_s) & !is.na(.data[[col]])) %>%
    # 仅保留必要列，减少计算量
    select(weight, country, thingy_MASTER_s, all_of(col)) %>%
    # 转成长格式，统一分组计算
    pivot_longer(cols = c(thingy_MASTER_s, all_of(col)),
                 names_to = "thingy", values_to = "value") %>%
    group_by(country, thingy) %>%
    # 计算加权均值，同时释放分组
    summarise(mean = weighted.mean(value, weight, na.rm = TRUE), .groups = "drop") %>%
    arrange(country, thingy)
}

# 使用map_dfr批量处理并合并结果
final_result <- map_dfr(target_cols, ~calc_weighted_mean(df, .x))

# 查看结果
print(final_result)

代码说明 #

• 去掉了冗余的布尔列生成，直接在filter中判断条件，提升效率
• 用.data[[col]]正确引用字符串形式的列名，解决列引用错误问题
• 先筛选必要列再执行pivot_longer，减少数据处理量
• 使用.groups = "drop"避免分组状态残留，确保后续操作不受影响
• 批量处理后的结果自动合并为单个tibble，符合需求

内容的提问来源于stack exchange，提问作者C.Robin