如何加速R data.table中逐行计算历史订阅天数的代码？

我有一份订阅数据集，包含以下字段：

• 订阅者（SUBSCRIBER）
• 订阅类型（SUBSCRIPTION_TYPE）
• 订阅签发日期（SUBSCRIPTION_ISSUE）
• 订阅开始日期（SUBSCRIPTION_START）
• 订阅结束日期（SUBSCRIPTION_END）

同一订阅者可能同时拥有多个同类型订阅（日期区间可能重叠）。需要为每一条订阅记录，计算该订阅者在当前订阅签发日期前1826天（约5年）内，该类型订阅的累计有效天数（需去重重叠日期）。

我已写出可运行但运行缓慢的代码，尝试用apply/mapply和purrr提速但未成功，也不确定如何改写为向量化函数，请求优化以下代码：

library(lubridate)
library(data.table)

# create example data
df <- 
  data.frame(
    SUBSCRIBER = c("A", "A", "A", "A", "A", "A", "B", "B", "B"),
    SUBSCRIPTION_TYPE = c("X", "X", "X", "X", "Z", "Z", "X", "X", "X"),
    SUBSCRIPTION_ISSUE = c(
      "2021-12-31",
      "2022-01-02",
      "2022-12-21",
      "2023-01-01",
      "2025-01-01",
      "2025-01-03",
      "2023-01-01",
      "2025-01-01",
      "2025-01-03"
    ),
    SUBSCRIPTION_START = c(
      "2022-01-01",
      "2022-01-03",
      "2023-01-01",
      "2023-01-03",
      "2025-01-01",
      "2025-01-03",
      "2023-01-03",
      "2025-01-01",
      "2025-01-03"
    ),
    SUBSCRIPTION_END = c(
      "2022-01-05",
      "2022-01-07",
      "2023-01-05",
      "2023-01-07",
      "2025-01-05",
      "2025-01-07",
      "2023-01-07",
      "2025-01-05",
      "2025-01-07"
    )
  )

# convert date columns to Date format
df$SUBSCRIPTION_ISSUE <- as.Date(df$SUBSCRIPTION_ISSUE)
df$SUBSCRIPTION_START <- as.Date(df$SUBSCRIPTION_START)
df$SUBSCRIPTION_END <- as.Date(df$SUBSCRIPTION_END)

# Convert data frame to data table
dt <- as.data.table(df)


# create a function to calculate the cumulative day count for each subscriber, subscription type, and issue date
calc_cumulative_days <- 
  function(dtinput,
           this_SUBSCRIBER,
           this_SUBSCRIPTION_TYPE,
           this_SUBSCRIPTION_ISSUE) {
    # filter the rows within the sliding window
    dtsubset <- 
      dtinput[SUBSCRIBER == this_SUBSCRIBER &
                SUBSCRIPTION_TYPE == this_SUBSCRIPTION_TYPE &
                SUBSCRIPTION_START < this_SUBSCRIPTION_ISSUE &
                SUBSCRIPTION_END > this_SUBSCRIPTION_ISSUE - 1826, ]
    dtsubset$days <- 1
    
    # create a data table with all dates within the sliding window
    dates <- 
      data.table(date = seq(
        from = this_SUBSCRIPTION_ISSUE[1] - 1,
        length.out = 1826,
        by = "-1 day"
      ))
    
    # convert date variable to class Date
    dates[, date := as.Date(date)] # Not sure whether this row speeds up or slows down
    setkey(dates, date) # Not sure whether this row speeds up or slows down
    
    # join with the dates table to get all dates within the sliding window
    joined <- 
      dates[dtsubset, on = .(date >= SUBSCRIPTION_START, date <= SUBSCRIPTION_END)]
    result <- nrow(joined)
    return(result)
  }



# apply the function to each row in the data table
dt[, historic_subscription_days := calc_cumulative_days(dt, SUBSCRIBER, SUBSCRIPTION_TYPE, SUBSCRIPTION_ISSUE), by = seq_len(nrow(dt))]

优化思路与代码 #

原代码低效原因 #

• 逐行循环调用函数，未利用data.table的分组与向量化优势
• 每次循环生成1826天的日期序列，重复计算开销极大
• 通过行连接统计天数，效率远低于直接计算区间重叠的总天数（无需展开日期）

