合并 data.table 中部分重叠的日期范围

Question

假设我有两张表（DT_sportA 和 DT_sportB），用于测量两个孩子（id）参加运动“A”和“B”的时间段。

library(data.table)
library(lubridate)

DT_sportA <- data.table(id = rep(1:2,each=2),
                start_date = ymd(c("2000-01-01","2002-01-15","2014-03-12","2016-10-14")),
                end_date = ymd(c("2000-02-03","2003-03-01","2014-04-03","2017-05-19")))
DT_sportA
#    id start_date   end_date
# 1:  1 2000-01-01 2000-02-03
# 2:  1 2002-01-15 2003-03-01
# 3:  2 2014-03-12 2014-04-03
# 4:  2 2016-10-14 2017-05-19


DT_sportB <- data.table(id = c(1L,1L,2L),
                        start_date = ymd(c("2000-01-15","2002-01-15","2017-02-10")),
                        end_date = ymd(c("2000-02-01","2006-03-19","2017-02-20")))

DT_sportB
#    id start_date   end_date
# 1:  1 2000-01-15 2000-02-01
# 2:  1 2002-01-15 2006-03-19
# 3:  2 2017-02-10 2017-02-20

我想生成一个新表，其中包含所有唯一且重叠的日期范围，其中两个分类指标表示孩子们参加的运动。所需的 DT 应如下所示：

   id start_date   end_date sportA sportB
1:  1 2000-01-01 2000-01-14      1      0
2:  1 2000-01-15 2000-02-01      1      1
3:  1 2000-02-02 2000-02-03      1      0
4:  1 2002-01-15 2002-03-01      1      1
5:  1 2002-03-02 2002-03-19      0      1
6:  2 2014-03-12 2014-04-03      1      0
7:  2 2016-10-14 2017-02-09      1      0
8:  2 2017-02-10 2017-02-20      1      1
9:  2 2017-02-21 2017-05-19      1      0

这是一个相当简单的玩具示例。真实数据跨越数百万行和大约 20 个“运动”，这就是我寻找data.table 解决方案的原因。

Answer 1

注意事项：

• 当对多个表执行类似/相同的操作时，我发现几乎总是将它们作为list of tables 而不是单个对象进行操作；虽然这个解决方案在没有这个（需要一些调整）的情况下一般都可以工作，但我相信它让很多事情值得改变；

• 此外，我实际上认为长格式比列表列表更好，因为我们仍然可以轻松区分 id 和 sport；

• 您的预期输出在避免行之间重叠的方式上有些不一致；例如，"2000-01-14" 不在数据中，但它是end_date，这表明"2000-01-15" 已减少，因为下一行从该日期开始......但"2000-02-02" 有一个明显相似的开始（但相反的）原因；解决这个问题的一种方法是从end_date 中减去一个非常低的数字，这样 id/sport/date 范围就不会匹配多行，我说“低数字”而不是 1 因为Date-class 对象确实numeric，日期可以是小数：虽然不显示小数，但还是小数，比较Sys.Date()-0.1和dput(Sys.Date()-0.1)。

sports <- rbindlist(mget(ls(pattern = "DT_sport.*")), idcol = "sport")
sports[, sport := gsub("^DT_", "", sport) ] # primarily aesthetics
#     sport    id start_date   end_date
#    <char> <int>     <Date>     <Date>
# 1: sportA     1 2000-01-01 2000-02-03
# 2: sportA     1 2002-01-15 2003-03-01
# 3: sportA     2 2014-03-12 2014-04-03
# 4: sportA     2 2016-10-14 2017-05-19
# 5: sportB     1 2000-01-15 2000-02-01
# 6: sportB     1 2002-01-15 2006-03-19
# 7: sportB     2 2017-02-10 2017-02-20

我倾向于喜欢管道data.table，由于我仍在使用R-4.0.5，因此我使用magrittr::%>%；它不是严格要求的，但我觉得它有助于可读性（以及因此可维护性等）。 （我不知道这是否会在 R-4.1 的原生 |> 管道中轻松工作，因为这对 RHS 数据放置有更多限制。）

library(magrittr)
out <- sports[, {
  vec <- sort(unique(c(start_date, end_date)));
  .(sd = vec[-length(vec)], ed = vec[-1]);
}, by = .(id) ] %>%
  .[, ed := pmin(ed, shift(sd, type = "lead") - 1e-5, na.rm = TRUE), by = .(id) ] %>%
  sports[., on = .(id, start_date <= sd, end_date >= ed) ] %>%
  .[ !is.na(sport), ] %>%
  .[, val := 1L ] %>%
  dcast(id + start_date + end_date ~ sport, value.var = "val", fill = 0)
out
#       id start_date   end_date sportA sportB
#    <int>     <Date>     <Date>  <int>  <int>
# 1:     1 2000-01-01 2000-01-14      1      0
# 2:     1 2000-01-15 2000-01-31      1      1
# 3:     1 2000-02-01 2000-02-02      1      0
# 4:     1 2002-01-15 2003-02-28      1      1
# 5:     1 2003-03-01 2006-03-19      0      1
# 6:     2 2014-03-12 2014-04-02      1      0
# 7:     2 2016-10-14 2017-02-09      1      0
# 8:     2 2017-02-10 2017-02-19      1      1
# 9:     2 2017-02-20 2017-05-19      1      0

演练：

• 第一个sports[, {...}] 只产生可行的日期范围，每个id；它会产生比需要更多的东西，这些会在稍后被过滤掉；我将它与end_date 的轻微偏移结合起来，以便行是互斥的（上面的第二个注释）；虽然它们似乎间隔了一整天，但它们之间的间隔只有不到 1 秒；我添加secdiff 在这里显示：

  sports[, {
    vec <- sort(unique(c(start_date, end_date)));
    .(sd = vec[-length(vec)], ed = vec[-1]);
  }, by = .(id) ] %>%
    .[, ed := pmin(ed, shift(sd, type = "lead") - 1e-5, na.rm = TRUE), by = .(id) ] %>%
    .[, secdiff := c(as.numeric(sd[-1] - ed[-.N], units="secs"), NA), by = .(id) ]
  #        id         sd         ed   secdiff
  #     <int>     <Date>     <Date>     <num>
  #  1:     1 2000-01-01 2000-01-14 0.8640000
  #  2:     1 2000-01-15 2000-01-31 0.8640000
  #  3:     1 2000-02-01 2000-02-02 0.8640000
  #  4:     1 2000-02-03 2002-01-14 0.8640000  # will be empty post-join
  #  5:     1 2002-01-15 2003-02-28 0.8640000
  #  6:     1 2003-03-01 2006-03-19        NA
  #  7:     2 2014-03-12 2014-04-02 0.8640001
  #  8:     2 2014-04-03 2016-10-13 0.8640001  # will be empty post-join
  #  9:     2 2016-10-14 2017-02-09 0.8640001
  # 10:     2 2017-02-10 2017-02-19 0.8640001
  # 11:     2 2017-02-20 2017-05-19        NA
  

• 顺便说一句，上一个项目符号中sports[..] 的第一个操作是{-blockized 以略微提高效率，选择不sort(unique(c(start_date, end_date))) 两次;

• 在id 和日期范围上左加入sports；这将在sport 列中生成NA 值，该值指示以编程方式生成的日期范围（具有简单的日期序列）但未分配运动；这些不需要的行被!is.na(sport) 删除；

• 分配val := 1L纯粹是为了让我们在整形期间有一个值列；

• dcast 重塑并用0 填充缺失值。