将函数应用于矩阵的每一行而不使用 R 中的 lapply 函数

Question

我有一个包含多行的输入数据框。对于每一行，我想应用一个函数。输入数据框有 1,000,000+ 行。如何使用 lapply 加速零件？我想避免使用 Efficient way to apply function to each row of data frame and return list of data frames 中的 apply 系列函数，因为在我的情况下这些方法似乎很慢。

这是一个具有简单功能的可重现示例：

library(tictoc)   # enable use of tic() and toc() to record time taken for test to compute

func <- function(coord, a, b, c){

  X1 <- as.vector(coord[1])
  Y1 <- as.vector(coord[2])
  X2 <- as.vector(coord[3])
  Y2 <- as.vector(coord[4])

  if(c == 0) {

    res1 <- mean(c((X1 - a) : (X1 - 1), (Y1 + 1) : (Y1 + 40)))
    res2 <- mean(c((X2 - a) : (X2 - 1), (Y2 + 1) : (Y2 + 40)))
    res <- matrix(c(res1, res2), ncol=2, nrow=1)

  } else {

    res1 <- mean(c((X1 - a) : (X1 - 1), (Y1 + 1) : (Y1 + 40)))*b
    res2 <- mean(c((X2 - a) : (X2 - 1), (Y2 + 1) : (Y2 + 40)))*b
    res <- matrix(c(res1, res2), ncol=2, nrow=1)

  }

  return(res)
}

## Apply the function
set.seed(1)
n = 10000000
tab <- as.matrix(data.frame(x1 = sample(1:100, n, replace = T), y1 = sample(1:100, n, replace = T), x2 = sample(1:100, n, replace = T), y2 = sample(1:100, n, replace = T)))


tic("test 1")
test <- do.call("rbind", lapply(split(tab, 1:nrow(tab)),
                                function(x) func(coord = x,
                                                 a = 40,
                                                 b = 5,
                                                 c = 1)))
toc()



 ## test 1: 453.76 sec elapsed

Answer 1

这似乎是一个重构向量化计算的好机会，R 可以更快地解决这个问题。 （TL；DR：这使它快了大约 1000 倍。）

看起来这里的任务是取两个整数范围的加权平均值，其中范围的书挡因行而异（基于 X1、X2、Y1 和 Y2），但序列的长度相同在每一行。这很有帮助，因为这意味着我们可以使用代数来简化计算。

对于 a = 40 的简单情况，第一个序列将从 x1-40 到 x-1，从 y+1 到 y1+40。平均值将是这两者的总和除以 80。总和将是 40*X1 + 40*Y1 + (-40:-1) 的总和 + (1:40) 的总和，最后两项抵消.所以你可以简单的输出每对列的平均值，乘以b。

library(dplyr)
b = 5
quick_test <- tab_tbl %>%
  as_data_frame() %>%
  mutate(V1 = (x1+y1)/2 * b,
         V2 = (x2+y2)/2 * b)

使用 n = 1E6（OP 的 10%），OP 函数需要 73 秒。上述函数耗时 0.08 秒，输出相同。

对于a != 40 的情况，它需要更多的代数。 V1 在这里以加权平均值结束，我们将序列(x1-a):(x1-1) 和序列(y1+1):(y1+40) 相加，全部除以a+40（因为x1 序列中有a 项和y1 序列中有 40 个项。我们实际上不需要将此序列相加；我们可以使用代数将其转换为更短的计算：https://en.wikipedia.org/wiki/Arithmetic_progression

sum of (x1-a):(x1-1) = x1*a + sum of (-a:-1) = x1*a + a*(-a + -1)/2 = x1*a - (a*a + a)/2

这一切意味着我们可以完全复制任何正面a 的代码，使用：

a = 50
b = 5

tictoc::tic("test 2b")
quick_test2 <- quick_test <- tab %>%
  as_data_frame() %>%
  mutate(V1 = (a*x1 - (a*a + a)/2  + 40*y1 + 820)/(a+40)*b,
         V2 = (a*x2 - (a*a + a)/2  + 40*y2 + 820)/(a+40)*b)
tictoc::toc()

这大约快 1000 倍。在 n = 1E6、a = 41、b = 5、c = 1 的情况下，OP 解决方案在我 2012 年的笔记本电脑上花费了 154 秒，而上面的 quick_test2 花费了 0.23 秒并且得到了相同的结果。

