How to boost up a for-loop - r

Question

I am suffering from slow for-loop execution in R. Here I provide a part of my code which is producing delay.
## subsitutes for original data
DC <- matrix(rnorm(10), ncol=101, nrow=6400)
C <- matrix(rnorm(20), ncol=101, nrow=6400)
N <- 80
Vcut <- ncol(DC)
V <- seq(-2.9,2.5,length=Vcut)
fNC <- matrix(NA, nrow=(N*N), ncol=Vcut)
fNDC <- matrix(NA, nrow=(N*N), ncol=Vcut)
Arbfunc <- function(dV){
b <- matrix(NA, nrow=1, ncol=Vcut)
for(i in 1:(N*N)) {
for (n in 1:Vcut) {
for (k in 1:Vcut) {
b[k] = (V[2]-V[1])*(exp((-1)*abs(V[k])))*exp(abs(V[n]-V[k])/dV)*(C[i,k]/V[k])
}
fNC[i,n] = exp(1*abs(V[n]))*(1/(2*dV))*(sum(b[]))
fNDC[i,n] = DC[i,n]/fNC[i,n]
}
}
}
Arbfunc(0.5)
Since I need to compare the results among the various values of dV's, this code should run at least within few seconds. But the result is
user system elapsed
40.15 0.03 40.24
which is too much slow for enough comparison. I tried several parallelization methods, but the result was not satisfactory (40 -> 25 secs although I used 11 threads in my pc).
Therefore, my guess is that the bottleneck is this for-loop itself, not a non-parallel code. Could you give me some advice to improve this for-loop or hint for parallelization ? Just a short comment would be grateful.

Answer 1

