使用 mapply 速度问题更新 data.table

Question

我有一个自定义函数，它的结果我想要在 data.table 中。我需要将此函数应用于另一个 data.table 的每一行中的一些变量。我有一种方法可以按照我想要的方式工作，但是速度很慢，我正在寻找是否有一种方法可以加快速度。

在我下面的示例中，重要的结果是 Column，它是在 while 循环中生成的，并且长度根据输入数据而变化，以及 Column2。

我的方法是让函数使用通过引用更新，:= 将结果附加到现有的 data.table。为了正确实现这一点，我将 Column 和 Column2 的长度设置为已知最大值，将 NA 替换为 0，然后简单地添加到现有的 data.table addTable 中，如下所示：addTable[, First:=First + Column]

此方法适用于我如何使用 mapply 在源 data.table 的每一行上应用该函数。这样，我就不必担心 mapply 调用的实际乘积（某种矩阵）；它只是为它应用 sample_fun 的每一行更新 addTable。

这是一个可重现的示例：

dt<-data.table(X= c(1:100), Y=c(.5, .7, .3, .4), Z=c(1:50000))    
addTable <- data.table(First=0, Second=0, Term=c(1:50))

sample_fun <- function(x, y, z) {
  Column <- NULL
  while(x>=1) {
    x <- x*y
    Column <- c(Column, x)
  }

  length(Column) <- nrow(addTable)
  Column[is.na(Column)] <- 0

  Column2 <- NULL
  Column2 <- rep(z, length(Column))

  addTable[, First := First + Column]
  addTable[, Second := Second + Column2]
}

如果我用 dt 在 50k 行运行它，它需要大约 30 秒：

system.time(mapply(sample_fun2, dt$X, dt$Y, dt$Z))

似乎很长一段时间（我的真实数据/功能更长）。我最初认为这是由于 while 循环造成的，因为 R 中围绕这些部分的显式循环一直存在警告。但是，在没有最后两行（更新 data.table 的地方）的情况下测试 sample_fun 时，它在 50k 行上的计时不到 1 秒。

长话短说，如果通过引用更新很快，为什么这是最慢的部分？有没有更好的方法来做到这一点？让 sample_fun 每次输出一个完整的 data.table 比我现在的要慢得多。

Answer 1

这里有几个注意事项：

1. 就目前而言，根据data.table您的需要使用可能是一种矫枉过正（尽管不一定），您可能可以避免它。
2. 您正在循环中增加对象 ( Column <- c(Column, x)) - 不要这样做。在你的情况下，没有必要。只需创建一个空的零向量，您就可以摆脱大部分功能。
3. 绝对不需要创建Column2- 它只是z- 因为 R 会自动回收它以使其适合正确的大小
4. 也不需要nrow(addTable)按行重新计算，这可能只是一个附加参数。
5. 您最大的开销是每行调用 data.table:::`[.data.table` - 这是一个非常昂贵的函数。该:=函数在这里的开销很小。如果您addTable[, First := First + Column] ; addTable[, Second := Second + Column2]仅替换，addTable$First + Column ; addTable$Second + Column2运行时间将从~35 秒减少到~2 秒。说明这另一种方法是通过用替换两条线set-例如set(addTable, j = "First", value = addTable[["First"]] + Column) ; set(addTable, j = "Second", value = addTable[["Second"]] + Column)基本上与共用的源代码:=。这也运行〜2秒
6. 最后，最好减少每行的操作量。您可以尝试使用Reduce而不是更新每行的实际数据集来累积结果。

让我们看一些例子

您的原始功能计时

library(data.table)
dt <- data.table(X= c(1:100), Y=c(.5, .7, .3, .4), Z=c(1:50000))    
addTable <- data.table(First=0, Second=0, Term=c(1:50))

sample_fun <- function(x, y, z) {
  Column <- NULL
  while(x>=1) {
    x <- x*y
    Column <- c(Column, x)
  }

  length(Column) <- nrow(addTable)
  Column[is.na(Column)] <- 0

  Column2 <- NULL
  Column2 <- rep(z, length(Column))

  addTable[, First := First + Column]
  addTable[, Second := Second + Column2]
}

system.time(mapply(sample_fun, dt$X, dt$Y, dt$Z))
#  user  system elapsed 
# 30.71    0.00   30.78 

30秒太慢了...

1- 让我们尝试删除 data.table:::`[.data.table` 开销

