R 按组对不同的列集应用不同的函数

我有一个

数据表

，具有以下功能：

• bycols

  ：将数据分组的列

• nonvaryingcols

  ：在每组中保持不变的列（这样，从每组中取出第一个项目并执行就足够了）

• datacols

  ：要聚合/汇总的列（例如，在组内汇总）

我很好奇，将上述三个输入都作为字符向量，最有效的方法是什么，你可以称之为混合折叠。它不一定是绝对最快的，但是足够快的速度和合理的语法将是理想的

示例数据，其中不同的列集存储在字符向量中

require(data.table)
set.seed(1)
bycols <- c("g1","g2")
datacols <- c("dat1","dat2")
nonvaryingcols <- c("nv1","nv2")
test <- data.table(
  g1 = rep( letters, 10 ),
  g2 = rep( c(LETTERS,LETTERS), each = 5 ),
  dat1 = runif( 260 ),
  dat2 = runif( 260 ),
  nv1 = rep( seq(130), 2),
  nv2 = rep( seq(130), 2) 
)

---

我已经想出了两种不同的方法，但其中一种是非常不灵活和笨拙的，另一种是非常缓慢的。如果到那时还没有人想出更好的方法，明天就会发布。

像往常一样，通过编程使用

[.data.table

，一般策略是构造一个表达式

e

，可以在

j

参数中计算。一旦您理解了这一点（我相信您会这样做），获得一个类似于您在命令行中编写的

j

-slot表达式就成了一个游戏

例如，在这里，并给出示例中的特定值，您希望调用如下所示：

test[, list(dat1=sum(dat1), dat2=sum(dat2), nv1=nv1[1], nv2=nv2[1]),
       by=c("g1", "g2")]

因此，您希望在

j

-槽中计算的表达式是

list(dat1=sum(dat1), dat2=sum(dat2), nv1=nv1[1], nv2=nv2[1])

以下大部分函数用于构造该表达式：

f <- function(dt, bycols, datacols, nvcols) {
    e <- c(sapply(datacols, function(x) call("sum", as.symbol(x))),
           sapply(nvcols, function(x) call("[", as.symbol(x), 1)))
    e<- as.call(c(as.symbol("list"), e))
    dt[,eval(e), by=bycols]
}

f(test, bycols=bycols, datacols=datacols, nvcols=nonvaryingcols)
##      g1 g2      dat1      dat2 nv1 nv2
##   1:  a  A 0.8403809 0.6713090   1   1
##   2:  b  A 0.4491883 0.4607716   2   2
##   3:  c  A 0.6083939 1.2031960   3   3
##   4:  d  A 1.5510033 1.2945761   4   4
##   5:  e  A 1.1302971 0.8573135   5   5
##  ---                                  
## 126:  v  Z 0.5627018 0.4282380 126 126
## 127:  w  Z 0.7588966 1.4429034 127 127
## 128:  x  Z 0.7060596 1.3736510 128 128
## 129:  y  Z 0.6015249 0.4488285 129 129
## 130:  z  Z 1.5304034 1.6012207 130 130

---

f这是我想到的。它可以工作，但速度很慢

test[, {
  cbind(
    as.data.frame( t( sapply( .SD[, ..datacols], sum ) ) ),
    .SD[, ..nonvaryingcols][1]
  )
}, by = bycols ]

基准

FunJosh <- function() {
  f(test, bycols=bycols, datacols=datacols, nvcols=nonvaryingcols)
}
FunAri <- function() {
  test[, {
    cbind(
      as.data.frame( t( sapply( .SD[, ..datacols], sum ) ) ),
      .SD[, ..nonvaryingcols][1]
    )
  }, by = bycols ]
}
FunEddi <- function() {
  cbind(
    test[, lapply(.SD, sum), by = bycols, .SDcols = datacols], 
    test[, lapply(.SD, "[", 1), by = bycols, .SDcols = nonvaryingcols][, ..nonvaryingcols]
  ) 
}

library(microbenchmark)
identical(FunJosh(), FunAri())
# [1] TRUE

microbenchmark(FunJosh(), FunAri(), FunEddi())
#Unit: milliseconds
#      expr        min         lq     median         uq        max neval
# FunJosh()   2.749164   2.958478   3.098998   3.470937   6.863933   100
#  FunAri() 246.082760 255.273839 284.485654 360.471469 509.740240   100
# FunEddi()   5.877494   6.229739   6.528205   7.375939 112.895573   100

FunJosh只是为了增加一点多样性，这里有一个@Josh O'brien解决方案的变体，它使用
bquote
操作符而不是
call
。我曾尝试用bquote替换最后的as.call，但因为bquote不支持列表拼接（例如，请参见），所以我无法实现

f <- function(dt, bycols, datacols, nvcols) {
        datacols = sapply(datacols, as.symbol)
        nvcols = sapply(nvcols, as.symbol)
        e = c(lapply(datacols, function(x) bquote(sum(.(x)))),
              lapply(nvcols, function(x) bquote(.(x)[1])))
        e = as.call(c(as.symbol("list"), e))
        dt[,eval(e), by=bycols]
}


>   f(test, bycols=bycols, datacols=datacols, nvcols=nonvaryingcols)
     g1 g2   dat1   dat2 nv1 nv2
  1:  a  A 0.8404 0.6713   1   1
  2:  b  A 0.4492 0.4608   2   2
  3:  c  A 0.6084 1.2032   3   3
  4:  d  A 1.5510 1.2946   4   4
  5:  e  A 1.1303 0.8573   5   5
 ---                            
126:  v  Z 0.5627 0.4282 126 126
127:  w  Z 0.7589 1.4429 127 127
128:  x  Z 0.7061 1.3737 128 128
129:  y  Z 0.6015 0.4488 129 129
130:  z  Z 1.5304 1.6012 130 130
> 

f（测试，bycols=bycols，datacols=datacols，nvcols=nonvaryingcols）
g1 g2 dat1 dat2 nv1 nv2
1:a 0.84040.6713 1
2:BA0.4492 0.46082
3:CA0.60841.20323
4:d A 1.5510 1.2946 4
5:EA1.13030.85735
---                            
126:VZ0.56270.4282126
127:w Z 0.7589 1.4429 127
128:xz0.7061 1.3737128
129:y Z 0.60150.4488 129
130:z z 1.5304 1.6012 130
> 
谢谢@JoshOBrien。这很有意义。马上发布我的带有基准测试的慢速解决方案。@eddi感谢您进行了修复。如果您要走
cbind
路线，最好执行
cbind（test[，lapply（.SD，sum），by=bycols，.SDcols=datacols]，test[，lapply（.SD，[，1），by=bycols，.SDcols=nonvaryingcols][，nonvaryingcols，with=F]）
。
f <- function(dt, bycols, datacols, nvcols) {
        datacols = sapply(datacols, as.symbol)
        nvcols = sapply(nvcols, as.symbol)
        e = c(lapply(datacols, function(x) bquote(sum(.(x)))),
              lapply(nvcols, function(x) bquote(.(x)[1])))
        e = as.call(c(as.symbol("list"), e))
        dt[,eval(e), by=bycols]
}


>   f(test, bycols=bycols, datacols=datacols, nvcols=nonvaryingcols)
     g1 g2   dat1   dat2 nv1 nv2
  1:  a  A 0.8404 0.6713   1   1
  2:  b  A 0.4492 0.4608   2   2
  3:  c  A 0.6084 1.2032   3   3
  4:  d  A 1.5510 1.2946   4   4
  5:  e  A 1.1303 0.8573   5   5
 ---                            
126:  v  Z 0.5627 0.4282 126 126
127:  w  Z 0.7589 1.4429 127 127
128:  x  Z 0.7061 1.3737 128 128
129:  y  Z 0.6015 0.4488 129 129
130:  z  Z 1.5304 1.6012 130 130
>