Создать таблицу всех возможных временных интервалов на основе существующих интервалов

Question

Две (массивные) таблицы в настоящее время имеют даты «от» и «до». Я хочу объединить две таблицы, чтобы у меня был каждый возможный набор дат «от» и «до», которые могут быть сформированы из исходных дат. Например, если int1 == 0: 6 и int2 == 3: 9, то я хочу три интервала: 0: 2, 3: 6, 7: 9.

Я пробовал фаверлапы и вручную создавалвсе возможные интервалы дат, а затем объединить данные в эту таблицу. Код ниже показывает эти неудачные попытки с игрушечными данными. Ожидаемый результат ниже должен прояснить, чего я хотел бы достичь.

Существующие таблицы огромны (миллионы идентификаторов каждая с несколькими наборами дат для каждого идентификатора).

В настоящее время я пытаюсь использовать третий метод ... создать пустую таблицу с каждым идентификатором, имеющим 1 день (как день, так и день) на строку. Проблема этого метода в том, что он безумно медленный, учитывая количество идентификаторов и годы, которые мне нужно покрыть. Прошло уже почти 20 часов, и моя базовая таблица все еще создается. После этого планируется объединение существующих таблиц с использованием foverlaps.

Я теряю голову из-за этой проблемы и буду благодарен за любую помощь.

# load packages
library(data.table)
library(lubridate)
# create data
dt1<- data.table(id = rep(1111, 4),
           from_date = as.Date(c("2016-01-01", "2016-03-31","2016-09-02", "2016-09-03")), 
           to_date = as.Date(c("2016-03-15", "2016-09-01", "2016-09-02", "2016-12-15")), 
           progs = c("a1", "b1", "c1", "d1"))
setkey(dt1, id, from_date, to_date)    

dt2<- data.table(id = rep(1111, 4),
           from_date = as.Date(c("2016-02-01", "2016-04-01","2016-11-01", "2016-12-01")), 
           to_date = as.Date(c("2016-02-28", "2016-09-30", "2016-11-30", "2016-12-31")), 
           progs = c("a2", "b2", "c2", "d2"))
setkey(dt2, id, from_date, to_date)    

# expected (hoped for) output
id  from_date   to_date progs1  prog2
1111    1/1/2016    1/31/2016   a1  NA
1111    2/1/2016    2/28/2016   a1  a2
1111    2/29/2016   3/15/2016   a1  NA
1111    3/31/2016   3/31/2016   b1  NA
1111    4/1/2016    9/1/2016    b1  b2
1111    9/2/2016    9/2/2016    c1  b2
1111    9/3/2016    9/30/2016   d1  b2
1111    10/1/2016   10/31/2016  NA  d1
1111    11/1/2016   11/30/2016  d1  c2
1111    12/1/2016   12/15/2016  d1  NA
1111    12/16/2016  12/31/2016  NA  d2

# failed attempt #1: using foverlaps
overlaps <- foverlaps(x=dt1, y=dt2, 
                by.x = c("id", "from_date", "to_date"),
                by.y = c("id", "from_date", "to_date"), 
                type = "any", 
                mult ="all")
# this does not give every time interval    

# failed attempt #2... super convoluted method
# try to make every possible time interval ----
dt <- rbind(dt1[, .(id, from_date)], dt2[, .(id, from_date)]) 
dt.temp <- rbind(dt1[, .(id, to_date)], dt2[, .(id, to_date)]) # get table with to_dates
setnames(dt.temp, "to_date", "from_date") 
dt <- rbind(dt, dt.temp)
rm(dt.temp)
dt <- unique(dt)
setorder(dt, -from_date)
dt[, to_date := as.Date(c(NA, from_date[-.N]), origin = "1970-01-01"), by = "id"]
setorder(dt, from_date)
dt <- dt[!is.na(to_date)] # the last 'from_date' is actually the final to_date, so it doesn't begin a time interval
dt[, counter := 1:.N, by = id] # create indicator so we can know which interval is the first interval for each id
dt[counter != 1, from_date := as.integer(from_date + 1)] # to prevent overlap with previous interval
dt[, counter := NULL]
setkey(dt, id, from_date, to_date)    

