基于条件的日期变量计算求助：修正药物服用截止日期

问题说明 #

现有包含ID、MedicationDate（购药日期）、NumberOfPackages（购药数量）的数据集，需计算LastDate（药物服用截止日期），规则为：1包药物可使用1个月。

• 若本次购药日期晚于或等于上次药物用完日期，LastDate = 购药日期 + 购药数量对应的月份
• 若本次购药日期早于上次药物用完日期，LastDate = 购药日期 + 购药数量对应的月份 + 上次剩余天数

当前代码在处理最后一行数据时出错，正确结果应为2013-04-23，但代码输出为2013-04-02。

原始数据 #

ID    MedicationDate   NumberOfPackages
 X001   2011-01-12             3    
 X001   2011-01-12             3    
 X001   2011-01-12             3    
 X001   2013-02-23             1    
 X001   2013-03-02             1    

当前错误输出 #

ID    MedicationDate   NumberOfPackages     LastDate
 X001   2011-01-12             3             2011-04-12
 X001   2011-01-12             3             2011-04-12
 X001   2011-01-12             3             2011-04-12
 X001   2013-02-23             1             2013-03-23
 X001   2013-03-02             1             2013-04-02

有效单行测试代码 #

as.Date("2013-03-02") %m+% months(1) %m+% days(as.numeric(difftime(as.Date("2013-03-23"),as.Date("2013-03-02"), units = "days")))

当前失效代码 #

library(lubridate)

test <- test %>%
  group_by(ID) %>%
  arrange(MedicationDate) %>%
  mutate(LastDate =
           case_when(
             lag(MedicationDate) == MedicationDate | is.na(lag(LastDate)) | lag(LastDate) <= MedicationDate ~ as.Date(MedicationDate) %m+% months(NumberOfPackages),
             TRUE ~ as.Date(MedicationDate) %m+% months(NumberOfPackages) %m+% days(as.numeric(difftime(as.Date(lag(LastDate)),as.Date(MedicationDate), units = "days"))) 
           ) 
  ) 

修正方案 #

问题核心：mutate中使用lag(LastDate)无法实时获取前一行刚计算出的LastDate值，因为mutate是批量计算列，而非逐行递推。需要用累积计算的方式处理依赖前一行结果的场景，这里使用purrr::accumulate实现递推逻辑。

修正后代码：

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

test <- test %>%
  group_by(ID) %>%
  arrange(MedicationDate) %>%
  mutate(
    LastDate = accumulate(
      .x = seq_along(MedicationDate),
      .f = function(prev_last, i) {
        current_date <- MedicationDate[i]
        current_packs <- NumberOfPackages[i]
        # 第一行或同日期购药，直接计算截止日期
        if (i == 1 || MedicationDate[i] == MedicationDate[i-1]) {
          current_date %m+% months(current_packs)
        } else {
          # 比较当前购药日期与上次截止日期
          if (current_date >= prev_last) {
            current_date %m+% months(current_packs)
          } else {
            # 加上上次剩余的天数
            current_date %m+% months(current_packs) %m+% days(as.numeric(difftime(prev_last, current_date, units = "days")))
          }
        }
      },
      .init = as.Date(NA)
    ) %>% tail(-1)  # 去掉.init生成的NA
  )

修正后结果 #

ID    MedicationDate NumberOfPackages LastDate  
  <chr> <date>                    <dbl> <date>    
1 X001  2011-01-12                   3 2011-04-12
2 X001  2011-01-12                   3 2011-04-12
3 X001  2011-01-12                   3 2011-04-12
4 X001  2013-02-23                   1 2013-03-23
5 X001  2013-03-02                   1 2013-04-23

内容的提问来源于stack exchange，提问作者reaq-br4