sample_fun <- function(x, y, z) {
  Column <- NULL
  while(x>=1) {
    x <- x*y
    Column <- c(Column, x)
  }

  length(Column) <- nrow(addTable)
  Column[is.na(Column)] <- 0

  Column2 <- NULL
  Column2 <- rep(z, length(Column))

  addTable$First + Column
  addTable$Second + Column2
}

system.time(mapply(sample_fun, dt$X, dt$Y, dt$Z))
# user  system elapsed 
# 2.25    0.00    2.26 

^ 那要快得多，但没有更新实际数据集。

2-现在让我们尝试将其替换为具有set相同影响:=但没有 data.table::`[.data.table` 开销

sample_fun <- function(x, y, z, n) {  
  Column <- NULL
  while(x>=1) {
    x <- x*y
    Column <- c(Column, x)
  }

  length(Column) <- nrow(addTable)
  Column[is.na(Column)] <- 0

  Column2 <- NULL
  Column2 <- rep(z, length(Column))

  set(addTable, j = "First", value = addTable[["First"]] + Column)
  set(addTable, j = "Second", value = addTable[["Second"]] + Column2)
}

system.time(mapply(sample_fun, dt$X, dt$Y, dt$Z))
# user  system elapsed 
# 2.96    0.00    2.96 

^ 嗯，这也比 30 秒快得多，并且效果与 :=

3-我们来试试，而不使用data.table在所有

dt <- data.frame(X= c(1:100), Y=c(.5, .7, .3, .4), Z=c(1:50000))    
addTable <- data.frame(First=0, Second=0, Term=c(1:50))

sample_fun <- function(x, y, z) {
  Column <- NULL
  while(x>=1) {
    x <- x*y
    Column <- c(Column, x)
  }

  length(Column) <- nrow(addTable)
  Column[is.na(Column)] <- 0

  Column2 <- NULL
  Column2 <- rep(z, length(Column))

  return(list(Column, Column2))
}

system.time(res <- mapply(sample_fun, dt$X, dt$Y, dt$Z))
# user  system elapsed 
# 1.34    0.02    1.36 

^ 那会更快

现在我们可以Reduce结合使用accumulate = TRUE来创建这些向量

system.time(addTable$First <- Reduce(`+`, res[1, ], accumulate = TRUE)[[nrow(dt)]])
# user  system elapsed 
# 0.07    0.00    0.06 
system.time(addTable$Second <- Reduce(`+`, res[2, ], accumulate = TRUE)[[nrow(dt)]])
# user  system elapsed 
# 0.07    0.00    0.06 

好吧，所有组合现在都在 2 秒以内（而不是原始函数的 30 秒）。

4- 进一步的改进可能是修复函数​​中的其他元素（如上所述），换句话说，你的函数可能只是

sample_fun <- function(x, y, n) {
  Column <- numeric(n)
  i <- 1L
  while(x >= 1) {
    x <- x * y
    Column[i] <- x
    i <- i + 1L
  }
  return(Column)
}

system.time(res <- Map(sample_fun, dt$X, dt$Y, nrow(addTable)))
# user  system elapsed 
# 0.72    0.00    0.72 

^ 速度提高两倍

现在，我们甚至没有打扰创建，Column2因为我们已经在dt$Z. 我们还使用了Map代替，mapply因为Reduce使用 alist比使用 a更容易matrix。

下一步与之前类似

system.time(addTable$First <- Reduce(`+`, res, accumulate = TRUE)[[nrow(dt)]])
# user  system elapsed 
# 0.07    0.00    0.07 

但我们可以进一步改进这一点。除了使用Map/Reduce我们可以创建一个matrixusingmapply然后运行matrixStats::rowCumsums它（内部用 C++ 编写）以计算addTable$First）

system.time(res <- mapply(sample_fun, dt$X, dt$Y, nrow(addTable)))
# user  system elapsed 
# 0.76    0.00    0.76 
system.time(addTable$First2 <- matrixStats::rowCumsums(res)[, nrow(dt)])
# user  system elapsed 
#    0       0       0 

虽然最后一步只是简单地求和 dt$Z

system.time(addTable$Second <- sum(dt$Z))
# user  system elapsed 
#    0       0       0

所以最终我们从大约 30 秒缩短到不到一秒。

一些最后的笔记

1. 由于看起来主要的开销仍然存在于函数本身中，您也可以尝试使用 Rcpp 重写它，因为在这种情况下循环似乎是不可避免的（尽管开销看起来并不大）。