# merge on dt1 ----
dt <- foverlaps(dt, dt1, type = "any", mult = "all")
dt[, from_date := i.from_date] # when dt1 didn't match, the from_date is NA. fill with i.from_date
dt[, to_date := i.to_date] # when dt2 didn't match, the from_date is NA. fill with i.from_date
dt[, c("i.from_date", "i.to_date") := NULL] # no longer needed
setkey(dt, id, from_date, to_date)    

# merge on dt2 ----
dt <- foverlaps(dt, dt2, type = "any", mult = "all")
dt[, from_date := i.from_date] # when dt2 didn't match, the from_date is NA. fill with i.from_date
dt[, to_date := i.to_date] # when dt2 didn't match, the from_date is NA. fill with i.from_date
dt[, c("i.from_date", "i.to_date") := NULL] # no longer needed
setkey(dt, id, from_date, to_date)    

setnames(dt, c("i.progs", "progs"), c("progs1", "progs2"))    

# Collapse data if dates are contiguous and data are the same ----
# Create unique ID for data chunks ----
dt[, group := .GRP, by = c("id", "progs1", "progs2")] # create group id
dt[, group := cumsum( c(0, diff(group)!=0) )] # in situation like a:a:a:b:b:b:b:a:a:a, want to distinguish first set of "a" from second set of "a"    

# Create unique ID for contiguous times within a given data chunk ----
setkey(dt, id, from_date)
dt[, prev_to_date := c(NA, to_date[-.N]), by = "group"]
dt[, diff.prev := from_date - prev_to_date] # difference between from_date & prev_to_date will be 1 (day) if they are contiguous
dt[diff.prev != 1, diff.prev := NA] # set to NA if difference is not 1 day, i.e., it is not contiguous, i.e., it starts a new contiguous chunk
dt[is.na(diff.prev), contig.id := .I] # Give a unique number for each start of a new contiguous chunk (i.e., section starts with NA)
setkey(dt, group, from_date) # need to order the data so the following line will work.
dt[, contig.id  := contig.id[1], by=  .( group , cumsum(!is.na(contig.id))) ] # fill forward by group
dt[, c("prev_to_date", "diff.prev") := NULL] # drop columns that were just intermediates    

# Collapse rows where data chunks are constant and time is contiguous ----      
dt[, from_date := min(from_date), by = c("group", "contig.id")]
dt[, to_date := max(to_date), by = c("group", "contig.id")]
dt[, c("group", "contig.id") := NULL]
dt <- unique(dt)      

# the end result is incorrect table
id  from_date   to_date progs2  progs1
1111    1/1/2016    2/28/2016   a2  a1
1111    2/29/2016   3/15/2016   NA  a1
1111    3/16/2016   3/31/2016   NA  b1
1111    4/1/2016    9/1/2016    b2  b1
1111    9/2/2016    9/2/2016    b2  c1
1111    9/3/2016    9/30/2016   b2  d1
1111    10/1/2016   11/30/2016  c2  d1
1111    12/1/2016   12/15/2016  d2  d1
1111    12/16/2016  12/31/2016  d2  NA

См. Ожидаемые результаты и реальные результаты выше ... Я не мог отобразить их аккуратнов таблице здесь.

Answer 1

Хотя @GenericNameNumber ответил на этот вопрос, я нашел другой способ решения моей проблемы, который может быть проще для понимания (хотя он неэффективен по сравнению с принятым ответом). Это займет всего несколько секунд, если вы хотите попробовать.

Если у кого-то есть идея простого, но эффективного кода, я весь в ушах!

# load packages ----
  library(data.table)    

# create data ----
  rm(list=ls())
  dt1<- data.table(id = rep(1111, 4),
                     from_date = as.Date(c("2016-01-01", "2016-03-31","2016-09-02", "2016-09-03")), 
                     to_date = as.Date(c("2016-03-15", "2016-09-01", "2016-09-02", "2016-12-15")), 
                     progs = c("a1", "b1", "c1", "d1"))
  setkey(dt1, id, from_date, to_date)    

  dt2<- data.table(id = rep(1111, 4),
                     from_date = as.Date(c("2016-02-01", "2016-04-01","2016-11-01", "2016-12-01")), 
                     to_date = as.Date(c("2016-02-28", "2016-09-30", "2016-11-30", "2016-12-31")), 
                     progs = c("a2", "b2", "c2", "d2"))
  setkey(dt2, id, from_date, to_date)        



