基于R数据框分组与行列值的新变量条件计算需求

示例数据 #

我在R中有如下调查数据集，需要针对特定新变量进行条件计算：

# Load package
library(tidyverse)

# Important: set seed for replicability
set.seed(123)

# Create data: step 1
df <- tibble(
  country = c(rep("A", 10), rep("B", 10)),
  respondent_id = 1:20,
  vote_choice = c(sample(c("PartyA", "PartyB", "PartyC"), 10, replace = TRUE),
                  sample(c("PartyD", "PartyE", "PartyF"), 10, replace = TRUE)),
  ptv_1 = runif(20, min = 0, max = 1) %>% round(., 3),
  ptv_2 = runif(20, min = 0, max = 1) %>% round(., 3),
  ptv_3 = runif(20, min = 0, max = 1) %>% round(., 3)
)

# Create data: step 2
df <- df %>% 
  group_by(vote_choice, country) %>%
  summarize(across(starts_with("ptv"), \(x) mean(x, na.rm = TRUE))) %>%
  pivot_longer(cols = starts_with("ptv"), names_to = "party_to_ptv", values_to = "average_value") %>%
  group_by(vote_choice, country) %>%
  slice_max(order_by = average_value) %>%
  ungroup() %>%
  mutate(average_value = NULL) %>%
  right_join(., df, by = c("vote_choice", "country"))

# Inspect data
df

变量说明 #

• country：包含2个国家，各10名受访者，每个国家有3个政党
• respondent_id：受访者ID，标识数据为受访者级别
• vote_choice：受访者上次选举投票的政党
• ptv_1/ptv_2/ptv_3：受访者对对应政党的倾向值，范围0-1
• party_to_ptv：映射vote_choice中的政党对应的ptv_*列

问题描述 #

需要计算政党的选举机会指标，最终需得到每个vote_choice政党的平均选举机会。

计算逻辑：
1 - (sqrt(选民所投票政党的PTV值) - sqrt(目标政党的PTV值))

计算规则：

1. 逐行获取受访者所投票政党对应的PTV列值
2. 若目标政党与所投票政党相同，结果设为NA
3. 将大于1的结果截断为1

手动计算示例（以electoral_opportunities_1为例）：

df %>% 
  mutate(electoral_potential_1 = 
           c(1 - ( sqrt(0.799) - sqrt(0.691) ),
             1 - ( sqrt(0.810) - sqrt(0.544) ),
             1 - ( sqrt(0.794) - sqrt(0.289) ),
             1 - ( sqrt(0.440) - sqrt(0.147) ),
             1 - ( sqrt(0.754) - sqrt(0.963) ),
             NA,
             NA,
             NA,
             NA,
             NA,
             1 - ( sqrt(0.220) - sqrt(0.478) ),
             1 - ( sqrt(0.352) - sqrt(0.318) ),
             1 - ( sqrt(0.668) - sqrt(0.415) ),
             1 - ( sqrt(0.418) - sqrt(0.414) ),
             NA,
             NA,
             NA,
             1 - ( sqrt(0.753) - sqrt(0.216) ),
             1 - ( sqrt(0.374) - sqrt(0.232) ),
             1 - ( sqrt(0.665) - sqrt(0.143) )) ) -> df

df %>% 
  mutate(electoral_opportunities_1 = ifelse(electoral_opportunities_1 > 1, 1, electoral_opportunities_1)) -> df

tidyverse高效解决方案 #

通过长格式重塑数据实现批量计算，避免手动逐个列处理：

library(tidyverse)

# 处理流程
df_processed <- df %>%
  # 1. 提取选民所投票政党的PTV值
  mutate(voted_ptv = case_when(
    party_to_ptv == "ptv_1" ~ ptv_1,
    party_to_ptv == "ptv_2" ~ ptv_2,
    party_to_ptv == "ptv_3" ~ ptv_3
  )) %>%
  # 2. 将ptv列转为长格式，批量处理所有目标政党
  pivot_longer(
    cols = starts_with("ptv"),
    names_to = "target_party_ptv",
    values_to = "target_ptv"
  ) %>%
  # 3. 应用计算逻辑，处理NA和截断值
  mutate(
    electoral_opportunity = case_when(
      target_party_ptv == party_to_ptv ~ NA_real_,
      TRUE ~ 1 - (sqrt(voted_ptv) - sqrt(target_ptv))
    ),
    electoral_opportunity = pmin(electoral_opportunity, 1)
  ) %>%
  # 4. 按投票政党分组计算平均选举机会
  group_by(vote_choice) %>%
  summarize(average_electoral_opportunity = mean(electoral_opportunity, na.rm = TRUE))

# 查看结果
df_processed

代码解释 #

• 提取所投票政党PTV值：通过case_when根据party_to_ptv的映射关系，自动匹配对应ptv_*列的值，无需手动逐行赋值。
• 长格式重塑：将宽格式的ptv_1/2/3转为长格式，让每个目标政党对应一行数据，实现批量计算，省去单独处理每个electoral_opportunities_*列的麻烦。
• 计算与截断：用case_when处理目标政党与所投票政党相同的NA场景，应用公式后通过pmin统一将大于1的结果截断为1。
• 分组求平均：直接按vote_choice分组，计算每个政党的平均选举机会，一步得到最终汇总结果。

示例输出 #

运行代码后将得到类似如下的汇总结果：

# A tibble: 6 × 2
  vote_choice average_electoral_opportunity
  <chr>                               <dbl>
1 PartyA                               0.923
2 PartyB                               0.871
3 PartyC                               0.895
4 PartyD                               0.942
5 PartyE                               0.883
6 PartyF                               0.867

内容的提问来源于stack exchange，提问作者Dr. Fabian Habersack