r - 有效地创建变量，指示日期变量是否在事件之前（按组）

Posted 2021-05-04

我在data.frame中有两个日期（date1和date2）和一个id变量：

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

我想创建一个新的变量var，它指示任何date2日期值是否在该行的date1日期值之前（不仅仅是紧接在它之前的date2值）：

> 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

我已经能够通过以下循环实现这一目标：

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
  }
}

但是，我的数据集非常大，如果可能的话，我想用data.table实现这个目标，尽管如果有一种有效的方法，我很乐意用dplyr来解决这个问题。

答案

建立在目前为止的其他三个答案......

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
}

由于copy，需要an open issue/bug的东西。

与chinsoon + 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

所以min way（由Martin Morgan的答案推动）赢得了这个示例数据。

另一答案

建议在@thelatemail建议的自我加入后使用.EACHI

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

---

编辑：一些时间供参考

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

另一答案

我很确定这可以通过data.table的自我加入来实现。例如。：

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

我基本上创建一个行引用号，然后将表连接到自身on "id"，找到日期比较符合预期的行，然后使用这些行号分配最终的hit变量。

另一答案

既不是data.table也不是dplyr，而是首先编写一个函数来做你想要的假设列没有分组

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

然后使用split()将数据分成组，Map()将函数应用于每个组，并使用split<-()分配新值

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

即使数据量很大，这也会相对有效，只要没有太多的组。不确定为什么日期被转换为样本数据中的字符; fun()可以另外推广。

对于使用@ chinsoon12中的数据进行计时（实际上只有几个组），我有

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
}

同

> 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 

如果有1000组（id = sample(1000, N, replace = TRUE)），则时间更均匀

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 

通过将Date值向量化强制转换为数字，可以获得相当大的加速

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
}

在1e4组中有1e5值，id是一个因子（），与最快的frank_*()相比，结果是

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

和

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