# Create table with 'intervals' of 1 day duration ----
  dt <- rbind(dt1[,1:3], dt2[,1:3])
  dt[, reps := (to_date - from_date) + 1] # identify the number of days per interval (add one because dates are inclusive)
  dt <- dt[rep(1:.N,reps)] # replicate each row to make 1 row per day of each interval
  dt[,counter:=(1:.N-1),by=c("id", "from_date")] # add a counter (aka index number) for each from date per id
  dt[, c("from_date", "to_date") := from_date + counter] # create intervals of 1 day
  dt[, c("reps", "counter") := NULL] # drop columns no longer needed
  dt <- unique(dt) # de-duplicate rows so each day only appears once
  setkey(dt, id, from_date)    

# merge on dt1 ----
    dt <- foverlaps(x=dt, y=dt1, 
                    by.x = c("id", "from_date", "to_date"), 
                    by.y = c("id", "from_date", "to_date"), 
                    type = "any", mult = "all")
    dt <- dt[, c("from_date", "to_date") := NULL] # drop intervals from dt1 because will use the intervals from dt for merging on dt2 below
    setnames(dt, c("i.from_date", "i.to_date"), c("from_date", "to_date") )
    setcolorder(dt, c("id", "from_date", "to_date"))
    setkey(dt, id, from_date, to_date)    

# merge on dt2 ----
    dt <- foverlaps(x=dt, y=dt2, 
                    by.x = c("id", "from_date", "to_date"), 
                    by.y = c("id", "from_date", "to_date"), 
                    type = "any", mult = "all")
    dt <- dt[, c("from_date", "to_date") := NULL] # drop intervals from dt2 because will use the intervals from dt for merging on dt2 below
    setnames(dt, c("i.from_date", "i.to_date"), c("from_date", "to_date") )
    setcolorder(dt, c("id", "from_date", "to_date"))
    setkey(dt, id, from_date, to_date)       

# Collapse data if dates are contiguous and data are the same ----
    # Create unique ID for data chunks ----
    setnames(dt, c("i.progs", "progs"), c("progs1", "progs2"))
    dt[, group := .GRP, by = c("id", "progs1", "progs2")] # create group id
    dt[, group := cumsum( c(0, diff(group)!=0) )] # in situation like a:a:a:b:b:b:b:a:a:a, want to distinguish first set of "a" from second set of "a"    

    # Create unique ID for contiguous times within a given data chunk ----
    setkey(dt, id, from_date)
    dt[, prev_to_date := c(NA, to_date[-.N]), by = "group"]
    dt[, diff.prev := from_date - prev_to_date] # difference between from_date & prev_to_date will be 1 (day) if they are contiguous
    dt[diff.prev != 1, diff.prev := NA] # set to NA if difference is not 1 day, i.e., it is not contiguous, i.e., it starts a new contiguous chunk
    dt[is.na(diff.prev), contig.id := .I] # Give a unique number for each start of a new contiguous chunk (i.e., section starts with NA)
    setkey(dt, group, from_date) # need to order the data so the following line will work.
    dt[, contig.id  := contig.id[1], by=  .( group , cumsum(!is.na(contig.id))) ] # fill forward by group
    dt[, c("prev_to_date", "diff.prev") := NULL] # drop columns that were just intermediates    

    # Collapse rows where data chunks are constant and time is contiguous ----      
    dt[, from_date := min(from_date), by = c("group", "contig.id")]
    dt[, to_date := max(to_date), by = c("group", "contig.id")]
    dt[, c("group", "contig.id") := NULL]
    dt <- unique(dt)      

Answer 2

Не на 100% уверен в том, что вы пытаетесь сделать, однако, есть функция, называемая скрещиванием, которая может получить все перестановки по нескольким векторам.

> library(tidyr)
> a <- c("2016-01-01", "2016-03-31","2016-09-02", "2016-09-03")
> b <- c("2016-03-15", "2016-09-01", "2016-09-02", "2016-12-15")
> c <- rep(1111, 4)
> crossing(a, b,c)

# A tibble: 16 x 3
   a          b              c
   <chr>      <chr>      <dbl>
 1 2016-01-01 2016-03-15  1111
 2 2016-01-01 2016-09-01  1111
 3 2016-01-01 2016-09-02  1111
 4 2016-01-01 2016-12-15  1111
 5 2016-03-31 2016-03-15  1111
 6 2016-03-31 2016-09-01  1111
 7 2016-03-31 2016-09-02  1111
 8 2016-03-31 2016-12-15  1111
 9 2016-09-02 2016-03-15  1111
