Options to speed up R code when parallelization is not feasible [duplicate] - r

Question

This question already has an answer here:
Reducing nested for loop to single loop in R
(1 answer)
Closed 5 years ago.
I have developed a simulation, which can be quite slow (up to 6 hours), depending on values of input parameters.
Profiling my code reveals that sample() is the bottleneck, but from my knowledge, there is no better function (sample() is already optimized for maximal speed since it is written in C).
Parallelization will not work either since algorithm iterations are dependent on one another.
Any suggestions on alternatives to improve runtime?
Any advice is warmly welcomed.
Below is my simulation code:
Haplotype Accumulation Curve Simulator
HAC.sim <- function(K = 1, N, Hstar, probs, m = 0, perms = 10000, p = 0.95){
pop <- array(dim = c(c(perms, ceiling((1 - m) * N / K)), K))
haps <- as.character(1:Hstar)
specs <- 1:ceiling((1 - m) * N / K)
for (j in 1:perms){
for (i in 1:K){
pop[j, specs, i] <- sample(haps, size = length(specs), replace = TRUE, prob = probs)
}
}
HAC.mat <- array(dim = c(c(perms, length(specs), K)))
for (k in specs){
for (j in 1:perms){
for (i in 1:K){
ind.index <- sample(specs, size = k, replace = FALSE)
hap.plot <- pop[sample(1:nrow(pop), size = 1, replace = TRUE), ind.index, sample(i, size = 1, replace = TRUE)]
HAC.mat[j, k, i] <- length(unique(hap.plot))
}
}
}
means <- apply(HAC.mat, MARGIN = 2, mean)
lower <- apply(HAC.mat, MARGIN = 2, function(x) quantile(x, 0.025))
upper <- apply(HAC.mat, MARGIN = 2, function(x) quantile(x, 0.975))
d <- assign("d", data.frame(specs, means), envir = .GlobalEnv)
P <- max(means)
Q <- Hstar - max(means)
R <- assign("R", max(means) / Hstar, envir = .GlobalEnv)
S <- (Hstar - max(means)) / Hstar
Nstar <- assign("Nstar", (N * Hstar) / max(means), envir = .GlobalEnv)
X <- ((N * Hstar) / max(means)) - N
cat("\n Measures of Sampling Closeness \n \n Mean number of haplotypes sampled: " , P, "\n Mean number of haplotypes not sampled: " , Q, "\n Proportion of haplotypes sampled: " , R, "\n Proportion of haplotypes not sampled: " , S, "\n \n Calculated mean value of N*: ", Nstar, "\n Mean number of individuals not sampled: ", X, "\n \n")
if (R < p){
cat("Desired level of H* has not yet been reached \n")
} else{
cat("Desired level of H* has been reached")
}
par(mfrow = c(1, 2))
plot(specs, means, type = "n", xlab = "Specimens sampled", ylab = "Unique haplotypes", ylim = c(1, Hstar))
polygon(x = c(specs, rev(specs)), y = c(lower, rev(upper)), col = "gray")
lines(specs, means, lwd = 2)
HAC.bar <- barplot(length(specs) * probs, xlab = "Unique haplotypes", ylab = "Specimens sampled", names.arg = 1:Hstar)
}
A quick reproducible example
N <- 50
Hstar <- 5
probs <- rep(1/Hstar, Hstar)
HAC.sim(N = N, Hstar = Hstar, probs = probs)

Answer 1

Sure, Rcpp is an option but would require you to rewrite parts of your code in C++. One non-invasive option is to use the compiler package that can offer some speed improvements with minimal effort:
#old R version of lapply
slow_func <- function(X, FUN, ...) {
FUN <- match.fun(FUN)
if (!is.list(X))
X <- as.list(X)
rval <- vector("list", length(X))
for(i in seq(along = X))
rval[i] <- list(FUN(X[[i]], ...))
names(rval) <- names(X) # keep `names' !
return(rval)
}
# Compiled versions
require(compiler)
slow_func_compiled <- cmpfun(slow_func)
You can read more about it here. However, if the only issue is sample it looks like Rcpp has an alternative implemention. It looks like it is not faster in all cases though.