Speed up loop operation - r

Question

I need to run a coverage probability test on different sample sizes and censoring proportions. I need to replicate 1000 bootstrap samples using the boot function in R. I have run the code for up to 3-8 hours and I have no idea regarding the runtime.
set.seed(20)
lambda <- 0.02
beta <- 0.5
alpha <- 0.05
n <- 140
N <- 1000
lambda_hat <- NULL
beta_hat <- NULL
cp <- NULL
bp_lambda <- matrix(NA, nrow=N, ncol=2)
bp_beta <- matrix(NA, nrow=N, ncol=2)
for (i in 1:N) {
u <- runif(n)
c_i <- rexp(n, 0.0001)
t_i <- (log(1 - (1/lambda)*log(1 - u)))^(1/beta)
s_i <- 1*(t_i < c_i)
t <- pmin(t_i, c_i)
data <- data.frame(u, t_i, c_i, s_i, t)
estimates.boot <- function(data, j){
data <- data[j, ]
data0 <- data[which(data$s_i == 0), ] #uncensored data
data1 <- data[which(data$s_i == 1), ] #right censored data
data
library(maxLik)
LLF <- function(para) {
t1 <- data$t_i
lambda <- para[1]
beta <- para[2]
e <- s_i*log(lambda*t1^(beta - 1)*beta*exp(t1^beta)*exp(lambda*(1 - exp(t1^beta))))
r <- (1 - s_i)*log(exp(lambda*(1 - exp(t1^beta))))
f <- sum(e + r)
return(f)
}
mle <- maxLik(LLF, start=c(para=c(0.02, 0.5)))
lambda_hat[i] <- mle$estimate[1]
beta_hat[i] <- mle$estimate[2]
return(c(lambda_hat[i], beta_hat[i]))
}
library(boot)
bootstrap <- boot(data, estimates.boot, 1000)
bootlambda <- bootstrap$t[, 1]
klambda <- bootlambda[order(bootlambda)]
bp_lambda[i, ] <- c(klambda[25], klambda[975])
bootbeta <- bootstrap$t[, 2]
kbeta <- bootbeta[order(bootbeta)]
bp_beta[i, ] <- c(kbeta[25], kbeta[975])
}
left_lambda <- sum(bp_lambda[, 1]>lambda)/N
right_lambda <- sum(bp_lambda[, 2]<lambda)/N
total_lambda <- left_lambda + right_lambda
left_beta <- sum(bp_beta[, 1] > beta)/N
right_beta <- sum(bp_beta[, 2]<beta)/N
total_beta <- left_beta + right_beta
sealphahat <- sqrt(alpha*(1 - alpha)/N)
antilambda <- total_lambda>(alpha + 2.58*sealphahat)
conlambda <- total_lambda<(alpha - 2.58*sealphahat)
asymlambda <- (max(left_lambda, right_lambda)/min(left_lambda, right_lambda)) > 1.5
antibeta <- total_beta > (alpha + 2.58*sealphahat)
conbeta <- total_beta < (alpha - 2.58*sealphahat)
asymbeta <- (max(left_beta, right_beta)/min(left_beta, right_beta)) > 1.5
anti <- antilambda + antibeta
con <- conlambda + conbeta
asym <- asymlambda + asymbeta
cbind(anti, con, asym)
Anyone have idea how to speed up the operation?

Answer 1

