Performance – Accelerate the R code – Apply a function to each row of an array

My goal is to apply a function. func1 to each row in a matrix entry and return a matrix. The code works but when the data frame contains more than 1 million rows, it is very slow. How can I optimize my code? I start to learn programming and I am not familiar with the strategies to accelerate the R code. The functions perform 2 main steps: 1) to find the locations of all the neighboring cells that are located in the PR extension from a focal cell, extract raster values in these locations and calculate the probability matrix, and 2) find the maximum value in the matrix and the new cell corresponding to the maximum value.

Here is the data frame and the plot:

set.seed (1234)
n = 10000
input <- as.matrix (data.frame (c1 = sample (1:10, n, replace = T), c2 = sample (1:10, n, replace = T), c3 = sample (1:10, n , replace = T), c4 = sample (1:10, n, replace = T)))

r <- raster (extension (0, 10, 0, 10), res = 1)
values ​​(r) <- sample (1: 1000, size = 10 * 10, replace = T)
## plot (r)

Here is my code to apply the function to each row in the matrix:

system time (
test <- input %>%
split (1: nrow (entry))%>%
map (~ func1 (.x, 2, 2, "test_1"))%>%
do.call ("rbind" ,.))

Here is the function:

func1 <- function (dataC, PR, DB, MT) {

## Retrieve the x and y coordinates of the current cell
c1 <- dataC[[1]]c2 <- dataC[[2]]## Retrieve the x and y coordinates of the previous cell
c3 <- dataC[[3]]c4 <- dataC[[4]]## Initializes the x and y coordinates of the new cell
newc1 <- -999
newc2 <- -999

if (MT == "test_1") {

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 - PR): (c1 - 1)), y = c ((c2 - PR): (c2 - 1))) ## cells in the upper left corner
V1 <- media (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * sqrt (2) * DB

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 - PR): (c1 - 1)), y = c ((c2 - 1): (c2 + 1))) ## cells in the upper middle corner
V2 <- media (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * DB

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 - PR): (c1 - 1)), y = c ((c2 + 1): (c2 + PR))) ## cells in the upper right corner
V3 <- media (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * sqrt (2) * DB

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 - 1): (c1 + 1)), y = c ((c2 - PR): (c2 - 1))) ## cells in the left corner
V4 <- media (raster :: extract (r, cbind (matC)[,1], matC[,2])), na.rm = T) * DB

V5 <- 0 ## cell in the middle corner

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 - 1): (c1 + 1)), y = c ((c2 + 1): (c2 + PR))) ## cells in the right corner
V6 <- media (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * DB

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 + 1): (c1 + PR)), y = c ((c2 - PR): (c2 - 1))) ## cells in the lower left corner
V7 <- media (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * sqrt (2) * DB

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 + 1): (c1 + PR)), y = c ((c2 - 1): (c2 + 1))) ## cells in the lower middle corner
V8 <- media (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * DB

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 + 1): (c1 + PR)), y = c ((c2 + 1): (c2 + PR))) ## cells in the lower right corner
V9 <- media (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * sqrt (2) * DB

} else if (MT == "test_2") {

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 - PR): (c1 - 1)), y = c ((c2 - PR): (c2 - 1))) ## cells in the upper left corner
V1 <- harmonic.mean (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * sqrt (2) * DB

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 - PR): (c1 - 1)), y = c ((c2 - 1): (c2 + 1))) ## cells in the upper middle corner
V2 <- harmonic.mean (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * DB

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 - PR): (c1 - 1)), y = c ((c2 + 1): (c2 + PR))) ## cells in the upper right corner
V3 <- harmonic.mean (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * sqrt (2) * DB

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 - 1): (c1 + 1)), y = c ((c2 - PR): (c2 - 1))) ## cells in the left corner
V4 <- harmonic.mean (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * DB

V5 <- 0 ## cells in the middle corner

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 - 1): (c1 + 1)), y = c ((c2 + 1): (c2 + PR))) ## cells in the right corner
V6 <- harmonic.mean (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * DB

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 + 1): (c1 + PR)), y = c ((c2 - PR): (c2 - 1))) ## cells in the lower left corner
V7 <- harmonic.mean (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * sqrt (2) * DB

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 + 1): (c1 + PR)), y = c ((c2 - 1): (c2 + 1))) ## cells in the lower middle corner
V8 <- harmonic.mean (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * DB

## Extract the raster values ​​with coordinates in matC
matC <- expand.grid (x = c ((c1 + 1): (c1 + PR)), y = c ((c2 + 1): (c2 + PR))) ## cells in the lower right corner
V9 <- harmonic.mean (raster :: extract (r, cbind (matC[,1], matC[,2])), na.rm = T) * sqrt (2) * DB

}

## Build the cell selection matrix
tot <- sum (c (1 / V1, 1 / V2, 1 / V3, 1 / V4, 1 / V6, 1 / V7, 1 / V8, 1 / V9), na.rm = TRUE)
mat_V <- matrix (data = c ((1 / V1) / tot, (1 / V2) / tot, (1 / V3) / tot, (1 / V4) / tot, V5,
(1 / V6) / tot, (1 / V7) / tot, (1 / V8) / tot, (1 / V9) / tot), nrow = 3, ncol = 3, byrow = TRUE)


while ((newc1 == -999 && newc2 == -999) || (c3 == newc1 && c4 == newc2)) {

## Test if the new cell is the previous cell
if (c3 == newc1 && c4 == newc2) {
mat_V[choiceC[1], choiceC[2]]<- NaN
## print (mat_V)
}

## Find the maximum value in the matrix
ChoiceC <- which(mat_V == max(mat_V, na.rm = TRUE), arr.ind = TRUE)
      ## print(choiceC)
      ## If there are several maximum values
      if(nrow(choiceC) > one) {
choiceC <- choiceC[sample(1:nrow(choiceC), 1), ]
      }

## Find the new cell in relation to the current cell
yes[1]== 1 and electionC[2]== 1) {## cell in the upper left corner

newC <- matrix (c (x = c1 - 1, y = c2 - 1), ncol = 2)

} else if (choiceC[1]== 1 and electionC[2]== 2) {## cell in the upper middle corner

newC <- matrix (c (x = c1 - 1, y = c2), ncol = 2)

} else if (choiceC[1]== 1 and electionC[2]== 3) {## cell in the upper right corner

newC <- matrix (c (x = c1 - 1, y = c2 + 1), ncol = 2)

} else if (choiceC[1]== 2 and electionC[2]== 1) {## cell in the left corner

newC <- matrix (c (x = c1, y = c2 - 1), ncol = 2)

} else if (choiceC[1]== 2 and electionC[2]== 3) {## cell in the right corner

newC <- matrix (c (x = c1, y = c2 + 1), ncol = 2)

} else if (choiceC[1]== 3 and electionC[2]== 1) {## cell in the lower left corner

newC <- matrix (c (x = c1 + 1, y = c2 - 1), ncol = 2)

} else if (choiceC[1]== 3 and electionC[2]== 2) {## cell in the lower middle corner

newC <- matrix (c (x = c1 + 1, y = c2), ncol = 2)

} else if (choiceC[1]== 3 and electionC[2]== 3) {## cell in the lower right corner

newC <- matrix (c (x = c1 + 1, y = c2 + 1), ncol = 2)
}

newc1 <- newC[[1]]newc2 <- newC[[2]]}

return (newC)

} 

Here is the elapsed time when n = 10000. Ideally, I would like to reduce the time required in <1 min.

elapsed user system
108.96 0.01 109.81