R中筛选接种后特定时间最近检测日期并批量生成新变量

需要提取每个受试者对应3个接种后时间点最接近的实验室检测记录：

• 接种后30天，对应变量名d3m1
• 接种后90天，对应变量名d3m3
• 接种后180天，对应变量名d3m6

匹配规则示例：如果某受试者3次检测分别在接种后27天、32天、40天，选32天的检测作为30天节点对应结果，命名为d3m1。

现有数据集字段说明：

• id：受试者唯一标识
• vax_date：疫苗接种日期
• assay_date：实验室检测日期
• wpost1/wpost3/wpost6：标记变量，取值为1代表该次检测属于对应时间窗、有资格匹配对应节点
• abs1/abs3/abs6：对应时间窗内，检测日期和接种日期间隔天数与目标节点天数的差值绝对值，值越小代表越接近目标节点，例如abs1的生成逻辑为：

abs1 = case_when(between(assay_date - vax_date, 14,45) ~ abs(assay_date - vax_date) - 30) 

原有代码存在两个问题：一是仅在wpost1==1的行给d3m1赋值，同个id下其他行返回NA；二是没有做批量适配，3个时间点需要重复写相同逻辑。

dplyr 实现方案 #

先按id分组计算每个节点的最优匹配记录，再合并回原数据集，保证同个id下所有行的节点变量取值统一，通过参数映射表实现循环处理，避免重复代码：

library(dplyr)

# 配置3个节点的字段映射关系，后续新增节点直接在这里加行即可
node_map <- tibble(
  node = c("d3m1", "d3m3", "d3m6"),
  wpost_col = c("wpost1", "wpost3", "wpost6"),
  abs_col = c("abs1", "abs3", "abs6")
)

# 批量计算每个id对应每个节点的最优匹配值
match_result <- lapply(1:nrow(node_map), function(i){
  current_node <- node_map$node[i]
  current_wpost <- node_map$wpost_col[i]
  current_abs <- node_map$abs_col[i]
  
  df %>%
    filter(.data[[current_wpost]] == 1) %>%
    group_by(id) %>%
    # 按差值升序排列，每组第一行就是最接近目标节点的记录
    arrange(.data[[current_abs]], .by_group = TRUE) %>%
    summarise(
      {{current_node}} := first(assay_date),
      # 需要同步提取其他检测指标在这里加即可，比如：
      # {{paste0(current_node, "_titer")}} := first(titer)
      .groups = "drop"
    )
}) %>%
  # 把3个节点的匹配结果按id合并成一张表
  Reduce(function(x,y) left_join(x,y, by="id"), .)

# 合并回原数据集，同id所有行都会填充统一的节点值
final_df <- df %>%
  left_join(match_result, by = "id")

data.table 实现方案 #

运行效率更高，适合百万行级别的大数据量场景，不需要拆分数据集再合并，直接在原数据上按分组完成赋值：

library(data.table)
dt <- as.data.table(dt)

# 节点参数映射表
node_map <- data.frame(
  node = c("d3m1", "d3m3", "d3m6"),
  wpost_col = c("wpost1", "wpost3", "wpost6"),
  abs_col = c("abs1", "abs3", "abs6")
)

# 循环批量处理3个节点
for(i in 1:nrow(node_map)){
  cur_node <- node_map$node[i]
  cur_wpost <- node_map$wpost_col[i]
  cur_abs <- node_map$abs_col[i]
  
  # 按id分组给所有行统一赋值，不需要提前筛选行
  dt[, (cur_node) := {
    valid_rows <- which(.SD[[cur_wpost]] == 1)
    if(length(valid_rows) == 0){
      NA_Date_
    }else{
      min_abs_idx <- which.min(.SD[[cur_abs]][valid_rows])
      .SD[["assay_date"]][valid_rows[min_abs_idx]]
    }
  }, by = id]
}

如果需要同步提取对应节点的其他检测指标，只需要在上述赋值块中新增对应列的计算逻辑即可，不需要重复编写分组逻辑。

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