如何在ggplot2的批量条形图函数中应用调查权重？

问题背景 #

处理包含250列的调查数据，现有函数可生成按sector分组的响应百分比条形图，需修改为加权百分比以反映调查权重的影响。

样本数据 #

q1 <- factor(c("yes",NA,"no","yes",NA,"yes","no","yes"))
q2 <- factor(c("Albania","USA","Albania","Albania","UK",NA,"UK","Albania"))
q3 <- factor(c(0,1,NA,0,1,1,NA,0))
q4 <- factor(c(0,NA,NA,NA,1,NA,0,0))
q5 <- factor(c("Dont know","Prefer not to answer","Agree","Disagree",NA,"Agree","Agree",NA))
q6 <- factor(c(1,NA,3,5,800,NA,900,2))
sector <- factor(c("Energy","Water","Energy","Other","Other","Water","Transportation","Energy"))
# 修正：原数据中weights被错误定义为factor，需改为numeric类型才能参与计算
weights <- as.numeric(c(0.13,0.25,0.13,0.22,0.22,0.25,0.4,0.13))

data <- data.frame(q1,q2,q3,q4,q5,q6,sector,weights)

原有未加权函数 #

plot_fun <- function(variable) {
  total <- sum(!is.na(data[[variable]]))
  
  data <- data |>
    filter(!is.na(.data[[variable]])) |>
    group_by(across(all_of(c("sector", variable)))) |>
    summarise(n = n(), .groups = "drop_last") |>
    mutate(pct = n / sum(n)) |>
    ungroup()
  
  ggplot(
    data = data,
    mapping = aes(fill = sector, x = pct, y = .data[[variable]])
  ) +
    geom_col(position = "dodge") +
    labs(
      y = variable, x = "Percentage of responses", fill = "Sector legend",
      caption = paste("Total =", total)
    ) +
    geom_text(
      aes(
        label = scales::percent(pct, accuracy = 0.1)
      ),
      position = position_dodge(.9), vjust = 0.5
    ) +
    scale_x_continuous(labels=function(x) paste0(x*100))+
    scale_fill_brewer(palette = "Accent")+
    theme_bw() +
    theme(panel.grid.major.y = element_blank()) 
}

修改后的加权版本函数 #

plot_fun_weighted <- function(variable) {
  # 计算该变量的加权总样本量（排除NA）
  total_weighted <- sum(data$weights[!is.na(data[[variable]])], na.rm = TRUE)
  
  data_processed <- data |>
    filter(!is.na(.data[[variable]])) |>
    # 按sector和目标变量分组
    group_by(sector, .data[[variable]]) |>
    # 计算每组的权重总和
    summarise(weight_sum = sum(weights, na.rm = TRUE), .groups = "drop") |>
    # 按目标变量分组，计算每个响应类别的总权重
    group_by(.data[[variable]]) |>
    # 计算加权百分比：组权重 / 响应类别总权重
    mutate(pct = weight_sum / sum(weight_sum, na.rm = TRUE)) |>
    ungroup()
  
  ggplot(
    data = data_processed,
    mapping = aes(fill = sector, x = pct, y = .data[[variable]])
  ) +
    geom_col(position = "dodge") +
    labs(
      y = variable, 
      x = "Weighted Percentage of responses", 
      fill = "Sector legend",
      caption = paste("Weighted Total =", round(total_weighted, 2))
    ) +
    geom_text(
      aes(label = scales::percent(pct, accuracy = 0.1)),
      position = position_dodge(.9), 
      vjust = 0.5
    ) +
    scale_x_continuous(labels = function(x) paste0(x*100)) +
    scale_fill_brewer(palette = "Accent") +
    theme_bw() +
    theme(panel.grid.major.y = element_blank()) 
}

关键改动说明 #

• 修正权重类型：原数据中weights被定义为factor，无法直接求和，改为numeric是解决问题的前提。
• 加权总样本量：替换原有的非NA计数，改为计算有效样本的权重总和，更符合调查权重的统计逻辑。
• 分组计算权重和：用sum(weights)替代n()，得到每组的加权样本量，而非简单计数。
• 加权百分比计算：按目标变量的每个响应类别分组，用组权重除以该类别的总权重，得到符合调查权重的百分比。
• 更新标签：将X轴和标题明确标注为“加权百分比”，并在说明中展示加权总样本量，提升图表可读性。

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