我想根据列的间隔（data.table）汇总time。这里的想法是每个间隔应该是一个单独的列，在输出中具有不同的名称。
我见过a similar question in SO，但我无法理解这个问题。帮助
library(data.table)
# sample data
set.seed(1L)
dt <- data.table( id= sample(LETTERS,50,replace=TRUE),
time= sample(60,50,replace=TRUE),
points= sample(1000,50,replace=TRUE))
# simple summary by `id`
dt[, .(total = sum(points)), by=id]
> id total
> 1: J 2058
> 2: T 1427
> 3: C 1020
在所需输出中，每列将以它们来自的间隔大小命名。例如，有三个时间间隔，例如time < 10，time < 20，time < 30，输出的头部应为：
id | total | subtotal_under10 | subtotal_under20 | subtotal_under30
答案 0 :(得分：4)
set.seed(1L);
N <- 50L;
dt <- data.table(id=sample(LETTERS,N,T),time=sample(60L,N,T),points=sample(1000L,N,T));
breaks <- seq(0L,as.integer(ceiling((max(dt$time)+1L)/10)*10),10L);
cuts <- cut(dt$time,breaks,labels=paste0('subtotal_under',breaks[-1L]),right=F);
res <- dcast(dt[,.(subtotal=sum(points)),.(id,cut=cuts)],id~cut,value.var='subtotal');
res <- res[dt[,.(total=sum(points)),id]][order(id)];
res;
## id subtotal_under10 subtotal_under20 subtotal_under30 subtotal_under40 subtotal_under50 subtotal_under60 total
## 1: A NA NA 176 NA NA 512 688
## 2: B NA NA 599 NA NA NA 599
## 3: C 527 NA NA NA NA NA 527
## 4: D NA NA 174 NA NA NA 174
## 5: E NA 732 643 NA NA NA 1375
## 6: F 634 NA NA NA NA 1473 2107
## 7: G NA NA 1410 NA NA NA 1410
## 8: I NA NA NA NA NA 596 596
## 9: J 447 NA 640 NA NA 354 1441
## 10: K 508 NA NA NA NA 454 962
## 11: M NA 14 1358 NA NA NA 1372
## 12: N NA NA NA NA 730 NA 730
## 13: O NA NA 271 NA NA 259 530
## 14: P NA NA NA NA 78 NA 78
## 15: Q 602 NA 485 NA 925 NA 2012
## 16: R NA 599 357 479 NA NA 1435
## 17: S NA 986 716 865 NA NA 2567
## 18: T NA NA NA NA 105 NA 105
## 19: U NA NA NA 239 1163 641 2043
## 20: V NA 683 NA NA 929 NA 1612
## 21: W NA NA NA NA 229 NA 229
## 22: X 214 993 NA NA NA NA 1207
## 23: Y NA 130 992 NA NA NA 1122
## 24: Z NA NA NA NA 104 NA 104
## id subtotal_under10 subtotal_under20 subtotal_under30 subtotal_under40 subtotal_under50 subtotal_under60 total
我已经根据累积小计的要求提出了一个新的解决方案。
我的目标是避免循环操作，例如lapply()，因为我意识到应该可以仅使用向量化操作（例如findInterval()，矢量化/累积操作（例如{）来计算所需结果。 {1}}和矢量索引。
我成功了，但是我应该警告你，算法在逻辑方面是相当复杂的。我试着在下面解释一下。
cumsum()breaks <- seq(0L,as.integer(ceiling((max(dt$time)+1L)/10)*10),10L);
ints <- findInterval(dt$time,breaks);
res <- dt[,{ y <- ints[.I]; o <- order(y); y <- y[o]; w <- which(c(y[-length(y)]!=y[-1L],T)); v <- rep(c(NA,w),diff(c(1L,y[w],length(breaks)))); c(sum(points),as.list(cumsum(points[o])[v])); },id][order(id)];
setnames(res,2:ncol(res),c('total',paste0('subtotal_under',breaks[-1L])));
res;
## id total subtotal_under10 subtotal_under20 subtotal_under30 subtotal_under40 subtotal_under50 subtotal_under60
## 1: A 688 NA NA 176 176 176 688
## 2: B 599 NA NA 599 599 599 599
## 3: C 527 527 527 527 527 527 527
## 4: D 174 NA NA 174 174 174 174
## 5: E 1375 NA 732 1375 1375 1375 1375
## 6: F 2107 634 634 634 634 634 2107
## 7: G 1410 NA NA 1410 1410 1410 1410
## 8: I 596 NA NA NA NA NA 596
## 9: J 1441 447 447 1087 1087 1087 1441
## 10: K 962 508 508 508 508 508 962
## 11: M 1372 NA 14 1372 1372 1372 1372
## 12: N 730 NA NA NA NA 730 730
## 13: O 530 NA NA 271 271 271 530
## 14: P 78 NA NA NA NA 78 78
## 15: Q 2012 602 602 1087 1087 2012 2012
## 16: R 1435 NA 599 956 1435 1435 1435
## 17: S 2567 NA 986 1702 2567 2567 2567
## 18: T 105 NA NA NA NA 105 105
## 19: U 2043 NA NA NA 239 1402 2043
## 20: V 1612 NA 683 683 683 1612 1612
## 21: W 229 NA NA NA NA 229 229
## 22: X 1207 214 1207 1207 1207 1207 1207
## 23: Y 1122 NA 130 1122 1122 1122 1122
## 24: Z 104 NA NA NA NA 104 104
## id total subtotal_under10 subtotal_under20 subtotal_under30 subtotal_under40 subtotal_under50 subtotal_under60
首先，我们像以前一样派生breaks <- seq(0L,as.integer(ceiling((max(dt$time)+1L)/10)*10),10L);
breaks <- seq(0,ceiling(max(dt$time)/10)*10,10); ## old derivation, for reference
。我应该提一下，我意识到我的原始推导算法中存在一个微妙的错误。也就是说，如果最大breaks值是10的倍数，那么派生的time向量将会缩短1.请考虑我们的最大breaks值是否为60序列上限的原始计算将是time，再次只有60。但它应该是70，因为值60在技术上属于ceiling(60/10)*10区间。我通过在计算序列的上限时将最大60 <= time < 70值加1来修复新代码（并追溯修改旧代码）。我还将两个文字更改为整数，并添加了time强制以保留整数。
as.integer()其次，我们预先计算每个ints <- findInterval(dt$time,breaks);
值落入的区间索引。我们可以对整个表预先计算一次，因为我们能够在后续data.table索引操作的time参数中索引每个id组的子集。请注意j使用默认参数完全符合我们的目的;我们不需要弄乱findInterval()，rightmost.closed或all.inside。这是因为left.open默认使用findInterval()逻辑，并且值不可能低于最低中断（为零）或高于或高于最高中断（必须更高）因为我们推导出它的方式而不是最大lower <= value < upper值。
time第三，我们使用data.table索引操作计算聚合，按res <- dt[,{ y <- ints[.I]; o <- order(y); y <- y[o]; w <- which(c(y[-length(y)]!=y[-1L],T)); v <- rep(c(NA,w),diff(c(1L,y[w],length(breaks)))); c(sum(points),as.list(cumsum(points[o])[v])); },id][order(id)];
分组。 （之后我们使用链式索引操作按id排序，但这并不重要。）id参数由在支撑块中执行的6个语句组成，现在我将解释一个时间。
j这将按输入顺序拉出当前y <- ints[.I];
组的间隔索引。
id按间隔捕获组记录的顺序。我们将需要此顺序用于o <- order(y);
的累积求和，以及该累积和中的哪些索引表示所需的间隔小计的推导。请注意，区间内订单（即联系）是无关紧要的，因为我们只会提取每个区间的最终小计，无论points是否以及如何打破关系，这将是相同的。
order()这实际上会将y <- y[o];
重新排序为间隔顺序。
y这会计算每个间隔序列的端点，只有那些构成间隔的 final 元素的元素的索引。此向量将始终包含至少一个索引，它将永远不会包含比间隔更多的索引，并且它将是唯一的。
w <- which(c(y[-length(y)]!=y[-1L],T));
根据其距离（按间隔测量）从其后续元素重复v <- rep(c(NA,w),diff(c(1L,y[w],length(breaks))));
的每个元素。我们在w上使用diff()来计算这些距离，需要附加y[w]元素来正确处理length(breaks)的最终元素。如果第一个间隔（以及零个或多个后续间隔）未在组中表示，我们还需要覆盖，在这种情况下，我们必须用NA填充它。这需要将NA添加到w并在参数向量前加1 w。
diff()最后，我们可以计算组聚合结果。由于您需要一个总列，然后需要单独的小计列，我们需要一个以总聚合开始的列表，然后是每个小计值一个列表组件。 c(sum(points),as.list(cumsum(points[o])[v]));
以间隔顺序给出目标求和操作数，然后我们累加求和，然后用points[o]索引以生成正确的累加小计序列。我们必须使用v将向量强制转换为列表，然后在列表前面加上总聚合，这只是整个as.list()向量的总和。然后从points表达式返回结果列表。
j最后，我们设置列名称。在事后设置它们更为高效，而不是在setnames(res,2:ncol(res),c('total',paste0('subtotal_under',breaks[-1L])));
表达式中重复设置它们。
对于基准测试，我将我的代码包装在一个函数中，并为Mike的代码做了同样的事情。我决定使我的j变量成为一个参数，其派生作为默认参数，我对Mike的breaks变量做了相同的操作，但没有默认参数。
另请注意，对于my_nums等价证明，我将两个结果强制转换为矩阵，因为Mike的代码总是将total和subtotal列计算为double，而我的代码保留了类型输入identical()列的输出（如果它是整数则为整数，如果为双，则为double）。强制转换为矩阵是我能够想到的最简单的方法来验证实际数据是否相同。
pointslibrary(data.table);
library(microbenchmark);
bgoldst <- function(dt,breaks=seq(0L,as.integer(ceiling((max(dt$time)+1L)/10)*10),10L)) { ints <- findInterval(dt$time,breaks); res <- dt[,{ y <- ints[.I]; o <- order(y); y <- y[o]; w <- which(c(y[-length(y)]!=y[-1L],T)); v <- rep(c(NA,w),diff(c(1L,y[w],length(breaks)))); c(sum(points),as.list(cumsum(points[o])[v])); },id][order(id)]; setnames(res,2:ncol(res),c('total',paste0('subtotal_under',breaks[-1L]))); res; };
mike <- function(dt,my_nums) { cols <- sapply(1:length(my_nums),function(x){return(paste0("subtotal_under",my_nums[x]))}); dt[,(cols) := lapply(my_nums,function(x) ifelse(time<x,points,NA))]; dt[,total := points]; dt[,lapply(.SD,function(x){ if (all(is.na(x))){ as.numeric(NA) } else{ as.numeric(sum(x,na.rm=TRUE)) } }),by=id, .SDcols=c("total",cols) ][order(id)]; };
## OP's sample input
set.seed(1L);
N <- 50L;
dt <- data.table(id=sample(LETTERS,N,T),time=sample(60L,N,T),points=sample(1000L,N,T));
identical(as.matrix(bgoldst(copy(dt))),as.matrix(mike(copy(dt),c(10,20,30,40,50,60))));
## [1] TRUE
microbenchmark(bgoldst(copy(dt)),mike(copy(dt),c(10,20,30,40,50,60)));
## Unit: milliseconds
## expr min lq mean median uq max neval
## bgoldst(copy(dt)) 3.281380 3.484301 3.793532 3.588221 3.780023 6.322846 100
## mike(copy(dt), c(10, 20, 30, 40, 50, 60)) 3.243746 3.442819 3.731326 3.526425 3.702832 5.618502 100
对于这么大的输入，我的代码明显优于迈克。
如果您想知道为什么我必须将70添加到Mike的## large input 1
set.seed(1L);
N <- 1e5L;
dt <- data.table(id=sample(LETTERS,N,T),time=sample(60L,N,T),points=sample(1000L,N,T));
identical(as.matrix(bgoldst(copy(dt))),as.matrix(mike(copy(dt),c(10,20,30,40,50,60,70))));
## [1] TRUE
microbenchmark(bgoldst(copy(dt)),mike(copy(dt),c(10,20,30,40,50,60,70)));
## Unit: milliseconds
## expr min lq mean median uq max neval
## bgoldst(copy(dt)) 19.44409 19.96711 22.26597 20.36012 21.26289 62.37914 100
## mike(copy(dt), c(10, 20, 30, 40, 50, 60, 70)) 94.35002 96.50347 101.06882 97.71544 100.07052 146.65323 100
论证中，那是因为有了这么多记录，获得60分的概率my_nums的随机生成非常高，这需要额外的间隔。你可以看到dt$time调用给出了TRUE，所以这是正确的。
identical()对于这个更大的输入，性能差异稍微明显。
答案 1 :(得分：4)
我很确定这样的事情也可以起作用：
# sample data
set.seed(1)
dt <- data.table( id= sample(LETTERS,50,replace=TRUE),
time= sample(60,50,replace=TRUE),
points= sample(1000,50,replace=TRUE))
#Input numbers
my_nums <- c(10,20,30)
#Defining columns
cols <- sapply(1:length(my_nums),function(x){return(paste0("subtotal_under",my_nums[x]))})
dt[,(cols) := lapply(my_nums,function(x) ifelse(time<x,points,NA))]
dt[,total := sum((points)),by=id]
dt[,(cols):= lapply(.SD,sum,na.rm=TRUE),by=id, .SDcols=cols ]
head(dt)
id time points subtotal_under10 subtotal_under20 subtotal_under30 total
1: G 29 655 0 0 1410 1410
2: J 52 354 447 447 1087 1441
3: O 27 271 0 0 271 530
4: X 15 993 214 1207 1207 1207
5: F 5 634 634 634 634 2107
6: X 6 214 214 1207 1207 1207
编辑：要汇总列，您只需更改为：
即可#Defining columns
cols <- sapply(1:length(my_nums),function(x){return(paste0("subtotal_under",my_nums[x]))})
dt[,(cols) := lapply(my_nums,function(x) ifelse(time<x,points,NA))]
dt[,total := points]
dt[,lapply(.SD,function(x){
if (all(is.na(x))){
as.numeric(NA)
} else{
as.numeric(sum(x,na.rm=TRUE))
}
}),by=id, .SDcols=c("total",cols) ]
这应该给出每个ID 1行的预期输出。
编辑：下面的每个OP评论，更改为0为NA。已更改，因此在构建列时不需要as.numeric（）调用。
答案 2 :(得分：1)
经过一段时间的思考，我想我已经达成了一个基于条件总和的非常简单快速的解决方案！ small 问题是我还没有弄清楚如何自动化这段代码来创建更多的列而不必编写每一列。这里的任何帮助都会受到欢迎！
library(data.table)
dt[, .( total = sum(points)
, subtotal_under10 = sum(points[which( time < 10)])
, subtotal_under20 = sum(points[which( time < 20)])
, subtotal_under30 = sum(points[which( time < 30)])
, subtotal_under40 = sum(points[which( time < 40)])
, subtotal_under50 = sum(points[which( time < 50)])
, subtotal_under60 = sum(points[which( time < 60)])), by=id][order(id)]
<强>微基准
在另一个答案中使用@bgoldst提出的相同基准，这个简单的解决方案比其他选择快得多：
set.seed(1L)
N <- 1e6L
dt <- data.table(id=sample(LETTERS,N,T),time=sample(60L,N,T),points=sample(1000L,N,T))
library(microbenchmark)
microbenchmark(rafa(copy(dt)),bgoldst(copy(dt)),mike(copy(dt),c(10,20,30,40,50,60)))
# expr min lq mean median uq max neval cld
# rafa(copy(dt)) 95.79 102.45 117.25 110.09 116.95 278.50 100 a
# bgoldst(copy(dt)) 192.53 201.85 211.04 207.50 213.26 354.17 100 b
# mike(copy(dt), c(10, 20, 30, 40, 50, 60)) 844.80 890.53 955.29 921.27 1041.96 1112.18 100 c