将函数应用于矩阵的每一行，而无需在R中使用lapply函数

Question

I have a input data frame with multiple rows. For each row, I want to apply a function. The input data frame has 1,000,000+ rows. How can I speed up the part using lapply ? I would like to avoid the apply family of functions as in Efficient way to apply function to each row of data frame and return list of data frames because these methods seem to be slow in my case.

Here is a reproducible example with a simple function:

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

This seems like a good opportunity to refactor and make this in a vectorized calculation, which R can solve faster. (TL;DR: this makes it about 1000x faster.)

It looks like the task here is to take a weighted average of two ranges of integers, where the bookends of the ranges vary by row (based on X1, X2, Y1, and Y2), but the sequences are the same length in each row. This helps, because it means we can use algebra to simplify the calculation.

For the simple case that a = 40, the first sequence will be from x1-40 to x-1, and from y+1 to y1+40. The mean will be the sum of these two divided by 80. The sum will be 40*X1 + 40*Y1 + sum of (-40:-1) + sum of (1:40), and those last two terms cancel out. So you can simply output the average of each pair of columns, multiplied by b.

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

Using n = 1E6 (10% of OP), the OP function takes 73 seconds. The function above takes 0.08 seconds and has the same output.

For the cases where a != 40 , it takes a little more algebra. V1 here ends up as a weighted average, where we're adding up the sequence (x1-a):(x1-1) and the sequence (y1+1):(y1+40) , all divided by a+40 (since there are a terms in the x1 sequence and 40 terms in the y1 sequence. We don't actually need to add up this sequence; we could convert it to a shorter calculation using algebra: 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

That all means we can fully replicate the code for any positive a using:

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()

This is about 1000x faster. With n = 1E6, a = 41, b = 5, c = 1, the OP solution took 154 seconds on my 2012 laptop, while quick_test2 above took 0.23 sec and had identical results.

(Small addendum, you could add a test to set b = 1 if c == 0, and then you've taken care of the if-else condition.)

Answer 2

Based on Jon Spring answer, we can do the same with 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

Looks like some already very fast options. Another slow option would be a standard for-loop .

This is much slower than theirs, but still 3 times faster than the lapply .

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

I suggest looking up the tidyverse, in this case specifically dplyr (a tidyverse sub-package). The tidyverse is a huge collection of useful and "tidy" (aka, FAST) operations. Once you go tidy, you never go back.

First, just some general math advice. Taking an average of a sequence can be done without actually generating the entire sequence. You just need the start and end of the sequence, as the average of the first and last number is the same as the average of the entire sequence. If your real data is a vector of non-sequential numbers let me know. The following three lines of code are a proof that the mean of the first and last number are the same as the mean of the full sequence:

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

If you don't believe me, paste those 3 lines into your consule until you find a FALSE value, or until you believe me. :)

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))

Notice I am not using a matrix yet. You can recreate your matrix later. If you are starting with a matrix for some reason, honestly I would just change it to a normal table for this so I can use tidy operations more easily. Maybe a guru can teach us how to use tidyverse operations on matrices, I don't know how. Solution:

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()

test 1: 8.91 sec elapsed Fast enough for me.

Please note I made a new column with mutate called "c" and set it to 1. This is because dplyr doesn't like it if you use if_else statements that have logical checks against an environmental variable (and if that variable is always 1, why would we code this in the first place?). Thus, I am assuming that you are planning to use a "c" that can sometimes be 1 and sometimes be 0, and I am proposing here that you should have that data in a column that we can reference.

Answer 5

@Jon Spring has provided a really good answer above.

However, I am suggesting a method which is using {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()

This method takes time of around 0.4 to 3.28 seconds on my laptop, when n = 1e7.

For n = 1e6, the method you posted in question takes around 138 seconds, while the method I used takes about 0.3 seconds.