объединить два кадра данных на неперекрывающиеся интервалы

Question

Я хочу объединить два кадра данных. Оба они имеют дату начала и дату окончания.

Если заданные интервалы перекрываются, я хочу разбить результирующие строки на неперекрывающиеся друг друга.

Пожалуйста, смотрите этот пример:

a 
id  beg_a  end_a prop_a 
    1 2000-01-01 2002-12-31  A 
    2 2000-01-01 2000-02-15  B 
    2 2000-04-01 2000-04-15  A 
    2 2002-01-01 2002-12-31  B 
    3 2000-01-01 2000-06-15  A 

b 
id  beg_b  end_b prop_b 
    1 1999-06-01 2000-05-15  D 
    1 2003-01-15 2003-01-31  D 
    2 1999-01-01 2003-01-15  D 
    3 2000-07-01 2001-08-01  E 

merged 
    id  beg_a  end_a prop_a  beg_b  end_b prop_b overallBeg overallEnd 
    1  <NA>  <NA> <NA> 1999-06-01 2000-05-15  D 1999-06-01 1999-12-31 
    1 2000-01-01 2002-12-31  A 1999-06-01 2000-05-15  D 2000-01-01 2000-05-15 
    1 2000-01-01 2002-12-31  A  <NA>  <NA> <NA> 2000-05-16 2002-12-31 
    1  <NA>  <NA> <NA> 2003-01-15 2003-01-31  D 2003-01-15 2003-01-31 
    2  <NA>  <NA> <NA> 1999-01-01 2003-01-15  D 1999-01-01 1999-12-31 
    2 2000-01-01 2000-02-15  B 1999-01-01 2003-01-15  D 2000-01-01 2000-02-15 
    2  <NA>  <NA> <NA> 1999-01-01 2003-01-15  D 2000-02-16 2000-03-31 
    2 2000-04-01 2000-04-15  A 1999-01-01 2003-01-15  D 2000-04-01 2000-04-15 
    2  <NA>  <NA> <NA> 1999-01-01 2003-01-15  D 2000-04-16 2001-12-31 
    2 2002-01-01 2002-12-31  B 1999-01-01 2003-01-15  D 2002-01-01 2002-12-31 
    2  <NA>  <NA> <NA> 1999-01-01 2003-01-15  D 2003-01-01 2003-01-15 
    3 2000-01-01 2000-06-15  A  <NA>  <NA> <NA> 2000-01-01 2000-06-15 
    3  <NA>  <NA> <NA> 2000-07-01 2001-08-01  E 2000-07-01 2001-08-01 

(или просто использовать эти команды в R)

a <- structure(list(id = c(1, 2, 2, 2, 3), beg_a = structure(c(10957, 
    10957, 11048, 11688, 10957), class = "Date"), end_a = structure(c(12052, 
    11002, 11062, 12052, 11123), class = "Date"), prop_a = structure(c(1L, 
    2L, 1L, 2L, 1L), .Label = c("A", "B"), class = "factor")), .Names = c("id", 
    "beg_a", "end_a", "prop_a"), row.names = c(NA, -5L), class = "data.frame") 

b <- structure(list(id = c(1, 1, 2, 3), beg_b = structure(c(10743, 
    12067, 10592, 11139), class = "Date"), end_b = structure(c(11092, 
    12083, 12067, 11535), class = "Date"), prop_b = structure(c(1L, 
    1L, 1L, 2L), .Label = c("D", "E"), class = "factor")), .Names = c("id", 
    "beg_b", "end_b", "prop_b"), row.names = c(NA, -4L), class = "data.frame") 

merged <- structure(list(id = c(1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 3, 3), 
     beg_a = structure(c(NA, 10957, 10957, NA, NA, 10957, NA, 
     11048, NA, 11688, NA, 10957, NA), class = "Date"), end_a = structure(c(NA, 
     12052, 12052, NA, NA, 11002, NA, 11062, NA, 12052, NA, 11123, 
     NA), class = "Date"), prop_a = structure(c(NA, 1L, 1L, NA, 
     NA, 2L, NA, 1L, NA, 2L, NA, 1L, NA), .Label = c("A", "B"), class = "factor"), 
     beg_b = structure(c(10743, 10743, NA, 12067, 10592, 10592, 
     10592, 10592, 10592, 10592, 10592, NA, 11139), class = "Date"), 
     end_b = structure(c(11092, 11092, NA, 12083, 12067, 12067, 
     12067, 12067, 12067, 12067, 12067, NA, 11535), class = "Date"), 
     prop_b = structure(c(1L, 1L, NA, 1L, 1L, 1L, 1L, 1L, 1L, 
     1L, 1L, NA, 2L), .Label = c("D", "E"), class = "factor"), 
     overallBeg = structure(c(10743, 10957, 11093, 12067, 10592, 
     10957, 11003, 11048, 11063, 11688, 12053, 10957, 11139), class = "Date"), 
     overallEnd = structure(c(10956, 11092, 12052, 12083, 10956, 
     11002, 11047, 11062, 11687, 12052, 12067, 11123, 11535), class = "Date")), .Names = c("id", 
    "beg_a", "end_a", "prop_a", "beg_b", "end_b", "prop_b", "overallBeg", 
    "overallEnd"), row.names = c(NA, -13L), class = "data.frame") 

