Alternative to for loop with "dynamic" variables with R - r

Question

I am new to StackOverflow even though it's been a while I play with R. I am struggling with a problem for which I was not able to find any answer on the site. Please correct me if I my quest was not enough accurate.
I have two 3d arrays, in this simplified case 256x256x200. First one is a field, the second one is made of indices, spanning from 1 to 8. I want to compute the average on each vertical level according to the values and the counts of the indices, i.e. the average the the field for 200 levels for each index (from 1 to 8). This should be done only if there are enough counts of the indices (i.e. an if condition within the loop). My output must be a matrix of 8x200.
For the example I create two random arrays. Here below there is the basic code I am using:
nz=200
lev=1:nz
indices=8
var0=array(rnorm(256*256*nz),dim=c(256,256,nz))
#octo=array(sample(1:indices),dim=c(256,256,nz))
octo=array(sample(1:indices,size=256*256*nz,replace=T),dim=c(256,256,nz))
counts=apply(octo,3,function(x) table(factor(x,levels=1:indices)))
#thr=0.1
thr=0.125
np=length(var0[,1,1])*length(var0[1,,1])
profile=array(NA,dim=c(nz,indices))
t0=proc.time()
for (i in 1:indices)
{
for (z in 1:length(lev))
{
if (counts[i,z]/np>thr)
{v0=var0[,,z]; profile[z,i]=counts[i,z]/np*mean(v0[octo[,,z]==i],na.rm=T)}
}
}
print(proc.time()-t0)
user system elapsed
5.169 0.001 5.170
I tried with apply family of functions but I am not able to write it down in a reasonable and efficient way, considering that I need that each computation takes into account a "dynamic" variable that changes its level (i.e. octo and counts vars). My real case is made by way bigger matrices and this should be done on dozens of fields, thus time is pretty relevant.
Are you aware of any faster alternatives?
Many thanks for any help!
EDIT: I corrected the original definition of octo and I adjusted the threshold thr. In this way the if condition makes sense, since it is not always respected.

Answer 1

Here's a data.table reshape solution that avoids loops and or apply statements:
nz=200
lev=1:nz
indices=8
var0=array(rnorm(256*256*nz),dim=c(256,256,nz))
octo=array(sample(1:indices),dim=c(256,256,nz))
counts=apply(octo,3,function(x) table(factor(x,levels=1:indices)))
thr=0.1
np=length(var0[,1,1])*length(var0[1,,1])
profile=array(NA,dim=c(nz,indices))
# From here load data.table to do the manipulation
# reshape2 to convert back into a matrix at the end
library(data.table)
library(reshape2)
# Take the data long and convert to data.table
var01 <- setDT(melt(var0))
octo1 <- setDT(melt(octo))
# Join the data to get corresponding data
# EDIT, it currently works, but I think that's because all data is defined
# adding nomatch in case of missing data
octo1 <- octo1[var01, on = c('Var1','Var2','Var3'), nomatch = NA]
# Make our calculation grouping by the vertical dimension and the value
profile <- octo1[,if(.N/np > thr) .N / np * mean(i.value, na.rm = TRUE) else NA, by = .(value,Var3)]
# Recast to matrix
profile <- acast(profile, value ~ Var3, mean, value.var = 'V1')

Answer 2

I think that I find a good solution with sapply including the thr
f1<-function()
{
for (i in 1:indices)
{
for (z in 1:length(lev)) {if (counts[i,z]/np>thr) {v0=var0[,,z]; profile[z,i]=counts[i,z]/np*mean(v0[octo[,,z]==i],na.rm=T) } }
}
return(profile)
}
f2<-function()
{
profile=sapply(lev, function(i) {
v0=var0[,,i];
mV=sapply(1:indices, function(j) {mean(v0[octo[,,i] == j], na.rm = TRUE)})
counts[,i]/np*mV
})
profile[counts/np <= thr]=NA
profile<-matrix(profile, nz, indices, byrow = TRUE)
return(profile)
}
f3<-function()
{
profile=sapply(lev, function(i) {
v0=var0[,,i];
mV=sapply(1:indices, function(j) {if (counts[j,i]/np>thr) {mean(v0[octo[,,i] == j], na.rm = TRUE)} else {NA}})
counts[,i]/np*mV
})
profile<-matrix(profile, nz, indices, byrow = TRUE)
return(profile)
}
Actually f1() is the original, f2() is the #parksw3 one and f3() is my version slightly improved.
benchmark(f1(),f2(),f3(),replications=10)
test replications elapsed relative user.self sys.self user.child sys.child
1 f1() 10 27.382 1.411 27.375 0 0 0
2 f2() 10 35.195 1.814 35.186 0 0 0
3 f3() 10 19.403 1.000 19.392 0 0 0
In this way it is always faster than the standard loop. The data.table is likely faster but it requires a full change of data structure that I cannot perform for the moment. Hope this helps!

Answer 3

This seems to be faster on my machine:
profile2 <- sapply(lev, function(i){
v0 <- var0[,,i]
mV <- sapply(1:indices, function(j){
mean(v0[octo[,,i] == j], na.rm = TRUE)
})
counts[,i]/np*mV
})
profile2[counts/np > thr] <- NA
profile2<- t(profile2)
all.equal(profile, profile2)
## TRUE
I tried comparing them with microbenchmark package but it takes fairly long... Here's a quick comparison I did with rbenchmark package
f1 <- function(){
for (i in 1:indices){
for (z in 1:length(lev)) {
if (counts[i,z]/np>thr){
v0=var0[,,z]; profile[z,i]=counts[i,z]/np*mean(v0[octo[,,z]==i],na.rm=T)
}
}
}
}
f2 <- function(){
prof <- sapply(lev, function(i){
v0 <- var0[,,i]
mV <- sapply(1:indices, function(j){
mean(v0[octo[,,i] == j], na.rm = TRUE)
})
counts[,i]/np*mV
})
profile2[counts/np > thr] <- NA
profile2<- t(profile2)
}
library(rbenchmark)
benchmark(f1(), f2(), replications = 10)
I put both codes into a function and tested. Here's the result:
## test replications elapsed relative user.self sys.self
## 1 f1() 10 89.03 1.342 85.15 1.72
## 2 f2() 10 66.34 1.000 61.50 0.75