improve execution time in a for loop (R) - r

Question

Here is a reproducible example of a for loop. Since I want to do 3000 iterations and my matrix is way bigger than this reproducible example, the computer crushes. Any ideas on how can I do it?
I have read that loops are not reccomended in R and instead the web proposes to use vectors and apply functions but I wasn't able to build my formula with that functions...
The matrix:
row.names <- c('A2003','B2010','C2011','D2010','E2001','F2005','F2009','G2003','G2007','H2004','H2010')
sp1 <- c(4,83,1,2,4,3,1,5,7,2,4)
sp2 <- c(5,0,2,3,10,5,0,2,4,3,1)
sp3 <- c(7,2,4,8,7,2,4,83,1,5,7)
sp4 <- c(0,2,4,2,4,12,1,5,7,2,4)
Site <- c('A','B','C','D','E','F','F','G','G','H','H')
Year <- c('2003','2010','2011','2010','2001','2005','2009','2003','2007','2004','2010')
Obs <- c(1,1,1,4,9,6,8,2,5,2,3)
ID <- c('A2003','B2010','C2011','D2010','E2001','F2005','F2009','G2003','G2007','H2004','H2010')
df<- data.frame(row.names, sp1, sp2, sp3, sp4, Site, Year, Obs, ID)
rownames(df) <- df[,1]
df[,1] <- NULL
df
df.1 <- subset(df, Obs == 1)
df.more <- subset(df, Obs >= 2)
df.1
df.more
The loop function:
require (vegan)
iterations <- 3000
out <- vector("list", iterations)
for(i in 1:iterations){
rnd.more <- do.call(rbind, lapply(split(df.more, df.more$Site),
function(df.more) df.more[sample(nrow(df.more), 1,replace=FALSE) , ])
)
rnd.df <- rbind(df.1,rnd.more)
rnd.df.bc <- as.matrix(vegdist(rnd.df[1:4], method="bray"))
rnd.df.bc[lower.tri(rnd.df.bc,diag=TRUE)] <- NA
triang <- rnd.df.bc[!is.na(rnd.df.bc)]
mean.bc <- mean(triang)
out[[i]] <- list(rnd = rnd.df, bc = rnd.df.bc, ave = mean.bc)
}
Extraction of the results:
all.rnd.df <- lapply(out, "[[", "rnd")
capture.output(all.rnd.df,file="all.rnd.df.txt")
all.rnd.df.bc <- lapply(out, "[[", "bc")
capture.output(all.rnd.df.bc,file="all.rnd.df.bc.txt")
all.triang <- lapply(out, "[[", "ave")
capture.output(all.triang,file="all.triang.txt")

Answer 1

precompute the sample indices:
idx <- lapply(1:iterations, function(x) {
tapply(1:nrow(df.more), as.character(df.more$Site), function(y) {
if(length(y) == 1) y else sample(y, 1)
})
})
idx <- lapply(idx, function(ids) c(1:nrow(df.1), ids + nrow(df.1)))
precompute a placeholder data.frame to index
rnd.df <- rbind(df.1, df.more)
now you just index the precomputed objects without having to calculate them every loop:
iterations <- 3000
out <- vector("list", iterations)
for(i in 1:iterations){
rnd.df.bc <- as.matrix(vegdist(rnd.df[idx[[i]] ,1:4], method="bray"))
rnd.df.bc[lower.tri(rnd.df.bc,diag=TRUE)] <- NA
triang <- rnd.df.bc[!is.na(rnd.df.bc)]
mean.bc <- mean(triang)
out[[i]] <- list(rnd = rnd.df, bc = rnd.df.bc, ave = mean.bc)
}
Benchmarks:
f1 = my method
f2 = OPs code
> microbenchmark(f1(), f2(), times=5L)
Unit: seconds
expr min lq mean median uq max neval
f1() 2.21069 4.877017 4.666875 5.27416 5.444411 5.528096 5
f2() 13.54813 13.554965 19.500247 14.51089 27.074520 28.812732 5
Make it parallel:
cl <- makeCluster(3)
registerDoSNOW(cl)
out <- foreach(i = 1:iterations, .packages=c('vegan')) %do%
{
rnd.df.bc <- as.matrix(vegdist(rnd.df[idx[[i]] ,1:4], method="bray"))
rnd.df.bc[lower.tri(rnd.df.bc,diag=TRUE)] <- NA
triang <- rnd.df.bc[!is.na(rnd.df.bc)]
mean.bc <- mean(triang)
list(rnd = rnd.df, bc = rnd.df.bc, ave = mean.bc)
}
stopCluster(cl)