Big thanks to #Mikko Marttila for correcting functions 3 and 4 and providing the idea for function 5.
R is best approached with vectorized options instead of explicit loops. For instance, the inner loop with k:
for (k in 1:Vcut) {
b[k] = (V[2]-V[1])*(exp((-1)*abs(V[k])))*exp(abs(V[n]-V[k])/dV)*(C[i,k]/V[k])
}
That's the same as saying
(V[2]-V[1])*(exp((-1)*abs(V)))*exp(abs(V[n]-V)/dV)*(C[i,]/V)
This small change gives us a 500x performance boost for this part of the function:
Unit: microseconds
expr min lq mean median uq max neval
k_loop 13186.7 13603.2 14605.471 13832.9 14517.8 41935.1 100
k_vectorized 16.4 17.6 25.559 28.8 32.0 52.7 100
Now if we look at the outer loop with the i, we see that there's really no need to loop by each row. We could instead make a matrix for the the sum(b[k]) statement turning this:
(V[2]-V[1])*(exp((-1)*abs(V)))*exp(abs(V[n]-V)/dV)*(C[i,]/V)
Into this:
(V[2]-V[1])*(exp((-1)*abs(V)))*exp(abs(V[n]-V)/dV)*(t(C)/V)
That just saved us N*N*k loops. In your case, that's 646,400 loops.
To put it altogether, we would have:
Arbfunc3 <- function(dV){
for (n in 1:Vcut) {
sum_b = colSums((V[2]-V[1])*(exp((-1)*abs(V)))*exp(abs(V[n]-V)/dV)*(t(C)/V))
fNC[, n] = exp(1*abs(V[n]))*(1/(2*dV))*(sum_b)
fNDC[, n] = DC[,n]/fNC[,n]
}
}
My median time for microbenchmark is 750 milliseconds for this alternative.
To further improve performance, we need to address the V[n] - V. Thankfully, the R has a function - outer(V, V, '-') and this will produce a matrix with all combinations we need.
Arbfunc4 <- function(dV) {
sum_b = apply((V[2]-V[1])*(exp((-1)*abs(V)))*exp(abs(outer(V, V, '-')) / dV) / V, 2, function(x) colSums(x * t(C)))
fNC = exp(1*abs(V))*(1/(2*dV))*t(sum_b)
fNDC= DC/t(fNC)
fNDC
}
Thanks to #Mikko Marttila for a suggestion to get rid of apply with a dot product.
Arbfunc5 <- function(dV) {
a = (V[2] - V[1]) * exp(-abs(V)) * t(C) / V
b = exp(abs(outer(V, V, "-")) / dV) %*% a
fNC = exp(1*abs(V))*(1/(2*dV))*(b)
fNDC= DC/t(fNC)
fNDC
}
Here is the system.time for each solution (Arbfunc2 is the elimination of the k_loop). The optimized solution is 2,600 times faster than the original.
> system.time(Arbfunc(0.5))
user system elapsed
78.03 0.39 79.72
> system.time(Arbfunc2(0.5))
user system elapsed
10.41 0.03 10.46
> system.time(Arbfunc3(0.5))
user system elapsed
0.69 0.13 0.81
> system.time(Arbfunc4(0.5))
user system elapsed
0.43 0.05 0.47
> system.time(Arbfunc5(0.5))
user system elapsed
0.03 0.00 0.03
Final Edit: Here's the complete code that I ran after restarting R and emptying my environment. No errors:
## subsitutes for original data
DC <- matrix(rnorm(10), ncol=101, nrow=6400)
C <- matrix(rnorm(20), ncol=101, nrow=6400)
N <- 80
Vcut <- ncol(DC)
V <- seq(-2.9,2.5,length=Vcut)
# Unneeded for Arbfunc4 adn Arbfunc5
# Corrected from NA to NA_real_ to prevent coercion from logical to numeric
# h/t to #HenrikB
fNC <- matrix(NA_real_, nrow=(N*N), ncol=Vcut)
fNDC <- matrix(NA_real_, nrow=(N*N), ncol=Vcut)
Arbfunc <- function(dV){
b <- matrix(NA, nrow=1, ncol=Vcut)
for(i in 1:(N*N)) {
for (n in 1:Vcut) {
for (k in 1:Vcut) {
b[k] = (V[2]-V[1])*(exp((-1)*abs(V[k])))*exp(abs(V[n]-V[k])/dV)*(C[i,k]/V[k])
}
fNC[i,n] = exp(1*abs(V[n]))*(1/(2*dV))*(sum(b[]))
fNDC[i,n] = DC[i,n]/fNC[i,n]
}
}
fNDC
}
Arbfunc2 <- function(dV){
b <- matrix(NA, nrow=1, ncol=Vcut)
for(i in 1:(N*N)) {
for (n in 1:Vcut) {
sum_b = sum((V[2]-V[1])*(exp((-1)*abs(V)))*exp(abs(V[n]-V)/dV)*(C[i,]/V))
fNC[i,n] = exp(1*abs(V[n]))*(1/(2*dV))*(sum_b)
fNDC[i,n] = DC[i,n]/fNC[i,n]
}
}
fNDC
}
Arbfunc3 <- function(dV){
for (n in 1:Vcut) {
sum_b = colSums((V[2]-V[1])*(exp((-1)*abs(V)))*exp(abs(V[n]-V)/dV)*(t(C)/V))
fNC[, n] = exp(1*abs(V[n]))*(1/(2*dV))*(sum_b)
fNDC[, n] = DC[,n]/fNC[,n]
}
fNDC
}
Arbfunc4 <- function(dV) {
sum_b = apply((V[2]-V[1])*(exp((-1)*abs(V)))*exp(abs(outer(V, V, '-')) / dV) / V, 2, function(x) colSums(x * t(C)))
fNC = exp(1*abs(V))*(1/(2*dV))*t(sum_b)
DC/t(fNC)
}
Arbfunc5 <- function(dV) {
#h/t to Mikko Marttila for dot product
a = (V[2] - V[1]) * exp(-abs(V)) * t(C) / V
b = exp(abs(outer(V, V, "-")) / dV) %*% a
fNC = exp(1*abs(V))*(1/(2*dV))*(b)
DC/t(fNC)
}
#system.time(res <- Arbfunc(0.5))
system.time(res2 <- Arbfunc2(0.5))
system.time(res3 <- Arbfunc3(0.5))
system.time(res4 <- Arbfunc4(0.5))
system.time(res5 <- Arbfunc5(0.5))
all.equal(res2,res3,res4,res5)
As #HenrikB mentions, the fNC and fNDC initialize as logical matrices. That means we get a performance hit when coercing them to real matrices. Doing it the incorrect is a one-time hit of 1 ms for this dataset but if this coercion were in a loop, it could really add up.
mat_NA_real_ <- function() {
mat = matrix(NA_real_, nrow = 6400, ncol = 101)
mat[1,1] = 1
}
mat_NA <- function() {
mat = matrix(NA, nrow = 6400, ncol = 101)
mat[1,1] = 1
}
microbenchmark(mat_NA_real_(), mat_NA())
Unit: microseconds
expr min lq mean median uq max neval
mat_NA_real_() 979.5 992.25 1490.081 998.65 1021.1 7612.5 100
mat_NA() 1865.8 1883.30 3793.119 1911.30 5335.4 53635.2 100