R:在 data.tables 列表中创建多个列并根据分组变量的条件修改它们

R: Create multiple columns in list of data.tables and modify them with condition on a grouping variable

我有一个数据表列表,如下所示:

group1 <- data.table(
    group = rep(x = c("group1"), each = 16),
    amount = rep(x = 7:4, each = 4),
    subgr = rep(x = 1:2, each = 8),    
    ind = rep(x = 0:1, each = 4, times = 2)
  )

group2 <- data.table(
    group = rep(x = c("group2"), each = 36),
    amount = rep(x = 13:8, each = 6),
    subgr = rep(x = 1:3, each = 12),
    ind = rep(x = 0:1, each = 6, times = 3)
  )

mydt <- rbind(group1, group2)

mydt <- lapply(X = split(x = 1:nrow(mydt), f = mydt[["group"]]),
FUN = function(i)mydt[i])

上面显示的对象过于简单,实际列表包含更多更大的 data.tables,每个在 subgr 中分布的行数和 data.table 的结构略有不同=16=] 他们自己。我想要实现的是:

  1. 在列表中的每个 data.table 中创建多个列,等于 subgr 中唯一值的数量。每个新列都是 amount 的副本。复制的列数将等于 subgr.
  2. 中唯一值的数量
  3. 修改每个 subgr 中新创建的列(如果 ind == 1 则为 amount*2,如果 ind ==0 则为 amount*4),保留其余值在 subgr 的子组中未受影响。

也就是说,要有这样的东西(这里只显示 mydt$group1,但它适用于所有表):

$group1
     group amount subgr ind am1 am2
 1: group1      7     1   0  28   7
 2: group1      7     1   0  28   7
 3: group1      7     1   0  28   7
 4: group1      7     1   0  28   7
 5: group1      6     1   1  12   6
 6: group1      6     1   1  12   6
 7: group1      6     1   1  12   6
 8: group1      6     1   1  12   6
 9: group1      5     2   0   5  20
10: group1      5     2   0   5  20
11: group1      5     2   0   5  20
12: group1      5     2   0   5  20
13: group1      4     2   1   4   8
14: group1      4     2   1   4   8
15: group1      4     2   1   4   8
16: group1      4     2   1   4   8

我知道将 data.table 拆分为 data.table 的列表不是一个好主意,如 this post 中所述,但这就是对象的样子。除此之外,拆分与我需要执行的任务有关:

  1. 数据表包含不同的行数。
  2. 这些行被分组到 subgr 定义的子组中,它们的数量在不同的数据表中也不同,即新列的数量在整个列表中将不同。

也就是说,不能一次处理整个 data.table,因为将在 group 变量中为每个组创建不同数量的列。

到目前为止我尝试的是使用 this post:

接受的答案中的第二种解决方案编写一个函数
myfun <- function(data, quantity, region, index) {
  data <- lapply(data, function(i) {
    i[ , eval(paste0("am", unique(i[[region]]))) := i[[quantity]]]
  })
  data <- lapply(X = data, FUN = function(i) {
    rep.names <- paste0("am", unique(i[[region]]))
    i[ , eval(rep.names) := lapply(.SD, function(j) {
      ifelse(i[["ind"]] == 1L, j*2L, j*4L)
      }), by = region, .SDcols = rep.names]
  })
  return(data)
}

myfun(mydt, quantity = "amount", region = "subgr", index = "ind")

它没有按预期工作,它根据条件修改了所有变量中的整个值范围。但是,它会发出警告,指出问题所在。这里只是第一个警告,其他都是一样的:

