r - data.table by = xx 当我返回不匹配时，如何保留长度为 0 的组

Question

我正在尝试解决由于我的数据量而出现的问题，但我一直无法找到答案。(即 Data.table: how to get the blazingly fast subsets it promises and apply to a second data.table)

这是虚拟数据。

library(dplyr)
library(tidyr)
library(lubridate)
library(data.table)

adherence <- cbind.data.frame(c("1", "2", "3", "1", "2", "3"), c("2013-01-01", "2013-01-01", "2013-01-01", "2013-02-01", "2013-02-01", "2013-02-01"))
names(adherence)[1] <- "ID" 
names(adherence)[2] <- "year"
adherence$year <- ymd(adherence$year)

lsr <- cbind.data.frame(
  c("1", "1", "1", "2", "2", "2", "3", "3"), #ID
  c("2012-03-01", "2012-08-02", "2013-01-06","2012-08-25", "2013-03-22", "2013-09-15", "2011-01-01", "2013-01-05"), #eksd
  c("60", "90", "90", "60", "120", "60", "30", "90") # DDD
)
names(lsr)[1] <- "ID"
names(lsr)[2] <- "eksd"
names(lsr)[3] <- "DDD"

lsr$eksd <- as.Date((lsr$eksd))
lsr$DDD <- as.numeric(as.character(lsr$DDD))
lsr$ENDDATE <- lsr$eksd + lsr$DDD
lsr <- as.data.table(lsr)

adherence <- as.data.table(adherence)

我尝试了不同的方法来获得结果:笛卡尔连接给我超过 2*31 行，但行不通。我重写了 data.table 中的所有内容，它确实将运行速度降低了几天。我发现，如果我能让这一行返回所需的结果，我就可以创建一个 for 循环来查看“2013-02-01”和其他 500 个时间点并实现我的梦想(继续另一个问题)。下面的一个子集只需要 15 秒处理我的数据(因此我可以在几个小时内运行完所有数据)，但我的问题是它只返回具有有值(value)子集的组。 ID:2 没有返回，我认为，因为该组在 i 中没有匹配项。 - 减少花费在操作上的时间。

lsr[eksd <= as.Date("2013-02-01") & ENDDATE > as.Date("2013-02-01"), sum(as.numeric(ENDDATE - as.Date("2013-02-01"))), keyby = ID]


    ID V1
1:  1 64
2:  3 63

在大多数情况下这很聪明，但我需要有关长度为 0 的组的信息。(或任何值 - 我只需要不删除 ID 信息)。有点像这样:

   ID V1
1:  1 64
2:  2 0
3:  3 63

我尝试使用 tidyr::complete 函数(如此处解释:dplyr summarise: Equivalent of ".drop=FALSE" to keep groups with zero length in output)，但 dplyr 太慢了。我的 0.2% 的数据需要 7 个小时。我相信这可以以某种方式实现。欢迎和赞赏任何建议。

Answer 1

出于速度原因，我建议您坚持使用第一种方法并简单地添加必要的零:

by_minem <- function(dt = lsr2) {
  x <- dt[eksd <= as.Date("2013-02-01") & ENDDATE > as.Date("2013-02-01"),
          sum(as.numeric(ENDDATE - as.Date("2013-02-01"))), keyby = ID]
  uid <- unique(dt$ID)
  id2 <- uid[!(uid %in% x$ID)]
  x2 <- data.table(ID = id2, V1 = 0)
  x <- rbind(x, x2)
  setkey(x, ID)
  x
}
by_minem(lsr)
#    ID V1
# 1:  1 64
# 2:  2  0
# 3:  3 63

在更大的数据上测试:

#Create larger data:
n <- 5e4
lsr2 <- lapply(1:n, function(x) lsr)
lsr2 <- rbindlist(lsr2, use.names = T, fill = T, idcol = T)
lsr2[, ID := as.integer(paste0(.id, ID))]
lsr2[, .(.N, uniqueN(ID))]
#         N     V2
# 1: 400000 150000

by_henry <- function(dt = lsr2) {
  dt[, sum((eksd <= as.Date("2013-02-01") & ENDDATE > as.Date("2013-02-01")) *
            as.numeric(ENDDATE - as.Date("2013-02-01"))), keyby = ID]
}

system.time(r1 <- by_henry()) #92.53
system.time(r2 <- by_minem()) #21.73
92.53/21.73 #4 times faster
all.equal(r1, r2)
# [1] TRUE

更新

这会更快:

    by_minem2 <- function(dt = lsr2) {
  d <- as.numeric(as.Date("2013-02-01"))
  dt[, ENDDATE2 := as.numeric(ENDDATE)]
  x <- dt[eksd <= d & ENDDATE > d, sum(ENDDATE2 - d), keyby = ID]
  uid <- unique(dt$ID)
  id2 <- setdiff(uid, x$ID)
  id2 <- uid[!(uid %in% x$ID)]
  x2 <- data.table(ID = id2, V1 = 0)
  x <- rbind(x, x2)
  setkey(x, ID)
  x
}

system.time(r2 <- by_minem2()) #0.13