基于data.table为自定义函数构建高效for循环的技术求助

我来帮你搞定这个基于data.table的多日期依从性计算问题，先理清楚你的需求：你需要基于minem提出的函数，在数百个评估日期上重复计算每个ID的覆盖天数，最后把所有结果合并成一个统一的data.table。你的原始循环有不少问题，咱们一步步来优化。

1. 回顾你的数据准备代码 #

首先是你提供的基础数据和包加载代码：

library(dplyr)
library(tidyr)
library(lubridate)
library(data.table)

# 构建adherence表
adherence <- cbind.data.frame(
  c("1", "2", "3", "1", "2", "3"), 
  c("2013-01-01", "2013-01-01", "2013-01-01", "2013-02-01", "2013-02-01", "2013-02-01")
)
names(adherence)[1] <- "ID"
names(adherence)[2] <- "year"
adherence$year <- ymd(adherence$year)
adherence <- as.data.table(adherence)

# 构建lsr表
lsr <- cbind.data.frame(
  c("1", "1", "1", "2", "2", "2", "3", "3"), #ID
  c("2012-03-01", "2012-08-02", "2013-01-06","2012-08-25", "2013-03-22", "2013-09-15", "2011-01-01", "2013-01-05"), #eksd
  c("60", "90", "90", "60", "120", "60", "30", "90") # DDD
)
names(lsr)[1] <- "ID"
names(lsr)[2] <- "eksd"
names(lsr)[3] <- "DDD"
lsr$eksd <- as.Date((lsr$eksd))
lsr$DDD <- as.numeric(as.character(lsr$DDD))
lsr$ENDDATE <- lsr$eksd + lsr$DDD
lsr <- as.data.table(lsr)

2. 参考函数（minem的by_minem2） #

你提到的minem函数是针对单个日期计算的，它的输出是每个ID在指定日期的覆盖天数：

by_minem2 <- function(dt = lsr) {
 d <- as.numeric(as.Date("2013-02-01"))
 dt[, ENDDATE2 := as.numeric(ENDDATE)]
 x <- dt[eksd <= d & ENDDATE > d, sum(ENDDATE2 - d), keyby = ID]
 uid <- unique(dt$ID)
 id2 <- setdiff(uid, x$ID)
 x2 <- data.table(ID = id2, V1 = 0)
 x <- rbind(x, x2)
 setkey(x, ID)
 x
}

运行结果如下：

> by_minem2(lsr)
   ID V1
1:  1 64
2:  2  0
3:  3 63

3. 你的核心需求 #

• 让函数支持传入任意评估日期，而不是硬编码的2013-02-01
• 在time.months的数百个日期上重复计算，每个结果绑定对应的评估日期
• 把所有结果合并成一个结构统一的data.table

4. 你原有循环的问题 #

你写的for循环存在几个关键问题：

• 把函数定义放在循环内部，每次循环都会重新定义函数，完全冗余
• 变量xtot没有提前初始化，直接append会报错
• 循环变量用了min(time.months):max(time.months)，这是数值范围，会包含很多不在time.months里的日期
• 循环内的结果累积逻辑混乱，没有正确绑定日期和结果

5. 高效解决方案（两种方法） #

方法一：lapply + rbindlist（简单易读，适合中等规模日期） #

先改写函数，让它接收评估日期作为参数，然后用lapply遍历所有日期，最后用rbindlist合并结果——这是data.table里处理这类重复计算的常规操作：

# 改写后的函数，支持传入评估日期d
by_minem_modified <- function(dt, d) {
  d_num <- as.numeric(d)
  dt[, ENDDATE2 := as.numeric(ENDDATE)]
  
  # 计算符合条件的ID的覆盖天数
  x <- dt[eksd <= d_num & ENDDATE > d_num, .(V1 = sum(ENDDATE2 - d_num)), by = ID]
  
  # 补全所有ID，没有覆盖的ID设为0
  all_ids <- unique(dt$ID)
  missing_ids <- setdiff(all_ids, x$ID)
  x <- rbind(x, data.table(ID = missing_ids, V1 = 0))
  
  # 添加评估日期列
  x[, eval_date := d]
  
  setkey(x, ID)
  return(x)
}

# 生成待评估的日期序列
time.months <- as.Date("2013-02-01") + (365.25/12)*(0:192)

# 遍历所有日期，生成结果列表后合并
result_list <- lapply(time.months, function(date) by_minem_modified(lsr, date))
final_result <- rbindlist(result_list)

# 查看前几行结果
head(final_result)

方法二：data.table笛卡尔积+分组计算（极致高效，适合大规模数据） #

如果你的数据量和日期数量都很大，推荐用这种方法——完全避免循环，利用data.table的高效关联和分组计算：

# 生成所有ID和评估日期的笛卡尔积（所有可能的组合）
all_combinations <- CJ(ID = unique(lsr$ID), eval_date = time.months)
# 转换日期为数值，方便后续计算
all_combinations[, eval_date_num := as.numeric(eval_date)]
lsr[, c("eksd_num", "ENDDATE_num") := .(as.numeric(eksd), as.numeric(ENDDATE))]

# 关联数据并计算每个ID-日期组合的覆盖天数
final_result <- lsr[all_combinations, on = "ID", allow.cartesian = TRUE
                   ][eksd_num <= eval_date_num & ENDDATE_num > eval_date_num, 
                     .(V1 = sum(ENDDATE_num - eval_date_num)), 
                     by = .(ID, eval_date)
                   ][all_combinations, on = .(ID, eval_date)
                     ][is.na(V1), V1 := 0]

# 调整列顺序，让结果更直观
setcolorder(final_result, c("eval_date", "ID", "V1"))

这两种方法都比你原来的for循环高效得多，其中方法二的性能优势在数据量越大时越明显——data.table的底层是C实现的，关联和分组计算的速度远快于普通R循环。

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