Tengo dos fechas (date1 y date2) y una variable id en un data.frame:

dat <- data.frame(c('2014-02-11', '2014-05-04', '2014-05-22'), c('2014-04-12', '2014-09-22', '2014-07-04'), c('a', 'a', 'b'))
names(dat) <- c('date1', 'date2', 'id')
dat$date1 <- as.character.Date(dat$date1, format = '%Y-%m-%d')
dat$date2 <- as.character.Date(dat$date2, format = '%Y-%m-%d')
> dat
       date1      date2 id
1 2014-02-11 2014-04-12  a
2 2014-05-04 2014-09-22  a
3 2014-05-22 2014-07-04  b

Me gustaría crear una nueva variable var que indique si any date2 valor de fecha precede al valor de fecha date1 para esa fila (no simplemente el {{X3) }} valor inmediatamente anterior):

> dat
       date1      date2 id var
1 2014-02-11 2014-04-12  a   0
2 2014-05-04 2014-09-22  a   1
3 2014-05-22 2014-07-04  b   0

He podido lograr esto con el siguiente bucle:

ids <- as.vector(unique(unlist(dat$id)))
dat$var <- as.numeric(0)
for (i in ids) {
  date2s <- as.vector(unlist(filter(dat, id == i)$date2))
  for (j in date2s) {
    dat <- dat %>% mutate(var = replace(var, (j < date1) & (id == i), 1)) # if any cdate precedes rdate
  }
}

Sin embargo, mi conjunto de datos es bastante grande, y me gustaría lograr esto usando data.table si es posible, aunque estoy feliz de abordar esto con dplyr si hay un enfoque eficiente.

6
kathystehl 2 mar. 2018 a las 07:52

4 respuestas

La mejor respuesta

Sobre la base de las otras tres respuestas hasta ahora ...

library(data.table)

frank_first = function() dat[, v0 := as.logical(copy(.SD)[copy(.SD), on=.(id, date2 < date1), mult="first", .N, by=.EACHI]$N)]

frank_which = function() dat[, vw := !is.na(copy(.SD)[copy(.SD), on=.(id, date2 < date1), mult="first", which=TRUE])]

frank_any = function() dat[, v1 := .SD[copy(.SD), on=.(id, date2 < date1), .N, by=.EACHI]$N > 0L]

frank_min = function() dat[, v := as.logical(.SD[, min(date2), by=id][copy(.SD), on=.(id, V1 < date1), .N, by=.EACHI]$N)]

fun = function(x, y) x > min(y)
mtm <- function(df) {
    df$var <- NA  # new column, to be updated
    split(df$var, df$id) <-
        Map(fun, split(df$date1, df$id), split(df$date2, df$id))
    df
}

El material copy es necesario debido a un problema / error abierto.

Un punto de referencia con chinsoon + datos de Martin Morgan:

set.seed(2L)
N <- 1e5
ng = 1e4
dat <- data.table(date1=sample(seq(as.Date("1970-01-01"), Sys.Date(), by="1 day"), N, replace=TRUE), 
    date2=sample(seq(as.Date("1970-01-01"), Sys.Date(), by="1 day"), N, replace=TRUE),
    id=sample(ng, N, replace=TRUE))

df = data.frame(dat)

microbenchmark::microbenchmark(frank_first(), frank_which(), frank_any(), frank_min(), mtm(df), times=5L)

Unit: milliseconds
          expr       min        lq      mean    median        uq       max neval cld
 frank_first()  70.38654  70.72610  80.37284  73.33607  86.87363 100.54186     5  a 
 frank_which()  55.90631  57.16385  62.89525  61.82535  64.63895  74.94178     5  a 
   frank_any()  38.56254  39.42893  40.53816  39.85976  41.47074  43.36885     5  a 
   frank_min()  36.73850  36.90551  62.55768  45.44839  55.41056 138.28545     5  a 
       mtm(df) 186.44924 190.26654 209.38918 219.73829 224.06300 226.42884     5   b

Entonces, la forma mínima (motivada por la respuesta de Martin Morgan) gana con estos datos de ejemplo.

5
Frank 2 mar. 2018 a las 17:44

Una sugerencia para usar .EACHI de la siguiente manera después de una auto-unión como lo sugiere @thelatemail

dat[dat, .(date1=i.date1, date2=i.date2, var=any(date2 < i.date1)), by=.EACHI, on=.(id)]

#   id      date1      date2   var
#1:  a 2014-02-11 2014-04-12 FALSE
#2:  a 2014-05-04 2014-09-22  TRUE
#3:  b 2014-05-22 2014-07-04 FALSE

Editar: algo de tiempo para referencia

set.seed(2L)
N <- 1e5
dat <- data.table(date1=sample(seq(as.Date("1970-01-01"), Sys.Date(), by="1 day"), N, replace=TRUE), 
    date2=sample(seq(as.Date("1970-01-01"), Sys.Date(), by="1 day"), N, replace=TRUE),
    id=sample(letters, N, replace=TRUE))

