Cómo aplanar/fusionar períodos de tiempo superpuestos
date datetime (4)
Tengo un gran conjunto de datos de períodos de tiempo, definidos por una columna ''inicio'' y ''final''. Algunos de los períodos se superponen.
Me gustaría combinar (aplanar / fusionar / contraer) todos los períodos de tiempo superpuestos para tener un valor ''inicial'' y un valor ''final''.
Algunos datos de ejemplo:
ID start end
1 A 2013-01-01 2013-01-05
2 A 2013-01-01 2013-01-05
3 A 2013-01-02 2013-01-03
4 A 2013-01-04 2013-01-06
5 A 2013-01-07 2013-01-09
6 A 2013-01-08 2013-01-11
7 A 2013-01-12 2013-01-15
Resultado deseado:
ID start end
1 A 2013-01-01 2013-01-06
2 A 2013-01-07 2013-01-11
3 A 2013-01-12 2013-01-15
Lo que he intentado:
require(dplyr)
data <- structure(list(ID = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L), class = "factor", .Label = "A"),
start = structure(c(1356998400, 1356998400, 1357084800, 1357257600,
1357516800, 1357603200, 1357948800), tzone = "UTC", class = c("POSIXct",
"POSIXt")), end = structure(c(1357344000, 1357344000, 1357171200,
1357430400, 1357689600, 1357862400, 1358208000), tzone = "UTC", class = c("POSIXct",
"POSIXt"))), .Names = c("ID", "start", "end"), row.names = c(NA,
-7L), class = "data.frame")
remove.overlaps <- function(data){
data2 <- data
for ( i in 1:length(unique(data$start))) {
x3 <- filter(data2, start>=data$start[i] & start<=data$end[i])
x4 <- x3[1,]
x4$end <- max(x3$end)
data2 <- filter(data2, start<data$start[i] | start>data$end[i])
data2 <- rbind(data2,x4)
}
data2 <- na.omit(data2)}
data <- remove.overlaps(data)
Aquí hay una posible solución.
La idea básica aquí es comparar la fecha de
start
retrasada con la fecha de finalización máxima "hasta ahora" utilizando la función
cummax
y crear un índice que separe los datos en grupos
data %>%
arrange(ID, start) %>% # as suggested by @Jonno in case the data is unsorted
group_by(ID) %>%
mutate(indx = c(0, cumsum(as.numeric(lead(start)) >
cummax(as.numeric(end)))[-n()])) %>%
group_by(ID, indx) %>%
summarise(start = first(start), end = last(end))
# Source: local data frame [3 x 4]
# Groups: ID
#
# ID indx start end
# 1 A 0 2013-01-01 2013-01-06
# 2 A 1 2013-01-07 2013-01-11
# 3 A 2 2013-01-12 2013-01-15
En aras de la exhaustividad,
el paquete
IRanges
en Bioconductor
tiene algunas funciones ordenadas que se pueden utilizar para tratar los rangos de fecha o fecha y hora.
Una de ellas es la función
reduce()
que combina rangos superpuestos o adyacentes.
Sin embargo, hay un inconveniente porque
IRanges
funciona en rangos de enteros (de ahí el nombre), por lo que la conveniencia de usar
IRanges
funciones de
IRanges
produce a expensas de convertir objetos
Date
o
POSIXct
para allá.
Además, parece que
dplyr
no funciona bien con
IRanges
(al menos juzgado por mi experiencia limitada con
dplyr
), así que uso
data.table
:
library(data.table)
options(datatable.print.class = TRUE)
library(IRanges)
library(lubridate)
setDT(data)[, {
ir <- reduce(IRanges(as.numeric(start), as.numeric(end)))
.(start = as_datetime(start(ir)), end = as_datetime(end(ir)))
}, by = ID]
ID start end <fctr> <POSc> <POSc> 1: A 2013-01-01 2013-01-06 2: A 2013-01-07 2013-01-11 3: A 2013-01-12 2013-01-15
Una variante de código es
setDT(data)[, as.data.table(reduce(IRanges(as.numeric(start), as.numeric(end))))[
, lapply(.SD, as_datetime), .SDcols = -"width"],
by = ID]
En ambas variantes, se
as_datetime()
de los paquetes
lubridate
, que ahorra para especificar el origen al convertir números a objetos
POSIXct
.
Sería interesante ver una comparación comparativa de los enfoques de
IRanges
frente a
la respuesta de David
.
La respuesta de @David Arenburg es excelente, pero me encontré con un problema en el que un intervalo anterior terminó después de un intervalo posterior, pero usar el
last
en la llamada de
summarise
resultó en una fecha de finalización incorrecta.
Sugeriría cambiar
first(start)
y
last(end)
a
min(start)
y
max(end)
data %>%
group_by(ID) %>%
mutate(indx = c(0, cumsum(as.numeric(lead(start)) >
cummax(as.numeric(end)))[-n()])) %>%
group_by(ID, indx) %>%
summarise(start = min(start), end = max(end))
Además, como mencionó @Jonno Bourne, es importante ordenar por
start
y cualquier variable de agrupación antes de aplicar el método.
Parece que llegué un poco tarde a la fiesta, pero tomé el código de
data.table
y lo
data.table
usando
data.table
continuación.
No hice pruebas exhaustivas, pero parecía funcionar un 20% más rápido que la versión
tidy
.
(No pude probar el método
IRange
porque el paquete aún no está disponible para R 3.5.1)
Además, la respuesta aceptada no captura el caso límite en el que un intervalo de fechas está totalmente dentro de otro (por ejemplo,
2018-07-07
a
2017-07-14
está dentro de
2018-05-01
a
2018-12-01
)
La respuesta de @zach captura ese caso extremo.
library(data.table)
start_col = c("2018-01-01","2018-03-01","2018-03-10","2018-03-20","2018-04-10","2018-05-01","2018-05-05","2018-05-10","2018-07-07")
end_col = c("2018-01-21","2018-03-21","2018-03-31","2018-04-09","2018-04-30","2018-05-21","2018-05-26","2018-05-30","2018-07-14")
# create fake data, double it, add ID
# change row 17, such that each ID grouping is a little different
# also adds an edge case in which one date range is totally within another
# (this is the edge case not currently captured by the accepted answer)
d <- data.table(start_col = as.Date(start_col), end_col = as.Date(end_col))
d2<- rbind(d,d)
d2[1:(.N/2), ID := 1]
d2[(.N/2 +1):.N, ID := 2]
d2[17,end_col := as.Date(''2018-12-01'')]
# set keys (also orders)
setkey(d2, ID, start_col, end_col)
# get rid of overlapping transactions and do the date math
squished <- d2[,.(START_DT = start_col,
END_DT = end_col,
indx = c(0, cumsum(as.numeric(lead(start_col)) > cummax(as.numeric(end_col)))[-.N])),
keyby=ID
][,.(start=min(START_DT),
end = max(END_DT)),
by=c("ID","indx")
]