编写R函数按规则生成孕期服药暴露周数统计列

示例数据集 #

df <- data.frame(
  id = c(1, 2, 3, 4),
  purchase = c("2023-01-01", "2023-05-30", "2023-09-06", "2023-08-26"),  # 每人购药日期示例
  date_conception = c("2023-01-01", "2023-05-01", "2023-06-01", "2023-07-01"),  # 每人受孕日期
  treatement_length = c(30, 45, 20, 10)) %>%
  mutate(date_conception = as.Date(date_conception),
         purchase = as.Date(purchase)) %>%
  mutate(trimestre_1 = date_conception + days(98))

需求说明 #

需统计女性受孕首日（date_conception）至孕早期结束（trimestre_1，共14周）内，每周的服药暴露天数，规则如下：

• 每周最多统计7天
• 未用完的疗程天数顺延至后续周
• 超出14周的疗程部分直接忽略

示例规则：

• 受孕首日购药、疗程30天：第1-4周各7天，第5周2天，其余周为0
• 孕14周前1天购药、疗程10天：第14周1天，其余周为0

期望输出 #

result_df <- df %>%
  mutate(week1 = c(7, 0, 0, 0),
         week2 = c(7,0,0,0),
         week3 = c(7,0,0,0),
         week4 = c(7,0,0,0),
         week5 = c(2,7,0,0),
         week6 = c(0,7,0,0),
         week7 = c(0,7,0,0),
         week8 = c(0,7,0,0),
         week9 = c(0,7,0,7),
         week10 = c(0,7,0,3),
         week11 = c(0,3,0,0),
         week12 = c(0,0,0,0),
         week13 = c(0,0,0,0),
         week14 = c(0,0,2,0))

实现代码 #

结合dplyr、purrr和lubridate包，通过自定义函数批量计算每周暴露天数：

library(dplyr)
library(purrr)
library(lubridate)

# 自定义函数：计算单个个体的每周服药暴露天数
calculate_weekly_exposure <- function(purchase_date, conception_date, treatment_days, end_date) {
  # 确定服药的起始/结束日期
  treat_start <- purchase_date
  treat_end <- purchase_date + days(treatment_days - 1)
  
  # 限制在孕早期时间范围内
  actual_start <- max(treat_start, conception_date)
  actual_end <- min(treat_end, end_date)
  
  # 无有效服药日期时返回全0向量
  if (actual_start > actual_end) {
    return(set_names(rep(0, 14), paste0("week", 1:14)))
  }
  
  # 生成所有服药日期，并计算对应孕周
  treat_dates <- seq(actual_start, actual_end, by = "day")
  week_nums <- ceiling((treat_dates - conception_date + 1) / 7)
  
  # 统计每周天数，补全1-14周的0值
  weekly_counts <- table(factor(week_nums, levels = 1:14))
  
  return(set_names(as.numeric(weekly_counts), paste0("week", 1:14)))
}

# 应用函数到数据集
result_df <- df %>%
  rowwise() %>%
  mutate(weekly_exposure = list(calculate_weekly_exposure(purchase, date_conception, treatement_length, trimestre_1))) %>%
  unnest_wider(weekly_exposure) %>%
  ungroup()

# 输出结果
print(result_df)

代码逻辑说明 #

1. 日期范围过滤：先锁定孕早期内的有效服药区间，排除超出范围的天数
2. 孕周映射：通过日期差计算每个服药日期对应的孕周（受孕日所在周期为第1周）
3. 天数统计：用table统计每周天数，自动补全未覆盖周的0值
4. 批量处理：通过rowwise()逐行计算，再用unnest_wider()将结果展开为列

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