dt1 <- copy(dat)
tlmMtd <- function() {
    dt1[, rownum := .I]
    dt1[dt1[dt1, on="id", rownum[i.date2 < date1], allow.cartesian=TRUE], hit := 1]
}

dt2 <- copy(dat)
csMtd <- function() dt2[dt2, .(date1=i.date1, date2=i.date2, var=any(date2 < i.date1)), by=.EACHI, on=.(id)]


dt3 <- copy(dat)
frankMtd <- function() dt3[, v := .SD[copy(.SD), on=.(id, date2 < date1), .N, by=.EACHI]$N > 0L]

microbenchmark::microbenchmark(
    tlmMtd(),
    csMtd(),
    frankMtd(),
    times=5L)

# Unit: milliseconds
#       expr        min         lq       mean     median         uq       max neval
# tlmMtd()   18528.9799 18652.2217 23486.4213 19116.8014 21140.5923 39993.511     5
# csMtd()     3801.2146  3943.6201  4984.6274  5341.4322  5673.6878  6163.182     5
# frankMtd()   176.4477   177.5576   191.9636   178.9564   182.0311   244.825     5
6
chinsoon12 2 mar. 2018 a las 09:54

Ni data.table ni dplyr, pero comience escribiendo una función que haga lo que quiera suponiendo que las columnas no estén agrupadas

function(x, y)
    as.Date(x) > min(as.Date(y))

Luego use split() para dividir los datos en grupos, Map() para aplicar la función a cada grupo y split<-() para asignar el nuevo valor

answer <- logical(nrow(dat))
split(answer, dat$id) <-
    Map(fun, split(dat$date1, dat$id), split(dat$date2, dat$id))

Esto será relativamente eficiente, incluso con grandes datos, siempre que no haya demasiados grupos. No estoy seguro de por qué las fechas se convirtieron en caracteres en los datos de muestra; fun() podría generalizarse de otra manera.

Para el tiempo usando los datos en @ chinsoon12 (donde de hecho solo hay unos pocos grupos), tengo

df <- as.data.frame(dat)
mtm1 <- function(df) {
    answer <- logical(nrow(dat))
    split(answer, df$id) <-
        Map(fun, split(df$date1, df$id), split(df$date2, df$id))
    answer
}

Con

> identical(mtm1(df), frankMtd()$v)
[1] TRUE
> microbenchmark::microbenchmark(frankMtd(), mtm(df), times=5L)
Unit: milliseconds
       expr        min        lq       mean     median         uq        max
 frankMtd() 1917.95697 1927.2548 1928.65821 1928.45893 1933.34159 1936.27878
   mtm1(df)   47.00293   47.0198   48.02849   47.10012   47.18432   51.83523
 neval cld
     5   b
     5  a 

Si hay 1000 grupos (id = sample(1000, N, replace = TRUE)), entonces los tiempos son más uniformes

Unit: milliseconds
       expr       min        lq      mean    median        uq      max neval
 frankMtd() 140.87859 140.88647 141.97093 141.86977 142.28619 143.9336     5
   mtm1(df)  61.82032  64.55505  64.61313  65.53642  65.53768  65.6162     5
 cld
   b
  a 

Se puede obtener una aceleración considerable mediante la coerción vectorizada de valores de fecha a numéricos

mtm2 <- function(df) {
    answer <- logical(nrow(df))
    split(answer, df$id) <- Map(
        function(x, y) x > min(y),
        split(as.numeric(df$date1), df$id),
        split(as.numeric(df$date2), df$id)
    )
    answer
}

Con 1e5 valores en 1e4 grupos, con id un factor (), y en comparación con el más rápido frank_*(), los resultados son

> identical(frank_any()$v, mtm1(df))
[1] TRUE
> identical(frank_any()$v, mtm2(df))
[1] TRUE

Y

Unit: milliseconds
        expr       min        lq      mean    median        uq       max neval
 frank_any()  79.90262  80.43112  81.79228  81.18565  83.18963  84.25236     5
    mtm1(df) 237.00027 241.40299 244.83638 246.26495 249.47713 250.03658     5
    mtm2(df)  44.11074  46.17133  51.26976  47.03285  52.77204  66.26184     5
 cld
  b 
   c
 a
4
Martin Morgan 3 mar. 2018 a las 08:59

Estoy bastante seguro de que esto se puede lograr mediante una autounión en data.table. P.ej.:

library(data.table)

setDT(dat)
dat[, rownum := .I]
dat[dat[dat, on="id", rownum[i.date2 < date1]], hit := 1]
dat

#        date1      date2 id rownum hit
#1: 2014-02-11 2014-04-12  a      1  NA
#2: 2014-05-04 2014-09-22  a      2   1
#3: 2014-05-22 2014-07-04  b      3  NA

Básicamente creo un número de referencia de fila, luego me uno a la tabla en sí mismo on "id", encuentro las filas donde la comparación de fechas es la esperada, luego uso esos números de fila para asignar el hit final variable.

5
thelatemail 2 mar. 2018 a las 05:29