优化方案 #

核心逻辑：按SUBSCRIBER+SUBSCRIPTION_TYPE分组，先合并组内重叠的订阅区间，再针对每条记录的时间窗口计算重叠天数总和，全程避免逐行循环与日期展开。

优化后的代码：

library(data.table)
library(lubridate)

# 构建示例数据并转换为data.table
df <- data.frame(
  SUBSCRIBER = c("A", "A", "A", "A", "A", "A", "B", "B", "B"),
  SUBSCRIPTION_TYPE = c("X", "X", "X", "X", "Z", "Z", "X", "X", "X"),
  SUBSCRIPTION_ISSUE = as.Date(c(
    "2021-12-31", "2022-01-02", "2022-12-21", "2023-01-01",
    "2025-01-01", "2025-01-03", "2023-01-01", "2025-01-01", "2025-01-03"
  )),
  SUBSCRIPTION_START = as.Date(c(
    "2022-01-01", "2022-01-03", "2023-01-01", "2023-01-03",
    "2025-01-01", "2025-01-03", "2023-01-03", "2025-01-01", "2025-01-03"
  )),
  SUBSCRIPTION_END = as.Date(c(
    "2022-01-05", "2022-01-07", "2023-01-05", "2023-01-07",
    "2025-01-05", "2025-01-07", "2023-01-07", "2025-01-05", "2025-01-07"
  ))
)

dt <- as.data.table(df)

# 1. 定义合并重叠区间的函数
merge_intervals <- function(starts, ends) {
  if (length(starts) == 0) return(data.table(start = Date(), end = Date()))
  # 按开始日期排序
  ord <- order(starts)
  starts_sorted <- starts[ord]
  ends_sorted <- ends[ord]
  
  merged_starts <- starts_sorted[1]
  merged_ends <- ends_sorted[1]
  
  for (i in 2:length(starts_sorted)) {
    current_start <- starts_sorted[i]
    current_end <- ends_sorted[i]
    last_merged_end <- merged_ends[length(merged_ends)]
    
    if (current_start <= last_merged_end + 1) {
      # 重叠或连续区间，合并
      merged_ends[length(merged_ends)] <- max(last_merged_end, current_end)
    } else {
      # 不重叠，新增区间
      merged_starts <- c(merged_starts, current_start)
      merged_ends <- c(merged_ends, current_end)
    }
  }
  return(data.table(start = merged_starts, end = merged_ends))
}

# 2. 计算每条记录的时间窗口：[签发日期-1826, 签发日期-1]
dt[, c("window_start", "window_end") := .(SUBSCRIPTION_ISSUE - 1826, SUBSCRIPTION_ISSUE - 1)]

# 3. 按用户-类型-窗口分组，预合并符合条件的历史订阅区间（排除当前记录）
dt[, historic_intervals := .(list(merge_intervals(
  starts = SUBSCRIPTION_START[SUBSCRIPTION_START < .BY$SUBSCRIPTION_ISSUE],
  ends = SUBSCRIPTION_END[SUBSCRIPTION_END > .BY$window_start]
))), by = .(SUBSCRIBER, SUBSCRIPTION_TYPE, window_start, window_end)]

# 4. 计算每条记录窗口内的重叠天数总和
calc_overlap_days <- function(intervals, win_start, win_end) {
  if (nrow(intervals) == 0) return(0)
  # 计算每个合并区间与窗口的重叠部分
  intervals[, overlap_start := pmax(start, win_start)]
  intervals[, overlap_end := pmin(end, win_end)]
  intervals[, overlap_days := overlap_end - overlap_start + 1]
  # 过滤无重叠的情况并求和
  return(sum(intervals$overlap_days[overlap_days > 0]))
}

dt[, historic_subscription_days := calc_overlap_days(historic_intervals[[1]], window_start, window_end), by = seq_len(nrow(dt))]

# 清理临时列
dt[, c("window_start", "window_end", "historic_intervals") := NULL]

print(dt)

优化效果说明 #

• 利用data.table分组操作替代逐行循环，减少重复计算
• 通过合并重叠区间，直接计算区间重叠天数，无需生成大量日期序列，内存与计算效率大幅提升
• 预计算每个窗口内的有效区间，进一步降低重复运算量

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