有间隔的重叠日期间隔

Question

我一直在尝试寻找一个优雅的 data.table 解决方案（但如果有更好的解决方案，我会采用另一个）关于如何组合处理 (1) 嵌套间隔、(2) 具有不同优先级的间隔的日期间隔， (3) 有间隙的区间（参见示例输入对象）。我设法通过 foverlaps 和 shift 找到了一个几乎成功的解决方案。我希望避免 for/while 循环或笛卡尔积，它们都是低效且不优雅的，但肯定会起作用。我希望有更好的东西，因为这是我必须处理的常见数据问题。根据要求，我将展示我几乎有效的解决方案，如果这有用的话。

require(data.table)
# my data looks somewhat like this...
input <- data.table(
  person_ID = c(rep(98723, 4), rep(8534, 2), 11223, rep(22446, 2)),
  team = c(rep("A", 4), rep("B", 2), "A", "B", "A"),
  start_date = as.Date(c("2009-10-1", "2011-11-21", "2012-1-23", "2013-3-2", 
    "2009-11-14", "2010-1-1", "2012-1-2", "2011-2-2", "2012-4-3")),
  end_date = as.Date(c("2010-5-23", NA, "2015-01-02", "2013-3-2", "2009-12-31", 
    "2010-3-1", "2015-03-22", "2016-1-2", "2014-9-30")))
team_priority <- data.table(team = c("A", "B"), priority = c(1, 2))
input[team_priority, priority := i.priority, on = "team"]

输入

  person_ID team start_date   end_date priority
1:     98723    A 2009-10-01 2010-05-23        1
2:     98723    A 2011-11-21       <NA>        1
3:     98723    A 2012-01-23 2015-01-02        1
4:     98723    A 2013-03-02 2013-03-02        1
5:      8534    B 2009-11-14 2009-12-31        2
6:      8534    B 2010-01-01 2010-03-01        2
7:     11223    A 2012-01-02 2015-03-22        1
8:     22446    B 2011-02-02 2016-01-02        2
9:     22446    A 2012-04-03 2014-09-30        1
# problem 1: gap in teams prevents simple min/max solution (see person_ID == 98723)

# problem 2: teams have priorities, so if team B is inside of time interval assigned to time A,
# then we need the records to reflect the following:
# team B -> team A -> team B based on when teams A & B start/stop (see person_ID == 22446)

# NOTE: problem 1 and 2 can be combined (I am trying to fix bad data entry)

# I have to assign priorities based on team involvement (A > B > C, etc)
output <- data.table(
  person_ID = c(rep(98723, 4), rep(8534, 2), 11223, rep(22446, 3)),
  team = c(rep("A", 4), rep("B", 2), "A", "B", "A", "B"),
  start_date = as.Date(c("2009-10-1", "2011-11-21", "2012-1-23", "2013-3-2", 
    "2009-11-14", "2010-1-1", "2012-1-2", "2011-2-2",  "2012-4-3", "2014-10-1")),
  end_date = as.Date(c("2010-5-23", NA, "2015-01-02", "2013-3-2", "2009-12-31", 
    "2010-3-1", "2015-03-22", "2012-4-2", "2014-9-30", "2016-1-2")),
  group_id = c(1, rep(2, 3), rep(4, 2), 5, 6, 7, 8))

输出

    person_ID team start_date   end_date group_id
 1:     98723    A 2009-10-01 2010-05-23        1
 2:     98723    A 2011-11-21       <NA>        2
 3:     98723    A 2012-01-23 2015-01-02        2
 4:     98723    A 2013-03-02 2013-03-02        2
 5:      8534    B 2009-11-14 2009-12-31        4
 6:      8534    B 2010-01-01 2010-03-01        4
 7:     11223    A 2012-01-02 2015-03-22        5
 8:     22446    B 2011-02-02 2012-04-02        6
 9:     22446    A 2012-04-03 2014-09-30        7
10:     22446    B 2014-10-01 2016-01-02        8

简单的 MIN/MAX 解决方案行不通！我不反对单独处理嵌套间隔（请参阅 person_id == 22446），但这确实是我在同时实现所有其他目标的同时无法弄清楚的部分。

Answer 1

可能还有其他方法可以更有效地做到这一点。但我认为这总比没有好。如果有人带来更好、更棒的东西，我会很乐意选择他们的回应。也许我应该把它分成几个部分来让它更可口，但如果我知道是哪些部分，我就不必一开始就问了。 :) 无论如何，这是我的解决方案，我会使其更加完善，因为它将包含在我的 R 包中，但这至少以我迄今为止测试的所有方式回答了这个问题。

我不得不打破我的愿望，因为其中的一部分有 for 循环，其中一部分使用了笛卡尔积。我想不出办法来避免它们（还）。