10 2016-09-02 2016-09-01  1111
11 2016-09-02 2016-09-02  1111
12 2016-09-02 2016-12-15  1111
13 2016-09-03 2016-03-15  1111
14 2016-09-03 2016-09-01  1111
15 2016-09-03 2016-09-02  1111
16 2016-09-03 2016-12-15  1111

Будет ли это что-то вродеесли чего ты пытаешься достичь?

Answer 3

Это не красиво, но вот гибридное решение tidyverse / data.table, которое работает. Он разбивает вещи на компоненты:

1. Полное объединение всех возможных комбинаций данных между dt1 и dt2 (по идентификатору).
2. Определение типа перекрытия, видимого в каждой строке (есть7 перестановок) и установите перекрывающиеся даты ( _o суффикс).
3. Для типов перекрытия требуется различное количество строк, чтобы отобразить объединенные даты начала и окончания. Разверните фрейм данных, чтобы указать количество строк, необходимое для каждого типа перекрытия.
4. Создайте объединенные даты ( _c суффикс) на основе типа перекрытия.
5. Определитек какому набору данных применяется комбинированный диапазон дат ( enroll_type = dt1, dt2 или оба), а затем отбрасывает строки из одного источника (dt1 / dt2), которые полностью охватываются enroll_type типа 'both'.
6. Из-за сортировки по ID + дате ранее вы можете использовать опережение / отставание для усечения комбинированных дат, чтобы ни одна дата не покрывалась более чем одной startdate_c - enddate_c span.