Я думаю, что есть некоторое сходство с другим моим вопросом: "smoothing" time data - can it be done more efficient?

Но и немного отличается.

Заранее благодарю вас за помощь!

Answer 1

sqldf будет работать, но я попробовал «чистое» решение R. Он работает, но он немного неряшлив. Я не понял, как «векторизовать» решение (удалите два для циклов в split.interval и удалите необходимость переходить на id.split).

Сначала я создаю две функции, которые могут принимать один идентификатор и сливаться «а» и «B» вместе:

split.interval = function(sub.a, sub.b) { 
    begs = c(sub.a$beg_a,sub.b$beg_b) 
    ends = c(sub.a$end_a,sub.b$end_b) 
    dates=c(begs,ends) 
    dates = dates[order(dates)] 
    d = data.frame(overallBeg = dates[-length(dates)], overallEnd = dates[-1]) 
    date.match = function(x,y) { 
      s = match(x, d$overallBeg) 
      e = match(y, d$overallEnd) 
      join=as.Date(rep(NA,length(d$overallBeg))) 
      for (i in 1:length(x)) join [s[i]:e[i]]= x[i] 
      join 
    } 

    d$a_join = date.match(sub.a$beg_a,sub.a$end_a) 
    d$b_join = date.match(sub.b$beg_b,sub.b$end_b) 

    d = merge(sub.a,d,by.x='beg_a',by.y='a_join',all.y=T) 
    d = merge(sub.b,d,by.x='beg_b',by.y='b_join',all.y=T) 

    d$id=pmax(d$id.x,d$id.y,na.rm=T) 
    d = d [order(d$overallBeg),c('id','beg_a','end_a','prop_a','beg_b','end_b','prop_b','overallBeg','overallEnd')] 
    # This next line will lead to a bug if overallBeg == overallEnd 
    d$overallEnd [d$overallEnd == c(d$overallBeg[-1],F)] = d$overallEnd [d$overallEnd == c(d$overallBeg[-1],F)] - 1 
    d 

} 

id.split = function (ids) { 
    sub.a=a[a$id==ids,] 
    sub.b=b[b$id==ids,] 

    split.interval (sub.a , sub.b) 
} 

Затем я запускаю функцию для каждого ID, и связывают их вместе.

l=lapply(unique(c(a$id,b$id)), id.split) 
res = do.call(rbind,l) 
row.names(res) = NULL 
res 

Answer 2

Вы можете сделать это в два этапа: сначала, вычислите все требуемые интервалы и поместите их в промежуточную таблицу, затем присоедините эту таблицу к двум исходным данным.

# First build all the desired intervals 
names(a) <- c("id", "valid_from", "valid_until", "prop_a") 
names(b) <- c("id", "valid_from", "valid_until", "prop_b") 

intervals <- rbind( 
    data.frame(id = a$id, date = a$valid_from), 
    data.frame(id = a$id, date = a$valid_until), 
    data.frame(id = b$id, date = b$valid_from), 
    data.frame(id = b$id, date = b$valid_until) 
) 
intervals <- unique(intervals) 
intervals <- intervals[ order(intervals$id, intervals$date), ] 
n <- dim(intervals)[1] 
intervals <- data.frame(
    id = intervals$id[-n], 
    id2 = intervals$id[-1], 
    valid_from = intervals$date[-n], 
    valid_until = intervals$date[-1] 
) 
intervals <- intervals[ 
    intervals$id == intervals$id2, 
    c("id", "valid_from", "valid_until") 
] 

Поскольку условие, по которому мы присоединяемся к данным, не является простым равенством, будем использовать sqldf.

library(sqldf) 
d <- sqldf(" 
    SELECT intervals.id, 
     intervals.valid_from, intervals.valid_until, 
     a.prop_a, b.prop_b 
    FROM intervals 
    LEFT JOIN a 
    ON   a.valid_from <= intervals.valid_from 
    AND intervals.valid_until <=   a.valid_until 
    AND intervals.id = a.id 
    LEFT JOIN b 
    ON   b.valid_from <= intervals.valid_from 
    AND intervals.valid_until <=   b.valid_until 
    AND intervals.id = b.id 
")