Warning messages:
1: In `[.data.table`(i, , `:=`(eval(rep.names), lapply(.SD,  ... :
  RHS 1 is length 16 (greater than the size (8) of group 1). The last
8 element(s) will be discarded.

也就是说,它只使用在左轴上必须使用的行,然后在右轴上使用整列。显然我在这里遗漏了一些重要的东西。 [this post][3] 接受的答案与第二种解决方案的不同之处在于,有多个列可供使用,而在我的例子中只有一个 (amount).

有人可以帮忙吗?

您的错误来自 i[["ind"]] 的长度,它包含数据集中的所有行,而 j 仅包含组中的行:

ifelse(i[["ind"]] == 1L, j*2L, j*4L)

有多种方法可以解决此问题并实现您的目标,这就是我的做法:

myfun <- function(data, quantity, region, index) {
        lapply(data, function(i) {
                i[ , eval(paste0("am", unique(i[[region]]))) := lapply(unique(i[[region]]), function(j)
                        {i[[quantity]]*ifelse(j==i[[region]],ifelse(ind==1, 2, 4), 1)})]
        })
}
myfun(mydt, quantity = "amount", region = "subgr", index = "ind")
$group1
     group amount subgr ind am1 am2
 1: group1      7     1   0  28   7
 2: group1      7     1   0  28   7
 3: group1      7     1   0  28   7
 4: group1      7     1   0  28   7
 5: group1      6     1   1  12   6
 6: group1      6     1   1  12   6
 7: group1      6     1   1  12   6
 8: group1      6     1   1  12   6
 9: group1      5     2   0   5  20
10: group1      5     2   0   5  20
11: group1      5     2   0   5  20
12: group1      5     2   0   5  20
13: group1      4     2   1   4   8
14: group1      4     2   1   4   8
15: group1      4     2   1   4   8
16: group1      4     2   1   4   8

$group2
     group amount subgr ind am1 am2 am3
 1: group2     13     1   0  52  13  13
 2: group2     13     1   0  52  13  13
 3: group2     13     1   0  52  13  13
 4: group2     13     1   0  52  13  13
 5: group2     13     1   0  52  13  13
 6: group2     13     1   0  52  13  13
 7: group2     12     1   1  24  12  12
 8: group2     12     1   1  24  12  12
 9: group2     12     1   1  24  12  12
10: group2     12     1   1  24  12  12
11: group2     12     1   1  24  12  12
12: group2     12     1   1  24  12  12
13: group2     11     2   0  11  44  11
14: group2     11     2   0  11  44  11
15: group2     11     2   0  11  44  11
16: group2     11     2   0  11  44  11
17: group2     11     2   0  11  44  11
18: group2     11     2   0  11  44  11
19: group2     10     2   1  10  20  10
20: group2     10     2   1  10  20  10
21: group2     10     2   1  10  20  10
22: group2     10     2   1  10  20  10
23: group2     10     2   1  10  20  10
24: group2     10     2   1  10  20  10
25: group2      9     3   0   9   9  36
26: group2      9     3   0   9   9  36
27: group2      9     3   0   9   9  36
28: group2      9     3   0   9   9  36
29: group2      9     3   0   9   9  36
30: group2      9     3   0   9   9  36
31: group2      8     3   1   8   8  16
32: group2      8     3   1   8   8  16
33: group2      8     3   1   8   8  16
34: group2      8     3   1   8   8  16
35: group2      8     3   1   8   8  16
36: group2      8     3   1   8   8  16

我建议这是一个适合 for 循环的任务。您可以遍历列表并就地修改每个 data.table,而不必重建列表,这正是 lapply() 所做的。

此外,我建议您先在矩阵中构建 am* 列,然后再将它们分配给目标 data.table。通过将 amount 作为基础数据向量传递,我们可以一次性完成所有 am* 列的大部分方法,因为大多数单元格直接从 amount 列获取它们的值没有任何变化,特别是如果有许多独特的 subgr 值。之后,我们可以通过使用索引矩阵对数据矩阵进行索引分配来选择性地修改必须更改的单元格。构建索引矩阵将相当容易,因为我们知道每行只有一个单元格必须更改。基本上,我们可以 cbind() 行索引序列 .I 以及从 match(subgr,grs) 计算出的所需列索引,其中 grssubgr 值的唯一集合。这比对每个 am* 列进行 j==i[[region]] 这样的相等比较更有效。

for (i in seq_along(mydt)) {
    grs <- unique(mydt[[i]]$subgr);
    mydt[[i]][,paste0('am',grs):={
        m <- matrix(amount,.N,length(grs));
        m[cbind(.I,match(subgr,grs))] <- amount*ifelse(ind==1L,2L,4L);
        as.data.frame(m);
    }];
}; ## end for
mydt;
## $group1
##      group amount subgr ind am1 am2
##  1: group1      7     1   0  28   7
##  2: group1      7     1   0  28   7
##  3: group1      7     1   0  28   7
##  4: group1      7     1   0  28   7
##  5: group1      6     1   1  12   6
##  6: group1      6     1   1  12   6
##  7: group1      6     1   1  12   6
##  8: group1      6     1   1  12   6
##  9: group1      5     2   0   5  20
## 10: group1      5     2   0   5  20
## 11: group1      5     2   0   5  20
## 12: group1      5     2   0   5  20
## 13: group1      4     2   1   4   8
## 14: group1      4     2   1   4   8
## 15: group1      4     2   1   4   8
## 16: group1      4     2   1   4   8
##
## $group2
##      group amount subgr ind am1 am2 am3
##  1: group2     13     1   0  52  13  13
##  2: group2     13     1   0  52  13  13
##  3: group2     13     1   0  52  13  13
##  4: group2     13     1   0  52  13  13
##  5: group2     13     1   0  52  13  13
##  6: group2     13     1   0  52  13  13
##  7: group2     12     1   1  24  12  12
##  8: group2     12     1   1  24  12  12
##  9: group2     12     1   1  24  12  12
## 10: group2     12     1   1  24  12  12
## 11: group2     12     1   1  24  12  12
## 12: group2     12     1   1  24  12  12
## 13: group2     11     2   0  11  44  11
## 14: group2     11     2   0  11  44  11
## 15: group2     11     2   0  11  44  11
## 16: group2     11     2   0  11  44  11
## 17: group2     11     2   0  11  44  11
## 18: group2     11     2   0  11  44  11
## 19: group2     10     2   1  10  20  10
## 20: group2     10     2   1  10  20  10
## 21: group2     10     2   1  10  20  10
## 22: group2     10     2   1  10  20  10
## 23: group2     10     2   1  10  20  10
## 24: group2     10     2   1  10  20  10
## 25: group2      9     3   0   9   9  36
## 26: group2      9     3   0   9   9  36
## 27: group2      9     3   0   9   9  36
## 28: group2      9     3   0   9   9  36
## 29: group2      9     3   0   9   9  36
## 30: group2      9     3   0   9   9  36
## 31: group2      8     3   1   8   8  16
## 32: group2      8     3   1   8   8  16
## 33: group2      8     3   1   8   8  16
## 34: group2      8     3   1   8   8  16
## 35: group2      8     3   1   8   8  16
## 36: group2      8     3   1   8   8  16
##      group amount subgr ind am1 am2 am3
##

基准测试

library(microbenchmark);
library(data.table);

hubert <- function(mydt) { myfun <- function(data, quantity, region, index) lapply(data, function(i) i[ , eval(paste0("am", unique(i[[region]]))) := lapply(unique(i[[region]]), function(j) {i[[quantity]]*ifelse(j==i[[region]],ifelse(ind==1, 2, 4), 1)})] ); myfun(mydt, quantity = "amount", region = "subgr", index = "ind"); };
bgoldst <- function(mydt) { for (i in seq_along(mydt)) { grs <- unique(mydt[[i]]$subgr); mydt[[i]][,paste0('am',grs):={ m <- matrix(amount,.N,length(grs)); m[cbind(.I,match(subgr,grs))] <- amount*ifelse(ind==1L,2L,4L); as.data.frame(m); }]; }; mydt; };

## OP's example
group1 <- data.table(group=rep(x=c("group1"),each=16),amount=rep(x=7:4,each=4),subgr=rep(x=1:2,each=8),ind=rep(x=0:1,each=4,times=2));
group2 <- data.table(group=rep(x=c("group2"),each=36),amount=rep(x=13:8,each=6),subgr=rep(x=1:3,each=12),ind=rep(x=0:1,each=6,times=3));
mydt <- rbind(group1,group2);
mydt <- lapply(X=split(x=1:nrow(mydt),f=mydt[["group"]]),FUN=function(i)mydt[i]);

ex <- hubert(lapply(mydt,copy));
all.equal(ex,bgoldst(lapply(mydt,copy)));
## [1] TRUE

microbenchmark(hubert(lapply(mydt,copy)),bgoldst(lapply(mydt,copy)));
## Unit: milliseconds
##                         expr      min       lq     mean   median       uq      max neval
##   hubert(lapply(mydt, copy)) 2.579173 2.632417 2.837445 2.669621 2.736549 6.555914   100
##  bgoldst(lapply(mydt, copy)) 2.603977 2.683092 2.880715 2.723078 2.781025 4.376168   100

## scale test
set.seed(1L);
NR <- 1e5L; NGRP <- 1e3L; NAMT <- 30L; NSUBGR <- 30L;
mydt <- data.table(group=paste0('group',sample(NGRP,NR,T)),amount=sample(NAMT,NR,T),subgr=sample(NSUBGR,NR,T),ind=sample(0:1,NR,T));
mydt <- split(mydt,mydt$group);

ex <- hubert(lapply(mydt,copy));
all.equal(ex,bgoldst(lapply(mydt,copy)));
## [1] TRUE

microbenchmark(hubert(lapply(mydt,copy)),bgoldst(lapply(mydt,copy)));
## Unit: seconds
##                         expr      min       lq     mean   median       uq      max neval
##   hubert(lapply(mydt, copy)) 2.831080 2.899419 2.938751 2.935096 2.970701 3.110481   100
##  bgoldst(lapply(mydt, copy)) 1.571023 1.647102 1.674666 1.671877 1.709434 1.845174   100