Answer 2

Not being familiar with the vegan package, I'm a little limited in what advice I can give you. For the most part, you've constructed your for loop well and as you can see below, you don't gain much by converting it to a function and running it through lapply.
I think your best bet is to parallelize your code. In the example below, if you convert your for loop to a function and use parLapply, you can shave a couple seconds off if you include the cluster build time. If you exclude the cluster build time, it's about 5 times faster on my 7 cores. Changes in computational time will vary by the number of cores you can run on. But I think that may be your best option for now.
library(parallel)
library(vegan)
row.names <- c('A2003','B2010','C2011','D2010','E2001','F2005','F2009','G2003','G2007','H2004','H2010')
sp1 <- c(4,83,1,2,4,3,1,5,7,2,4)
sp2 <- c(5,0,2,3,10,5,0,2,4,3,1)
sp3 <- c(7,2,4,8,7,2,4,83,1,5,7)
sp4 <- c(0,2,4,2,4,12,1,5,7,2,4)
Site <- c('A','B','C','D','E','F','F','G','G','H','H')
Year <- c('2003','2010','2011','2010','2001','2005','2009','2003','2007','2004','2010')
Obs <- c(1,1,1,4,9,6,8,2,5,2,3)
ID <- c('A2003','B2010','C2011','D2010','E2001','F2005','F2009','G2003','G2007','H2004','H2010')
df<- data.frame(row.names, sp1, sp2, sp3, sp4, Site, Year, Obs, ID)
rownames(df) <- df[,1]
df[,1] <- NULL
df
df.1 <- subset(df, Obs == 1)
df.more <- subset(df, Obs >= 2)
df.1
df.more
more.fun <- function(df.more, df.1)
{
rnd.more <- do.call(rbind, lapply(split(df.more, df.more$Site),
function(df.more) df.more[sample(nrow(df.more), 1,replace=FALSE) , ])
)
rnd.df <- rbind(df.1,rnd.more)
rnd.df.bc <- as.matrix(vegdist(rnd.df[1:4], method="bray"))
rnd.df.bc[lower.tri(rnd.df.bc,diag=TRUE)] <- NA
triang <- rnd.df.bc[!is.na(rnd.df.bc)]
mean.bc <- mean(triang)
list(rnd = rnd.df, bc = rnd.df.bc, ave = mean.bc)
}
start.orig <- Sys.time()
set.seed(pi)
iterations <- 3000
out <- vector("list", iterations)
for(i in 1:iterations){
rnd.more <- do.call(rbind, lapply(split(df.more, df.more$Site),
function(df.more) df.more[sample(nrow(df.more), 1,replace=FALSE) , ])
)
rnd.df <- rbind(df.1,rnd.more)
rnd.df.bc <- as.matrix(vegdist(rnd.df[1:4], method="bray"))
rnd.df.bc[lower.tri(rnd.df.bc,diag=TRUE)] <- NA
triang <- rnd.df.bc[!is.na(rnd.df.bc)]
mean.bc <- mean(triang)
out[[i]] <- list(rnd = rnd.df, bc = rnd.df.bc, ave = mean.bc)
}
end.orig <- Sys.time()
start.apply <- Sys.time()
fn = out <- lapply(1:3000, function(i) more.fun(df.more, df.1))
end.apply <- Sys.time()
start.parallel <- Sys.time()
cl <- makeCluster(7)
clusterEvalQ(cl, library(vegan))
clusterExport(cl, c("df.more", "df.1", "more.fun"))
start.parallel.apply <- Sys.time()
out <- parLapply(cl, 1:3000, function(i) more.fun(df.more, df.1))
end.parallel <- Sys.time()
#* Compare times
end.orig - start.orig
end.apply - start.apply
end.parallel - start.parallel
end.parallel - start.parallel.apply
(the time comparisons here are pretty crude)