Basically, you want to apply a random sampling to an estimation function (inner bootstrap) and randomly sample the entire process again (outer bootstrap).
Consequently we could write an estimation function estimate() using replicate() (to avoid boot:boot) and a function for the inner bootstrap innerBoot(). In the latter we could use matrixStats::rowQuantiles for fast computation of the quantiles you want.
I essentially used your code, just fixed a few issues that prevented the code from running.
estimate <- function() {
u <- runif(n)
c_i <- rexp(n, 0.0001)
t_i <- (log(1 - (1/lambda)*log(1 - u)))^(1/beta)
s_i <- 1*(t_i < c_i)
t <- pmin(t_i, c_i)
LLF <- function(para) {
lambda <- para[1]
beta <- para[2]
e <- s_i*log(lambda*t_i^(beta - 1)*beta*exp(t_i^beta)*exp(lambda*(1 - exp(t_i^beta))))
r <- (1 - s_i)*log(exp(lambda*(1 - exp(t_i^beta))))
return(sum(e + r))
}
mle <- maxLik::maxLik(LLF, start=c(para=c(0.02, 0.5)))
return(setNames(mle$estimate, c('lambda_hat', 'beta_hat')))
}
innerBoot <- function() {
boot <- replicate(N, estimate())
return(matrixStats::rowQuantiles(boot, p=c(.025, .975)))
}
We also perform the outer bootstrap with replicate(). I wrap it here in system.time() to get a time measurement.
lambda <- 0.02
beta <- 0.5
alpha <- 0.05
n <- 140
# N <- 1000
N <- 10 ## for testing
seed <- 42
set.seed(seed)
tm <- system.time(
BA <- replicate(N, innerBoot())
)
I got these measurements,
tm
# user system elapsed ## N = 10
# 1.055 0.000 1.057
# user system elapsed ## N = 100
# 102.012 0.227 102.489
which indicates that for N <- 1000 about 167 minutes are to be expected.
The result is an array of dim 2x2xN.
> dim(BA)
[1] 2 2 100
To calculate the summaries we may easily refer to the respective cells.
boot_sum <- function(BA) {
left_lambda <- sum(BA[1, 1, ] > lambda)/N
right_lambda <- sum(BA[1, 2, ] >< lambda)/N
left_beta <- sum(BA[2, 1, ] > beta)/N
right_beta <- sum(BA[2, 2, ] < beta)/N
total_lambda <- left_lambda + right_lambda
total_beta <- left_beta + right_beta
sealphahat <- sqrt(alpha*(1 - alpha)/N)
antilambda <- total_lambda > (alpha + 2.58*sealphahat)
conlambda <- total_lambda < (alpha - 2.58*sealphahat)
asymlambda <- (max(left_lambda, right_lambda)/min(left_lambda, right_lambda)) > 1.5
antibeta <- total_beta > (alpha + 2.58*sealphahat)
conbeta <- total_beta < (alpha - 2.58*sealphahat)
asymbeta <- (max(left_beta, right_beta)/min(left_beta, right_beta)) > 1.5
anti <- antilambda + antibeta
con <- conlambda + conbeta
asym <- asymlambda + asymbeta
return(cbind(anti, con, asym))
}
boot_sum(BA)
# anti con asym
# [1,] 2 0 2
Note: You should definitely check the code in the body of estimate() (i.e. run it manually several times without bootstrapping), as it throws warnings every now and then, probably there is a mistake in how you define LLF().
Warning messages:
1: In log(lambda * t_i^(beta - 1) * beta * exp(t_i^beta) * exp(lambda * :
NaNs produced
2: In log(lambda * t_i^(beta - 1) * beta * exp(t_i^beta) * exp(lambda * :
NaNs produced
Also I'm not sure if the summary calculation currently makes much sense.
My advice is to check your likelihood function and the summary by 1. manually run the lines, 2. starting with a very small N like 10 or so, to see if calculations make sense.
Once you've checked that, it's worth to wait the ~167 minutes to wait for the result.
Or parallelize innerBoot(), which is about 80% faster overall (using 7 cores), as follows:
innerBootParallel <- function() {
boot <- parSapply(cl, 1:N, function(i) estimate())
return(matrixStats::rowQuantiles(boot, p=c(.025, .975)))
}
library(parallel)
cl <- makeCluster(detectCores() - 1)
clusterExport(cl, c('estimate', 'n', 'lambda', 'N', 'beta'))
clusterSetRNGStream(cl, seed)
BA <- replicate(N, innerBootParallel())
stopCluster(cl)
boot_sum(BA)