overlap_combine <- 
  function(overlap_dt, id_cols, team_col, start_col, end_col, overlap_int = 1L, 
           replace_blanks = Sys.Date(), priority_col = "priority") {
    setorderv(overlap_dt, c(id_cols, team_col, start_col))
    overlap_dt[, end_col := get(end_col) + overlap_int]
    sd_cols <- c(start_col, "end_col")
    # foverlaps cannot deal with blanks
    overlap_dt[is.na(end_col), end_col := replace_blanks]
    # note: if end_col becomes < start_col due to overlap_int,
    # we assign end_col <- start_col
    overlap_dt[end_col - get(start_col) < 0, end_col := start_col]
    overlap_dt[, index := .I]
    setnames(overlap_dt, start_col, "start_date")
    # setnames(overlap_dt, team_col, "team")
    # finding overlapping combinations via vectors of indices ---
    c_overlap <- 
      overlap_dt[overlap_dt[, unique(.SD), .SDcols = 
                              c(id_cols, team_col, "start_date", "end_col", "index")], 
                 on = c(id_cols, team_col), allow.cartesian = TRUE]
    c_overlap <- c_overlap[i.index != index]
    c_overlap[between(i.start_date, start_date, end_col) |
                between(i.end_col, start_date, end_col), 
              ovr_vec := list(list(unique(c(index, i.index)))), 
              by = c(id_cols, team_col, "start_date")]
    ovr_l <- c_overlap[, ovr_vec]
    ovr_l <- Filter(Negate(function(x) is.null(unlist(x))), ovr_l)
    ovr_l <- unique(ovr_l)
    # find list of reduced vectors which we need to MIN/MAX ---
    ovr_red_l <- list()
    for (i in seq_along(ovr_l)) {
      tmp_inter <- unique(unlist(sapply(
        ovr_l,
        FUN = function(x) {
          if (length(intersect(unlist(x), unlist(ovr_l[i]))) > 0) {
            result <- union(unlist(x), unlist(ovr_l[i]))
            return(result)
          } else {
            return(ovr_l[i])
          }
        }
      )))
      ovr_red_l[[i]] <- sort(tmp_inter)
    }
    ovr_red_l <- unique(ovr_red_l)

    for (i in seq(ovr_red_l)) {
      setkey(overlap_dt, index)[ovr_red_l[[i]],
                                c("start_date", "end_date", "end_col") := 
                                  list(min(start_date), max(end_date), max(end_col))]
    }
    overlap_dt[, index := NULL]
    overlap_dt <- unique(overlap_dt)
    setkeyv(overlap_dt, c(id_cols, "start_date"))
    # figure out which intervals are nested, separate them out & deal with them
    overlap_dt[, index := .I]
    overlap_dt[, prior_shift := priority - shift(priority, n = 1), by = id_cols]
    overlap_dt[between(shift(start_date, n = 1), start_date, end_col), ovr_shift := 1, by = id_cols]
    overlap_dt[shift(ovr_shift) == 1 & prior_shift < 0, nested_ovr := 1]
    overlap_dt[index %in% overlap_dt[nested_ovr == 1, index - 1], nested_ovr := 1]
        overlap_nested_dt <- overlap_dt[nested_ovr == 1]
    overlap_dt <- overlap_dt[is.na(nested_ovr)]
    nested_melt_dt <- 
      melt(overlap_nested_dt, id.vars = c(id_cols, team_col, priority_col), 
           measure.vars = c("start_date", "end_col"), value.name = "date_value")
    setkey(nested_melt_dt, person_ID, date_value)
    nested_melt_dt[, boundaries := cumsum(ifelse(variable == "start_date", 1, -1))]
    nested_melt_dt[boundaries==1 & variable == "start_date", bound_ok := 1]
    nested_melt_dt[boundaries==0 & variable == "end_col", bound_ok := 1]
    # create new records that need to be added ---
    add_dt <- nested_melt_dt[0, ]
    if (nrow(nested_melt_dt)>0) {
      for (i in 1:nrow(nested_melt_dt))
        if (nested_melt_dt[i, is.na(bound_ok)]) {
          if (nested_melt_dt[i, variable] == "start_date") {
            add_dt <- rbindlist(list(add_dt, 
                                     data.table(nested_melt_dt[i, person_ID],
                                                nested_melt_dt[i-1, team],
                                                nested_melt_dt[i-1, priority],
                                                "end_col", 
                                                nested_melt_dt[i, date_value - 1],
                                                NA, NA)))
          } else if (nested_melt_dt[i, variable] == "end_col") {
            add_dt <- rbindlist(list(add_dt, 
                                     data.table(nested_melt_dt[i, person_ID],
                                                nested_melt_dt[i+1, team],
                                                nested_melt_dt[i+1, priority],
                                                "start_date", 
                                                nested_melt_dt[i, date_value + 1],
                                                NA, NA)))
          }
        }
    }
    # add new records back in
    nested_melt_dt <- rbindlist(list(nested_melt_dt, add_dt))
    setkeyv(nested_melt_dt, c(id_cols, "date_value"))
    nested_melt_dt[, c("bound_ok", "boundaries") := NULL]
    nested_melt_dt[, date_group := .I, by = id_cols]
    nested_melt_dt[variable == "end_col", date_group := date_group - 1L]
    nested_melt_dt <-
      dcast(nested_melt_dt, paste0(paste(id_cols, sep = "+"), "+", team_col, "+",  
                                   priority_col, "+", "date_group ~ variable"), value.var = "date_value")
    nested_melt_dt[, end_date := end_col]
    nested_melt_dt[, c("date_group") := NULL]
    overlap_dt[,  c("index", "prior_shift", "ovr_shift", "nested_ovr") := NULL]
    overlap_dt <- rbindlist(list(overlap_dt, nested_melt_dt), use.names = TRUE)
    setorderv(overlap_dt, c(id_cols, start_col, team_col))
    return(overlap_dt)
  }
overlap_combine(overlap_dt = copy(input), id_cols = "person_ID", 
                team_col = "team", start_col = "start_date", end_col = "end_date", 
                overlap_int = 1L, replace_blanks = Sys.Date() + 1e3, 
                priority_col = "priority")

函数输出

   person_ID team start_date   end_date priority    end_col
1:      8534    B 2009-11-14 2010-03-01        2 2010-03-02
2:     11223    A 2012-01-02 2015-03-22        1 2015-03-23
3:     22446    B 2011-02-02 2012-04-02        2 2012-04-02
4:     22446    A 2012-04-03 2014-10-01        1 2014-10-01
5:     22446    B 2014-10-02 2016-01-03        2 2016-01-03
6:     98723    A 2009-10-01 2010-05-23        1 2010-05-24
7:     98723    A 2011-11-21       <NA>        1 2018-12-17