在两列中使用 'start' 和 'end' 值来指定 R 中剩余列的填充范围
use 'start' and 'end' values in two columns to specify fill range over remaining columns in R
我需要在 'start' 和 'end' 列之间用“1”填充矩阵的每一行，其中 'start' 和 'end' 列名称（日期在实际数据）在矩阵的两列中为每个 'id' 指定。
例如
library(data.table)
d<- data.table(id = c("id_1","id_2"),
start.date = c(as.Date("2021-06-01"), as.Date("2021-07-02")),
end.date = c(as.Date("2021-08-04"), as.Date("2021-09-12")))
> d
id start.date end.date
1: id_1 2021-06-01 2021-08-04
2: id_2 2021-07-02 2021-09-12
目标是计算每个日期落入的人数。对于较小的数据集，我会这样做：
expand.dates<- function(start.date, end.date){
dates<- seq.Date(start.date, end.date, "1 day")
}
##join expanded dates list to the original data.table 'd' on 'id'
xx<- d[d[,.(dates = expand.dates(start.date, end.date)), by = id], on = .(id)]
cnts<- xx[,.(counts = .N), by = .(dates)]
但真实数据有数百万个单独的 ID，上述方法会导致内存错误（无法创建 8.5GB 的矢量），所以我尝试 'cast' 日期范围，然后 运行 对日期进行 colSums 以获得计数。
已编辑问题的答案
OP 编辑了问题 :
imagine several million distinct IDs and a full range of possible
start and end dates, spanning anywhere from a few days to a few years.
The goal is to get a count of individuals that fall on each date
我在 Bioconductor 的 IRanges 包的帮助下解决了类似的问题：
install.packages("IRanges", repos = "https://bioconductor.org/packages/3.15/bioc")
library(IRanges)
cvr <- d[, coverage(IRanges(as.numeric(start.date), as.numeric(end.date)))]
data.table(start.date = lubridate::as_date(start(cvr)),
end.date = lubridate::as_date(end(cvr)),
count = runValue(cvr))
start.date end.date count
1: 1970-01-02 2021-05-31 0
2: 2021-06-01 2021-07-01 1
3: 2021-07-02 2021-08-04 2
4: 2021-08-05 2021-09-12 1
结果表示时间尺度，其中每行显示每个子周期的重叠数 count（覆盖率）。
说明
输入数据集
id start.date end.date
1: id_1 2021-06-01 2021-08-04
2: id_2 2021-07-02 2021-09-12
转换为 整数范围 以便利用 IRanges 中的 coverage() 函数。 coverage() returns 子周期的紧凑 run-length 编码 (RLE) 表示：
cvr
integer-Rle of length 18882 with 4 runs
Lengths: 18778 31 34 39
Values : 0 1 2 1
最后，RLE 被转换为 data.frame，整数范围强制变回 Date class。
用法
结果可以很容易地用于各种用例：
result <- data.table(start.date = lubridate::as_date(start(cvr)),
end.date = lubridate::as_date(end(cvr)),
count = runValue(cvr))[-1]
此处，日期范围已被缩减，即第一行已被删除。
绘图
library(ggplot2)
ggplot(result[]) +
aes(x = start.date, y = count, xend = end.date, yend = count) +
geom_segment()
正在查询
result["2021-08-21" %between% .(start.date, end.date)]
start.date end.date count
1: 2021-08-05 2021-09-12 1
扩展（反向 RLE）
result[, .(Date = seq(start.date, end.date, by = 1), count), by = 1:nrow(result)]
nrow Date count
1: 1 2021-06-01 1
2: 1 2021-06-02 1
3: 1 2021-06-03 1
4: 1 2021-06-04 1
5: 1 2021-06-05 1
---
100: 3 2021-09-08 1
101: 3 2021-09-09 1
102: 3 2021-09-10 1
103: 3 2021-09-11 1
104: 3 2021-09-12 1
N.B.: 随着 data.table 的开发版本 1.14.3，代码可以通过使用 by = .I 进行 row-wise 操作来简化。
data.table::update.dev.pkg()
library(data.table)
result[, .(Date = seq(start.date, end.date, by = 1), count), by = .I]
原始问题的答案
由于行数较多，矩阵中1的填入可能性有限，我的建议是加入look-up table.
lut <- fread(
"
a, b, c, d, e, f
c, d, 1, 1,NA,NA
c, e, 1, 1, 1,NA
c, f, 1, 1, 1, 1
d, e,NA, 1, 1,NA
d, f,NA, 1, 1, 1
e, f,NA,NA, 1, 1
")
lut[d, on =.(a, b), .(id, a, b, c, d, e, f)]
id a b c d e f
1: A1 c e 1 1 1 NA
2: B2 d f NA 1 1 1
3: C3 c e 1 1 1 NA
4: D4 d f NA 1 1 1
这种方法 比 r2evans' answer 快 个数量级并且消耗更少的内存。对于具有 100 万行的示例用例，r2evans 的方法花费了 30 多秒并分配了将近 600 兆字节的内存，而连接花费了不到 150 毫秒并分配了不到 100 兆字节的内存。
基准详情
library(bench)
col_names <- letters[3:6]
n_cols <- length(col_names)
lut_text <-
"a, b, c, d, e, f
c, d, 1, 1,NA,NA
c, e, 1, 1, 1,NA
c, f, 1, 1, 1, 1
d, e,NA, 1, 1,NA
d, f,NA, 1, 1, 1
e, f,NA,NA, 1, 1"
bm <- press(
n = 10^(1:6),
{
set.seed(42)
ia <- sample(1:(n_cols - 1), n, replace = TRUE)
ib <- pmin(ia + sample(1:(n_cols - 1), n, replace = TRUE), n_cols)
d <- data.table(id = 1:n,
a = col_names[ia],
b = col_names[ib]
)
for (col in col_names) {
set(d, , col, NA_integer_)
}
str(d)
mark(
r2evans = {
seq.character <- function(from, to, ...) {
letters[seq(match(tolower(from), letters),
match(tolower(to), letters), ...)]
}
newd <- rbindlist(Map(function(...) {
o <- seq.character(...)
setNames(as.list(rep(1L, length(o))), o)
}, d$a, d$b), fill = TRUE, use.names = TRUE)
cbind(d[,1:3], newd)
},
join = {
lut <- fread(text = lut_text)
lut[d, on =.(a, b), .(id, a, b, c, d, e, f)]
}
)
}
)
bm
# A tibble: 12 × 14
expression n min median `itr/sec` mem_alloc `gc/sec` n_itr n_gc total_time result memory
<bch:expr> <dbl> <bch:tm> <bch:tm> <dbl> <bch:byt> <dbl> <int> <dbl> <bch:tm> <list> <list>
1 r2evans 10 868.5µs 937.7µs 1002. 1.64MB 5.32 377 2 376.1ms <data.table> <Rprofmem>
2 join 10 2.43ms 2.99ms 322. 928.97KB 4.13 156 2 483.99ms <data.table> <Rprofmem>
3 r2evans 100 3.03ms 3.24ms 289. 109.08KB 8.45 137 4 473.24ms <data.table> <Rprofmem>
4 join 100 2.44ms 2.66ms 355. 140.84KB 2.03 175 1 493.48ms <data.table> <Rprofmem>
5 r2evans 1000 26.09ms 27.11ms 35.7 803.18KB 11.0 13 4 364.26ms <data.table> <Rprofmem>
6 join 1000 2.48ms 2.67ms 359. 225.21KB 4.12 174 2 485.02ms <data.table> <Rprofmem>
7 r2evans 10000 288.68ms 299.55ms 3.34 5.95MB 8.35 2 5 599.1ms <data.table> <Rprofmem>
8 join 10000 3.59ms 4.3ms 217. 1.04MB 3.98 109 2 502.33ms <data.table> <Rprofmem>
9 r2evans 100000 3.26s 3.26s 0.307 58.48MB 5.52 1 18 3.26s <data.table> <Rprofmem>
10 join 100000 12.14ms 13.07ms 64.7 9.28MB 7.84 33 4 509.99ms <data.table> <Rprofmem>
11 r2evans 1000000 30.76s 30.76s 0.0325 583.7MB 0.845 1 26 30.76s <data.table> <Rprofmem>
12 join 1000000 74.74ms 141.19ms 1.65 91.68MB 0.826 4 2 2.42s <data.table> <Rprofmem>
# … with 2 more variables: time <list>, gc <list>
ggplot2::autoplot(bm)
注意 bench::mark() 默认检查结果是否相等。
我需要在 'start' 和 'end' 列之间用“1”填充矩阵的每一行，其中 'start' 和 'end' 列名称（日期在实际数据）在矩阵的两列中为每个 'id' 指定。
例如
library(data.table)
d<- data.table(id = c("id_1","id_2"),
start.date = c(as.Date("2021-06-01"), as.Date("2021-07-02")),
end.date = c(as.Date("2021-08-04"), as.Date("2021-09-12")))
> d
id start.date end.date
1: id_1 2021-06-01 2021-08-04
2: id_2 2021-07-02 2021-09-12
目标是计算每个日期落入的人数。对于较小的数据集，我会这样做：
expand.dates<- function(start.date, end.date){
dates<- seq.Date(start.date, end.date, "1 day")
}
##join expanded dates list to the original data.table 'd' on 'id'
xx<- d[d[,.(dates = expand.dates(start.date, end.date)), by = id], on = .(id)]
cnts<- xx[,.(counts = .N), by = .(dates)]
但真实数据有数百万个单独的 ID，上述方法会导致内存错误（无法创建 8.5GB 的矢量），所以我尝试 'cast' 日期范围，然后 运行 对日期进行 colSums 以获得计数。
已编辑问题的答案
OP 编辑了问题
imagine several million distinct IDs and a full range of possible start and end dates, spanning anywhere from a few days to a few years. The goal is to get a count of individuals that fall on each date
我在 Bioconductor 的 IRanges 包的帮助下解决了类似的问题：
install.packages("IRanges", repos = "https://bioconductor.org/packages/3.15/bioc")
library(IRanges)
cvr <- d[, coverage(IRanges(as.numeric(start.date), as.numeric(end.date)))]
data.table(start.date = lubridate::as_date(start(cvr)),
end.date = lubridate::as_date(end(cvr)),
count = runValue(cvr))
start.date end.date count 1: 1970-01-02 2021-05-31 0 2: 2021-06-01 2021-07-01 1 3: 2021-07-02 2021-08-04 2 4: 2021-08-05 2021-09-12 1
结果表示时间尺度，其中每行显示每个子周期的重叠数 count（覆盖率）。
说明
输入数据集
id start.date end.date 1: id_1 2021-06-01 2021-08-04 2: id_2 2021-07-02 2021-09-12
转换为 整数范围 以便利用 IRanges 中的 coverage() 函数。 coverage() returns 子周期的紧凑 run-length 编码 (RLE) 表示：
cvr
integer-Rle of length 18882 with 4 runs Lengths: 18778 31 34 39 Values : 0 1 2 1
最后，RLE 被转换为 data.frame，整数范围强制变回 Date class。
用法
结果可以很容易地用于各种用例：
result <- data.table(start.date = lubridate::as_date(start(cvr)),
end.date = lubridate::as_date(end(cvr)),
count = runValue(cvr))[-1]
此处，日期范围已被缩减，即第一行已被删除。
绘图
library(ggplot2)
ggplot(result[]) +
aes(x = start.date, y = count, xend = end.date, yend = count) +
geom_segment()
正在查询
result["2021-08-21" %between% .(start.date, end.date)]
start.date end.date count 1: 2021-08-05 2021-09-12 1
扩展（反向 RLE）
result[, .(Date = seq(start.date, end.date, by = 1), count), by = 1:nrow(result)]
nrow Date count 1: 1 2021-06-01 1 2: 1 2021-06-02 1 3: 1 2021-06-03 1 4: 1 2021-06-04 1 5: 1 2021-06-05 1 --- 100: 3 2021-09-08 1 101: 3 2021-09-09 1 102: 3 2021-09-10 1 103: 3 2021-09-11 1 104: 3 2021-09-12 1
N.B.: 随着 data.table 的开发版本 1.14.3，代码可以通过使用 by = .I 进行 row-wise 操作来简化。
data.table::update.dev.pkg()
library(data.table)
result[, .(Date = seq(start.date, end.date, by = 1), count), by = .I]
原始问题的答案
由于行数较多，矩阵中1的填入可能性有限，我的建议是加入look-up table.
lut <- fread(
"
a, b, c, d, e, f
c, d, 1, 1,NA,NA
c, e, 1, 1, 1,NA
c, f, 1, 1, 1, 1
d, e,NA, 1, 1,NA
d, f,NA, 1, 1, 1
e, f,NA,NA, 1, 1
")
lut[d, on =.(a, b), .(id, a, b, c, d, e, f)]
id a b c d e f 1: A1 c e 1 1 1 NA 2: B2 d f NA 1 1 1 3: C3 c e 1 1 1 NA 4: D4 d f NA 1 1 1
这种方法 比 r2evans' answer 快 个数量级并且消耗更少的内存。对于具有 100 万行的示例用例，r2evans 的方法花费了 30 多秒并分配了将近 600 兆字节的内存，而连接花费了不到 150 毫秒并分配了不到 100 兆字节的内存。
基准详情
library(bench)
col_names <- letters[3:6]
n_cols <- length(col_names)
lut_text <-
"a, b, c, d, e, f
c, d, 1, 1,NA,NA
c, e, 1, 1, 1,NA
c, f, 1, 1, 1, 1
d, e,NA, 1, 1,NA
d, f,NA, 1, 1, 1
e, f,NA,NA, 1, 1"
bm <- press(
n = 10^(1:6),
{
set.seed(42)
ia <- sample(1:(n_cols - 1), n, replace = TRUE)
ib <- pmin(ia + sample(1:(n_cols - 1), n, replace = TRUE), n_cols)
d <- data.table(id = 1:n,
a = col_names[ia],
b = col_names[ib]
)
for (col in col_names) {
set(d, , col, NA_integer_)
}
str(d)
mark(
r2evans = {
seq.character <- function(from, to, ...) {
letters[seq(match(tolower(from), letters),
match(tolower(to), letters), ...)]
}
newd <- rbindlist(Map(function(...) {
o <- seq.character(...)
setNames(as.list(rep(1L, length(o))), o)
}, d$a, d$b), fill = TRUE, use.names = TRUE)
cbind(d[,1:3], newd)
},
join = {
lut <- fread(text = lut_text)
lut[d, on =.(a, b), .(id, a, b, c, d, e, f)]
}
)
}
)
bm
# A tibble: 12 × 14 expression n min median `itr/sec` mem_alloc `gc/sec` n_itr n_gc total_time result memory <bch:expr> <dbl> <bch:tm> <bch:tm> <dbl> <bch:byt> <dbl> <int> <dbl> <bch:tm> <list> <list> 1 r2evans 10 868.5µs 937.7µs 1002. 1.64MB 5.32 377 2 376.1ms <data.table> <Rprofmem> 2 join 10 2.43ms 2.99ms 322. 928.97KB 4.13 156 2 483.99ms <data.table> <Rprofmem> 3 r2evans 100 3.03ms 3.24ms 289. 109.08KB 8.45 137 4 473.24ms <data.table> <Rprofmem> 4 join 100 2.44ms 2.66ms 355. 140.84KB 2.03 175 1 493.48ms <data.table> <Rprofmem> 5 r2evans 1000 26.09ms 27.11ms 35.7 803.18KB 11.0 13 4 364.26ms <data.table> <Rprofmem> 6 join 1000 2.48ms 2.67ms 359. 225.21KB 4.12 174 2 485.02ms <data.table> <Rprofmem> 7 r2evans 10000 288.68ms 299.55ms 3.34 5.95MB 8.35 2 5 599.1ms <data.table> <Rprofmem> 8 join 10000 3.59ms 4.3ms 217. 1.04MB 3.98 109 2 502.33ms <data.table> <Rprofmem> 9 r2evans 100000 3.26s 3.26s 0.307 58.48MB 5.52 1 18 3.26s <data.table> <Rprofmem> 10 join 100000 12.14ms 13.07ms 64.7 9.28MB 7.84 33 4 509.99ms <data.table> <Rprofmem> 11 r2evans 1000000 30.76s 30.76s 0.0325 583.7MB 0.845 1 26 30.76s <data.table> <Rprofmem> 12 join 1000000 74.74ms 141.19ms 1.65 91.68MB 0.826 4 2 2.42s <data.table> <Rprofmem> # … with 2 more variables: time <list>, gc <list>
ggplot2::autoplot(bm)
注意 bench::mark() 默认检查结果是否相等。