（小附录，如果 c == 0，您可以添加一个测试来设置 b = 1，然后您已经处理了 if-else 条件。）

Answer 2

根据 Jon Spring 的回答，我们可以对 base R 做同样的事情：

test2 <- function(d, a, b, c) {
  if (c == 0) b <- 1
  X <- d[, c('x1', 'x2')]
  Y <- d[, c('y1', 'y2')]
  (a*X - (a*a + a)/2  + 40*Y + 820)/(a+40)*b
}

res2 <- test2(tab, 40, 5, 1)

Answer 3

看起来一些已经非常快的选项。另一个慢速选项是标准的for-loop。

这比他们的慢很多，但仍然比lapply快3倍。

n = 1e6

tic("test 2")
test <- vector("list", nrow(tab))
for (i in 1:nrow(tab)) {test[[i]] <- func(coord = tab[i,], a = 40, b = 5, c = 1)
}
testout <- do.call(rbind, test)
toc()

> test 2: 3.85 sec elapsed

Answer 4

我建议查找 tidyverse，在这种情况下特别是 dplyr（一个 tidyverse 子包）。 tidyverse 是大量有用且“整洁”（又名 FAST）操作的集合。收拾好就再也回不去了。

首先，只是一些一般性的数学建议。可以在不实际生成整个序列的情况下对序列进行平均。您只需要序列的开始和结束，因为第一个和最后一个数字的平均值与整个序列的平均值相同。如果您的真实数据是非序列数字的向量，请告诉我。以下三行代码证明了第一个和最后一个数字的均值与全序列的均值相同：

seqstart <- sample(1:50, 1, replace = T)
seqend <- sample(51:100, 1, replace = T)
mean(c(seqstart, seqend)) == mean(seqstart:seqend)

如果您不相信我，请将这 3 行粘贴到您的 consule 中，直到您找到 FALSE 值，或者直到您相信我为止。 :)

library(tidyverse)
set.seed(1)
n = 10000000
tab <- data.frame(x1 = sample(1:100, n, replace = T), y1 = sample(1:100, n, 
replace = T), x2 = sample(1:100, n, replace = T), y2 = sample(1:100, n, replace = 
T))

请注意，我还没有使用矩阵。您可以稍后重新创建矩阵。如果您出于某种原因从矩阵开始，老实说，我会为此将其更改为普通表，以便我可以更轻松地使用整洁的操作。也许大师可以教我们如何在矩阵上使用 tidyverse 运算，我不知道如何。解决方案：

tic("test 1")
a <- 40
b <- 5
test <- tab %>% mutate(c = 1) %>%
mutate(res1 = if_else(c==1,(((x1 - a)+(x1 - 1)+(y1 + 1)+(y1 + 40))/4)*b,(((x1 - a)+ 
(x1 - 1)+(y1 + 1)+(y1 + 40))/4))) %>%
mutate(res2 = if_else(c==1,(((x2 - a)+(x2 - 1)+(y2 + 1)+(y2 + 40))/4)*b,(((x2 - a)+ 
(x2 - 1)+(y2 + 1)+(y2 + 40))/4)))
test %>% select(res1,res2) -> test
toc()

测试 1：经过 8.91 秒 对我来说足够快。

请注意，我创建了一个名为“c”的 mutate 新列并将其设置为 1。这是因为 dplyr 不喜欢如果您使用对环境变量进行逻辑检查的 if_else 语句（并且如果该变量是总是 1，为什么我们首先要编写这个代码？）。因此，我假设您计划使用有时为 1 有时为 0 的“c”，我在这里建议您应该将这些数据放在我们可以引用的列中。

Answer 5

@Jon Spring 在上面提供了一个非常好的答案。

不过，我建议使用 {data.table} 的方法。

test2 <- data.table(copy(tab))
tic("test2")
a <- 40
b <- 5
c <- 1
test2[, Output1 := (x1*a - 0.5*(a + a^2) + 40 * y1 + 820)/ (a + 40) * b]
test2[, Output2 := (x2*a - 0.5*(a + a^2) + 40 * y2 + 820)/ (a + 40) * b]
toc()

当 n = 1e7 时，此方法在我的笔记本电脑上需要大约 0.4 到 3.28 秒的时间。

对于 n = 1e6，您发布的方法大约需要 138 秒，而我使用的方法大约需要 0.3 秒。