r - 将多个字符列映射到数值的最快方法

Question

我有一个算法，在每次迭代时计算特定组的均值(这些组不只改变它们的值)。

值表 -

d1 <- data.frame(x = sample(LETTERS, N, replace = TRUE), 
                  y1=rnorm(N))
head(d1)
#   x         y1
# 1 H -0.7852538
# 2 G -0.6739159
# 3 V -1.7783771
# 4 L -0.2849846
# 5 I -0.1760284
# 6 V -0.2785826

我可以计算均值(有几种方式:dplyr、data.table 和 tapply)。我有另一个 data.frame，由两列和组名组成。

d2 <- data.frame('group.high' = sample(LETTERS, N * 2, replace = TRUE), 
                 'group.low' = sample(LETTERS, N * 2, replace = TRUE))
head(d2)
#   group.high group.low
# 1          U         L
# 2          K         J
# 3          C         Q
# 4          Q         A
# 5          Q         U
# 6          K         W

我想将基于 d1 的每组平均值添加到列 mean.high 和 mean.better。

到目前为止，我已经尝试了 dplyr 和 data.table 中的两个选项。我不得不在其中任何一个中使用 left_join 两次。它们的速度相似。

microbenchmark(
  dplyr = {
  means <- tapply(d1$y1, INDEX = d1$x, FUN = mean)
  ### Solution 1 
  dplyr.d2 <- left_join(d2,data.frame('group.high' = names(means), 
                                      'mean.high' = means, stringsAsFactors = FALSE) ) %>%  
    left_join(., data.frame('group.low' = names(means), 
                            'mean.low' = means, stringsAsFactors = FALSE))},
  data.table = {
  ### Solution 2 
  d1    <- as.data.table(d1)
  d2    <- as.data.table(d2)
  means <- d1[ ,.(means = mean(y1)), by = x]
  new.d2 <- data.table::merge.data.table(x = d2, y = means, by.x = 'group.high', by.y = 'x')
  data.table.d2 <- data.table::merge.data.table(x = new.d2, y = means, by.x = 'group.low', by.y = 'x')
  }
)

Unit: milliseconds
       expr     min       lq     mean  median       uq      max neval cld
      dplyr 34.0837 36.88650 53.22239 42.9227 47.50660 231.5066   100  a 
 data.table 40.2071 47.70735 87.46804 51.2517 59.05385 258.4999   100   b

有没有更好的方法？我怎样才能加快计算速度？

如评论中所述，存在更新值的迭代过程。这是一个例子。

N <- 10000

iterFuncDplyr <- function(d1, d2) { 
  dplyr.d2 <- left_join(d2,data.frame('group.high' = names(means), 
                                      'mean.high' = means, stringsAsFactors = FALSE) ) %>%  
    left_join(., data.frame('group.low' = names(means), 
                            'mean.low' = means, stringsAsFactors = FALSE))
  return(var(d1$y1))
}

iterFuncData <- function(d1, d2) { 
  means <- d1[ ,.(means = mean(y1)), by = x]
  new.d2 <- data.table:::merge.data.table(x = d2, y = means, by.x = 'group.high', by.y = 'x')
  data.table.d2 <- data.table:::merge.data.table(x = new.d2, y = means, by.x = 'group.low', by.y = 'x')
  return(var(d1$y1))
}


d1 <- data.frame(x = sample(LETTERS, N, replace = TRUE), 
                 y1=rnorm(N))

d2 <- data.frame('group.high' = sample(LETTERS, N * 2, replace = TRUE), 
                 'group.low' = sample(LETTERS, N * 2, replace = TRUE))

library(data.table)
library(dplyr)

microbenchmark::microbenchmark(dplyr = {
temp.val <- 0 

for (i in 1:10) {
  d1$y1 <- temp.val + rnorm(N)
  temp.val <- iterFuncDplyr(d1, d2)
}},
data.table = {
d1    <- as.data.table(d1)
d2    <- as.data.table(d2)

temp.val <- 0 

for (i in 1:10) {
  d1$y1 <- temp.val + rnorm(N)
  temp.val <- iterFuncData(d1, d2)
}
}
)

Unit: milliseconds
       expr      min       lq     mean   median       uq      max neval
      dplyr 46.22904 50.67959 52.78275 51.96358 53.34825 108.2874   100
 data.table 63.81111 67.13257 70.85537 69.85712 72.72446 127.4228   100

Answer 1

您可以对命名向量 means 进行子集化以创建新列并匹配您的输出:

means <- tapply(d1$y1, INDEX = d1$x, FUN = mean)
d2$mean.high <- means[d2$group.high]
d2$mean.low <- means[d2$group.low]

identical(as.matrix(d2), as.matrix(d3)) #factor vs character, used d3 w/ benchmark
[1] TRUE

Unit: microseconds
       expr    min      lq      mean   median       uq     max neval
      dplyr 4868.2 5316.25  5787.123  5524.15  5892.70 12187.3   100
 data.table 8254.4 9606.60 10438.424 10118.35 10771.75 20966.5   100
     subset  481.2  529.40   651.194   550.35   582.55  7849.9   100

基准代码:

d3 <- d2

microbenchmark::microbenchmark( # N = 10000
  dplyr = {
    means <- tapply(d1$y1, INDEX = d1$x, FUN = mean)
    ### Solution 1 
    dplyr.d2 <- left_join(d2,data.frame('group.high' = names(means), 
                                        'mean.high' = means, stringsAsFactors = FALSE) ) %>%  
      left_join(., data.frame('group.low' = names(means), 
                              'mean.low' = means, stringsAsFactors = FALSE))},
  data.table = {
    ### Solution 2 
    d1    <- as.data.table(d1)
    d2    <- as.data.table(d2)
    means <- d1[ ,.(means = mean(y1)), by = x]
    new.d2 <- data.table::merge.data.table(x = d2, y = means, by.x = 'group.high', by.y = 'x')
    data.table.d2 <- data.table::merge.data.table(x = new.d2, y = means, by.x = 'group.low', by.y = 'x')
  },
  subset = {
    means <- tapply(d1$y1, INDEX = d1$x, FUN = mean)
    d3$mean.high <- means[d2$group.high]
    d3$mean.low <- means[d2$group.low]

  }
)