R语言筛选dat_mov日期前后均有zbfa测量值的纵向数据子集

问题说明 #

需要使用dplyr包的筛选逻辑处理纵向数据集，筛选规则如下：

• 仅纳入同时满足两个条件的受试者：dat_mov（特定节点日期）前至少1次有效zbfa（人体测量值）记录、dat_mov后至少1次间隔6个月及以上的有效zbfa记录
• 最终每个符合条件的受试者仅保留2条记录：dat_mov前最近1次有效测量、dat_mov后满6个月的首次有效测量
  原有逐行比较dat < dat_mov的写法存在逻辑缺陷：dat_mov仅在单个时间点行有值，逐行匹配会把同ID其他时间点的有效记录误判为不符合，导致符合条件的ID被错误剔除。

示例构造代码 #

id <- c(12)
periode <- c(2011:2018)
timepoint <- c(1:8)
zbfa <- c("NA", "NA", "-0.36", "-0.47", "NA", "-0.70", "NA", "NA")
dat <- c("NA", "NA", "2013-10-10", "2014-09-22", "NA", "2016-12-05", "NA", "NA")
dat_mov <- c("NA", "NA", "NA", "2014-06-30", "NA", "NA", "NA", "NA")
data <- data.frame(id, periode, timepoint, zbfa, dat, dat_mov)

原始数据预览 #

id periode timepoint  zbfa        dat    dat_mov
1 12    2011         1    NA         NA         NA
2 12    2012         2    NA         NA         NA
3 12    2013         3 -0.36 2013-10-10         NA
4 12    2014         4 -0.47 2014-09-22 2014-06-30
5 12    2015         5    NA         NA         NA
6 12    2016         6 -0.70 2016-12-05         NA
7 12    2017         7    NA         NA         NA
8 12    2018         8    NA         NA         NA

期望输出 #

示例中id=12符合筛选条件，最终仅保留2条目标记录，格式如下：

id periode timepoint  zbfa        dat dat_mov
1 12    2013         3 -0.36 2013-10-10      NA
2 12    2016         6 -0.70 2016-12-05      NA

注：提问中原示例期望输出标注timepoint=4为笔误，2013年记录对应原始数据timepoint=3

实现方案 #

解决思路 #

1. 先做数据类型清洗：把字符串格式的"NA"转为R语言识别的真正缺失值，将日期列转为标准日期格式，数值列转为数值类型
2. 按受试者id分组，提取每个ID唯一的dat_mov节点日期，避免逐行匹配的逻辑错误
3. 对每个ID单独筛选有效测量记录，分别定位节点前最近1条、节点后满6个月的最早1条记录，两条记录都存在则保留该ID的结果
4. 合并所有符合条件的记录输出最终数据集

可运行代码 #

library(dplyr)
library(lubridate)

# 数据类型清洗
clean_data <- data %>%
  mutate(across(c(zbfa, dat, dat_mov), ~na_if(., "NA"))) %>%
  mutate(
    zbfa = as.numeric(zbfa),
    dat = ymd(dat),
    dat_mov = ymd(dat_mov)
  )

# 按ID分组筛选目标记录
new_data <- clean_data %>%
  group_by(id) %>%
  mutate(mov_date = first(na.omit(dat_mov))) %>%
  # 先过滤掉无zbfa、无测量日期的无效记录
  filter(!is.na(zbfa), !is.na(dat)) %>%
  group_modify(~{
    current_mov <- .x$mov_date[1]
    # 提取节点前最近1条记录
    pre_meas <- .x %>%
      filter(dat < current_mov) %>%
      arrange(desc(dat)) %>%
      slice_head(n = 1)
    # 提取节点后6个月及以上的最早1条记录
    post_meas <- .x %>%
      filter(dat >= current_mov + months(6)) %>%
      arrange(dat) %>%
      slice_head(n = 1)
    # 前后记录都存在才返回结果
    if(nrow(pre_meas) == 1 & nrow(post_meas) == 1){
      bind_rows(pre_meas, post_meas)
    }
  }) %>%
  ungroup() %>%
  select(-mov_date)

运行代码后得到的结果和期望格式一致，支持多ID批量处理，不会出现逐行匹配导致的误删问题。

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