Применение функции к каждой строке матрицы без использования функции lapply в R

Question

У меня есть фрейм входных данных с несколькими строками.Для каждой строки я хочу применить функцию.Фрейм входных данных содержит более 1 000 000 строк.Как я могу ускорить часть, используя lapply?Я хотел бы избежать применения семейства функций, как в Эффективный способ применить функцию к каждой строке фрейма данных и вернуть список фреймов данных , потому что в моем случае эти методы кажутся медленными.

Вот воспроизводимый пример с простой функцией:

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

@ Джон Спринг дал действительно хороший ответ выше.

Однако я предлагаю метод, который использует {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()

Этот метод требует временипримерно от 0,4 до 3,28 секунды на моем ноутбуке, когда n = 1e7.

Для n = 1e6 метод, который вы опубликовали, занимает около 138 секунд, в то время как метод, который я использовал, занимает около 0,3 секунды.

Answer 2

Я предлагаю поискать 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 строкив ваш потребитель, пока не найдете ЛОЖНОЕ значение или пока вы мне не поверите.:)

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

Обратите внимание, я еще не использую матрицу.Вы можете воссоздать свою матрицу позже.Если по какой-то причине вы начинаете с матрицы, то, честно говоря, я бы просто изменил ее на обычную таблицу, чтобы мне было проще использовать аккуратные операции.Может быть, гуру может научить нас, как использовать обратные операции с матрицами, я не знаю как.Решение:

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 с прошло достаточно быстро для меня.

Обратите внимание, что я создал новый столбец с mutate под названием "c" и установил его в 1. Это потому, чтоdplyr не нравится, если вы используете операторы if_else, которые имеют логические проверки по отношению к переменной окружения (и если эта переменная всегда равна 1, зачем нам кодировать это в первую очередь?).Таким образом, я предполагаю, что вы планируете использовать «с», который иногда может быть 1, а иногда и 0, и я предлагаю здесь, чтобы вы имели эти данные в столбце, на который мы можем ссылаться.

Answer 3

Основываясь на ответе Джона Спринга, мы можем сделать то же самое с базой 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 4

Похоже, некоторые уже очень быстрые варианты.Другим медленным вариантом будет стандартный for-loop.

Это намного медленнее, чем у них, но все же в 3 раза быстрее, чем 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 5

Похоже, это хорошая возможность реорганизовать и сделать это в векторизованном расчете, который R может решить быстрее.(TL; DR: это делает его примерно в 1000 раз быстрее.)

Похоже, задача здесь состоит в том, чтобы взять средневзвешенное значение двух диапазонов целых чисел, где выходные значения диапазонов варьируются в зависимости от строки (на основе X1, X2, Y1 и Y2), но последовательности имеют одинаковую длину в каждой строке.Это помогает, потому что это означает, что мы можем использовать алгебру для упрощения вычислений.

Для простого случая, когда a = 40, первая последовательность будет от x1-40 до x-1 и от y + 1 доу1 + 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 (10% от OP), функция OP занимает 73 секунды.Вышеуказанная функция занимает 0,08 секунды и имеет тот же результат.

Для случаев, когда a != 40, требуется немного больше алгебры.V1 здесь заканчивается как средневзвешенное значение, где мы складываем последовательность (x1-a):(x1-1) и последовательность (y1+1):(y1+40), все разделенные на a+40 (поскольку в последовательности x1 есть a члены и40 членов в последовательности y1. На самом деле нам не нужно добавлять эту последовательность, мы можем преобразовать ее в более короткий расчет с использованием алгебры: 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 заняло 154 секунды на моем ноутбуке 2012 года, в то время как quick_test2 выше заняло 0,23 секунды и показало идентичные результаты.

(Небольшое дополнение, можно добавить тестустановить b = 1, если c == 0, и тогда вы позаботились об условии if-else.)