Возможно, вы найдете способы сделать это более элегантным и эффективным.

      library(data.table)
    library(tidyr)

    #create test data ----
    dt1<- data.table(id = rep(1111, 4),
                     from_date = as.Date(c("2016-01-01", "2016-03-31","2016-09-02", "2016-09-03")), 
                     to_date = as.Date(c("2016-03-15", "2016-09-01", "2016-09-02", "2016-12-15")), 
                     progs = c("a1", "b1", "c1", "d1"))
    setkey(dt1, id, from_date, to_date)    

    dt2<- data.table(id = rep(1111, 4),
                     from_date = as.Date(c("2016-02-01", "2016-04-01","2016-11-01", "2016-12-01")), 
                     to_date = as.Date(c("2016-02-28", "2016-09-30", "2016-11-30", "2016-12-31")), 
                     progs = c("a2", "b2", "c2", "d2"))
    setkey(dt2, id, from_date, to_date)    

    # create all possible matches between time segments ----
    dt <- setDT(mutate(dt1) %>% full_join(., dt2, by = c("id")) )
    #dt[, c("progs.y", "progs.x") := NULL]
    #setnames(dt, names(dt), c("id", "startdate_dt1", "enddate_dt1", "startdate_dt2", "enddate_dt2"))
    setnames(dt, names(dt), c("id", "startdate_dt1", "enddate_dt1", "progs1", "startdate_dt2", "enddate_dt2", "progs2"))

    # set up intervals ----
    temp <- dt %>%
      mutate(overlap_type = case_when(
        # First ID the non-matches
        is.na(startdate_dt1) | is.na(startdate_dt2) ~ 0,
        # Then figure out which overlapping date comes first
        # Exactly the same dates
        startdate_dt1 == startdate_dt2 & enddate_dt1 == enddate_dt2 ~ 1,
        # dt1 before dt2 (or exactly the same dates)
        startdate_dt1 <= startdate_dt2 & startdate_dt2 <= enddate_dt1 & 
          enddate_dt1 <= enddate_dt2 ~ 2,
        # dt2 before dt1
        startdate_dt2 <= startdate_dt1 & startdate_dt1 <= enddate_dt2 & 
          enddate_dt2 <= enddate_dt1 ~ 3,
        # dt2 dates competely within dt1 dates or vice versa
        startdate_dt2 >= startdate_dt1 & enddate_dt2 <= enddate_dt1 ~ 4,
        startdate_dt1 >= startdate_dt2 & enddate_dt1 <= enddate_dt2 ~ 5,
        # dt1 coverage only before dt2 (or dt2 only after dt1)
        startdate_dt1 < startdate_dt2 & enddate_dt1 < startdate_dt2 ~ 6,
        # dt1 coverage only after dt2 (or dt2 only before dt1)
        startdate_dt1 > enddate_dt2 & enddate_dt1 > enddate_dt2 ~ 7,
        # Any rows that are left
        TRUE ~ 8),
        # Calculate overlapping dates
        startdate_o = as.Date(case_when(
          overlap_type %in% c(1, 2, 4) ~ startdate_dt2,
          overlap_type %in% c(3, 5) ~ startdate_dt1), origin = "1970-01-01"),
        enddate_o = as.Date(ifelse(overlap_type %in% c(1:5),
                                   pmin(enddate_dt2, enddate_dt1),
                                   NA), origin = "1970-01-01"),
        # Need to duplicate rows to separate out non-overlapping dt1 and dt2 periods
        repnum = case_when(
          overlap_type %in% c(2:5) ~ 3,
          overlap_type %in% c(6:7) ~ 2,
          TRUE ~ 1)
      ) %>%
      select(id, startdate_dt1, enddate_dt1, startdate_dt2, enddate_dt2, 
             startdate_o, enddate_o, overlap_type, repnum) %>%
      arrange(id, startdate_dt1, startdate_dt2, startdate_o, 
              enddate_dt1, enddate_dt2, enddate_o)


    ### Expand out rows to separate out overlaps ----
    temp_ext <- temp[rep(seq(nrow(temp)), temp$repnum), 1:ncol(temp)]

    ## process expanded ----
    temp_ext <- temp_ext %>% 
      group_by(id, startdate_dt1, enddate_dt1, startdate_dt2, enddate_dt2) %>% 
      mutate(rownum_temp = row_number()) %>%
      ungroup() %>%
      arrange(id, startdate_dt1, enddate_dt1, startdate_dt2, enddate_dt2, startdate_o, 
              enddate_o, overlap_type, rownum_temp) %>%
      mutate(
        # Remove non-overlapping dates
        startdate_dt1 = as.Date(ifelse((overlap_type == 6 & rownum_temp == 2) | 
                                       (overlap_type == 7 & rownum_temp == 1), 
                                     NA, startdate_dt1), origin = "1970-01-01"), 
        enddate_dt1 = as.Date(ifelse((overlap_type == 6 & rownum_temp == 2) | 
                                     (overlap_type == 7 & rownum_temp == 1), 
                                   NA, enddate_dt1), origin = "1970-01-01"),
        startdate_dt2 = as.Date(ifelse((overlap_type == 6 & rownum_temp == 1) | 
                                       (overlap_type == 7 & rownum_temp == 2), 
                                     NA, startdate_dt2), origin = "1970-01-01"), 
        enddate_dt2 = as.Date(ifelse((overlap_type == 6 & rownum_temp == 1) | 
                                     (overlap_type == 7 & rownum_temp == 2), 
                                   NA, enddate_dt2), origin = "1970-01-01")) %>%
      distinct(id, startdate_dt1, enddate_dt1, startdate_dt2, enddate_dt2, startdate_o, 
               enddate_o, overlap_type, rownum_temp, .keep_all = TRUE) %>%
      # Remove first row if start dates are the same or dt1 is only one day
      filter(!(overlap_type %in% c(2:5) & rownum_temp == 1 & 
                 (startdate_dt1 == startdate_dt2 | startdate_dt1 == enddate_dt1))) %>%
      # Remove third row if enddates are the same
      filter(!(overlap_type %in% c(2:5) & rownum_temp == 3 & enddate_dt1 == enddate_dt2))

    ##  Calculate the finalized date columms----
    ### Calculate finalized date columns
    temp_ext <- temp_ext %>%
      # Set up combined dates
      mutate(
        # Start with rows with only dt1 or dt2, or when both sets of dates are identical
        startdate_c = as.Date(
          case_when(
            (!is.na(startdate_dt1) & is.na(startdate_dt2)) | overlap_type == 1 ~ startdate_dt1,
            !is.na(startdate_dt2) & is.na(startdate_dt1) ~ startdate_dt2), origin = "1970-01-01"),
        enddate_c = as.Date(
          case_when(
            (!is.na(enddate_dt1) & is.na(enddate_dt2)) | overlap_type == 1 ~ enddate_dt1,
            !is.na(enddate_dt2) & is.na(enddate_dt1) ~ enddate_dt2), origin = "1970-01-01"),
        # Now look at overlapping rows and rows completely contained within the other data's dates
        startdate_c = as.Date(
          case_when(
            overlap_type %in% c(2, 4) & rownum_temp == 1 ~ startdate_dt1,
            overlap_type %in% c(3, 5) & rownum_temp == 1 ~ startdate_dt2,
            overlap_type %in% c(2:5) & rownum_temp == 2 ~ startdate_o,
            overlap_type %in% c(2:5) & rownum_temp == 3 ~ enddate_o + 1,
            TRUE ~ startdate_c), origin = "1970-01-01"),
        enddate_c = as.Date(
          case_when(
            overlap_type %in% c(2:5) & rownum_temp == 1 ~ lead(startdate_o, 1) - 1,
            overlap_type %in% c(2:5) & rownum_temp == 2 ~ enddate_o,
            overlap_type %in% c(2, 5) & rownum_temp == 3 ~ enddate_dt2,
            overlap_type %in% c(3, 4) & rownum_temp == 3 ~ enddate_dt1,
            TRUE ~ enddate_c), origin = "1970-01-01"),
        # Deal with the last line for each person if it's part of an overlap
        startdate_c = as.Date(ifelse((id != lead(id, 1) | is.na(lead(id, 1))) &
                                       overlap_type %in% c(2:5) & 
                                       enddate_dt1 != enddate_dt2, 
                                     lag(enddate_o, 1) + 1, 
                                     startdate_c), origin = "1970-01-01"),
        enddate_c = as.Date(ifelse((id != lead(id, 1) | is.na(lead(id, 1))) &
                                     overlap_type %in% c(2:5), 
                                   pmax(enddate_dt1, enddate_dt2, na.rm = TRUE), 
                                   enddate_c), origin = "1970-01-01")
      ) %>%
      arrange(id, startdate_c, enddate_c, startdate_dt1, startdate_dt2, 
              enddate_dt1, enddate_dt2, overlap_type) %>%
      mutate(
        # Identify which type of enrollment this row represents
        enroll_type = 
          case_when(
            (overlap_type == 2 & rownum_temp == 1) | 
              (overlap_type == 3 & rownum_temp == 3) |
              (overlap_type == 6 & rownum_temp == 1) | 
              (overlap_type == 7 & rownum_temp == 2) |
              (overlap_type == 4 & rownum_temp %in% c(1, 3)) |
              (overlap_type == 0 & is.na(startdate_dt2)) ~ "dt1",
            (overlap_type == 3 & rownum_temp == 1) | 
              (overlap_type == 2 & rownum_temp == 3) |
              (overlap_type == 6 & rownum_temp == 2) | 
              (overlap_type == 7 & rownum_temp == 1) | 
              (overlap_type == 5 & rownum_temp %in% c(1, 3)) |
              (overlap_type == 0 & is.na(startdate_dt1)) ~ "dt2",
            overlap_type == 1 | (overlap_type %in% c(2:5) & rownum_temp == 2) ~ "both",
            TRUE ~ "x"
          ),
        # Drop rows from enroll_type == h/m when they are fully covered by an enroll_type == b
        drop = 
          case_when(
            id == lag(id, 1) & !is.na(lag(id, 1)) & 
              startdate_c == lag(startdate_c, 1) & !is.na(lag(startdate_c, 1)) &
              enddate_c >= lag(enddate_c, 1) & !is.na(lag(enddate_c, 1)) & 
              # Fix up quirk from dt1 data where two rows present for the same day
              !(lag(enroll_type, 1) != "dt2" & lag(enddate_dt1, 1) == lag(startdate_dt1, 1)) &
              enroll_type != "both" ~ 1,
            id == lead(id, 1) & !is.na(lead(id, 1)) & 
              startdate_c == lead(startdate_c, 1) & !is.na(lead(startdate_c, 1)) &
              enddate_c <= lead(enddate_c, 1) & !is.na(lead(enddate_c, 1)) & 
              # Fix up quirk from dt1 data where two rows present for the same day
              !(lead(enroll_type, 1) != "dt2" & lead(enddate_dt1, 1) == lead(startdate_dt1, 1)) &
              enroll_type != "both" & lead(enroll_type, 1) == "both" ~ 1,
            # Fix up other oddities when the date range is only one day
            id == lag(id, 1) & !is.na(lag(id, 1)) & 
              startdate_c == lag(startdate_c, 1) & !is.na(lag(startdate_c, 1)) &
              startdate_c == enddate_c & !is.na(startdate_c) & 
              ((enroll_type == "dt2" & lag(enroll_type, 1) %in% c("both", "dt1")) |
                 (enroll_type == "dt1" & lag(enroll_type, 1) %in% c("both", "dt2"))) ~ 1,
            id == lag(id, 1) & !is.na(lag(id, 1)) & 
              startdate_c == lag(startdate_c, 1) & !is.na(lag(startdate_c, 1)) &
              startdate_c == enddate_c & !is.na(startdate_c) &
              startdate_dt1 == lag(startdate_dt1, 1) & enddate_dt1 == lag(enddate_dt1, 1) &
              !is.na(startdate_dt1) & !is.na(lag(startdate_dt1, 1)) &
              enroll_type != "both" ~ 1,
            id == lead(id, 1) & !is.na(lead(id, 1)) & 
              startdate_c == lead(startdate_c, 1) & !is.na(lead(startdate_c, 1)) &
              startdate_c == enddate_c & !is.na(startdate_c) &
              ((enroll_type == "dt2" & lead(enroll_type, 1) %in% c("both", "dt1")) |
                 (enroll_type == "dt1" & lead(enroll_type, 1) %in% c("both", "dt2"))) ~ 1,
            # Drop rows where the enddate_c < startdate_c due to 
            # both data sources' dates ending at the same time
            enddate_c < startdate_c ~ 1,
            TRUE ~ 0
          )
      ) %>%
      filter(drop == 0 | is.na(drop)) %>%
      # Truncate remaining overlapping end dates
      mutate(enddate_c = as.Date(
        ifelse(id == lead(id, 1) & !is.na(lead(startdate_c, 1)) &
                 startdate_c < lead(startdate_c, 1) &
                 enddate_c >= lead(enddate_c, 1),
               lead(startdate_c, 1) - 1,
               enddate_c),
        origin = "1970-01-01")
      ) %>%
      select(-drop, -repnum, -rownum_temp) %>%
      # With rows truncated, now additional rows with enroll_type == h/m that 
      # are fully covered by an enroll_type == b
      # Also catches single day rows that now have enddate < startdate
      mutate(
        drop = case_when(
          id == lag(id, 1) & startdate_c == lag(startdate_c, 1) &
            enddate_c == lag(enddate_c, 1) & lag(enroll_type, 1) == "both" & 
            enroll_type != "both" ~ 1,
          id == lead(id, 1) & startdate_c == lead(startdate_c, 1) &
            enddate_c <= lead(enddate_c, 1) & lead(enroll_type, 1) == "both" ~ 1,
          id == lag(id, 1) & startdate_c >= lag(startdate_c, 1) &
            enddate_c <= lag(enddate_c, 1) & enroll_type != "both" &
            lag(enroll_type, 1) == "both" ~ 1,
          id == lead(id, 1) & startdate_c >= lead(startdate_c, 1) &
            enddate_c <= lead(enddate_c, 1) & enroll_type != "both" &
            lead(enroll_type, 1) == "both" ~ 1,
          TRUE ~ 0)
      ) %>%
      filter(drop == 0 | is.na(drop)) %>%
      select(id, startdate_c, enddate_c, enroll_type)

Answer 4

Я думаю, я понимаю, что вы имеете в виду, попробуйте это - из базы R:

library("data.table")
dt1<- data.table(id = rep(1111, 4),
                 from_date = as.Date(c("2016-01-01", "2016-03-31","2016-09-02", "2016-09-03")), 
                 to_date = as.Date(c("2016-03-15", "2016-09-01", "2016-09-02", "2016-12-15")), 
                 progs1 = c("a1", "b1", "c1", "d1"))

dt2 <- data.table(id = rep(1111, 4),
                 from_date = as.Date(c("2016-02-01", "2016-04-01","2016-11-01", "2016-12-01")), 
                 to_date = as.Date(c("2016-02-28", "2016-09-30", "2016-11-30", "2016-12-31")), 
                 progs2 = c("a2", "b2", "c2", "d2"))

# Full outer join: 

dt3 <- merge(dt1, dt2, by = intersect(colnames(dt1), colnames(dt2)), all = TRUE)