如何用R语言针对特定年龄计算概率面积及条件校正

问题背景 #

给定数据集结构如下：

library("tidyverse")
DataSet2 <- tibble(
  id = c(1,2,3,4,5,6,7,8,9,10),
  AGE = c(15,15.25,15.5, 15.75, 16, 16.25, 16.5, 16.75, 46.5, 46.75),
  f_curve_notch = c(25.14,30.28,43.33,43.33,25.14,25.14,25.14,25.14,67,33.77),
  f_curve_tilde = c(.2514,30.28,43.33,43.33,25.14,25.14,25.14,25.14,.67,33.77)
)

需完成两项核心任务：

1. 按年龄段计算probarea，首尾年龄段公式特殊，中间段遵循统一模式，计算覆盖至46.5岁对应的年龄段
2. 对probarea进行条件校正：若对应年龄的f_curve_notch>0且不等于同年龄的f_curve_tilde，则给probarea加上((f_curve_tilde - f_curve_notch)*0.125)，否则保持原值

解决方案 #

1. 数据预处理：分组排序 #

针对百万级数据，优先使用向量化操作保证效率，先按个体id分组并按AGE排序：

data_processed <- DataSet2 %>%
  group_by(id) %>%
  arrange(AGE, .by_group = TRUE) %>%
  mutate(
    is_first = row_number() == 1,
    is_last = row_number() == n()
  )

2. 批量计算各年龄段probarea #

根据示例公式，划分三类计算逻辑，使用slider包的滑动窗口函数实现批量计算：

# 安装依赖包（首次运行需执行）
# install.packages("slider")
library(slider)

data_with_probarea <- data_processed %>%
  mutate(
    probarea = case_when(
      # 首段（age15probarea）：取前3个年龄点计算
      is_first ~ slide_dbl(
        f_curve_notch,
        ~((.x[1]*2) + (.x[2]*2) + .x[3])/5,
        .after = 2, .complete = TRUE
      ),
      # 末段（age47probarea）：取最后2个年龄点计算
      is_last ~ ((nth(f_curve_notch, n()-1) + last(f_curve_notch)*2)/3),
      # 中间段：取连续5个年龄点计算
      TRUE ~ slide_dbl(
        f_curve_notch,
        ~(.x[1] + .x[2]*2 + .x[3]*2 + .x[4]*2 + .x[5])/8,
        .after = 4, .complete = TRUE
      )
    ),
    # 标记对应年龄段
    age_group = case_when(
      is_first ~ "age15",
      is_last ~ "age47",
      TRUE ~ paste0("age", floor(AGE) + 1)
    )
  ) %>%
  filter(!is.na(probarea)) # 过滤无效窗口的计算结果

3. 条件校正probarea #

按要求对计算结果进行校正：

data_final <- data_with_probarea %>%
  mutate(
    probarea_corrected = case_when(
      f_curve_notch > 0 & f_curve_notch != f_curve_tilde ~ probarea + ((f_curve_tilde - f_curve_notch)*0.125),
      TRUE ~ probarea
    )
  )

百万级数据效率优化 #

如果数据量极大，可改用data.table进一步提升运算速度：

# 安装依赖包（首次运行需执行）
# install.packages("data.table")
library(data.table)

setDT(DataSet2)
data_processed_dt <- DataSet2[order(id, AGE), 
                              `:=`(is_first = .I == 1, is_last = .I == .N), 
                              by = id]

data_final_dt <- data_processed_dt[, 
  probarea := fcase(
    is_first, ((f_curve_notch[1]*2)+(f_curve_notch[2]*2)+f_curve_notch[3])/5,
    is_last, ((f_curve_notch[.N-1] + f_curve_notch[.N]*2))/3,
    TRUE, frollapply(f_curve_notch, 5, function(x) (x[1]+x[2]*2+x[3]*2+x[4]*2+x[5])/8, align = "left")
  ),
  by = id
][,
  probarea_corrected := fcase(
    f_curve_notch >0 & f_curve_notch != f_curve_tilde, probarea + ((f_curve_tilde - f_curve_notch)*0.125),
    default = probarea
  )
]

结果说明 #

最终输出的data_final（或data_final_dt）包含每个个体各年龄段的原始probarea、校正后的probarea_corrected及对应年龄段标记，可直接用于后续分析。

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