Skip to content

Instantly share code, notes, and snippets.

@BERENZ
Created October 25, 2015 14:43
Show Gist options
  • Select an option

  • Save BERENZ/9236df77bfef83664305 to your computer and use it in GitHub Desktop.

Select an option

Save BERENZ/9236df77bfef83664305 to your computer and use it in GitHub Desktop.
mclapply with progress bar
## Source: https://stackoverflow.com/questions/10984556/is-there-way-to-track-progress-on-a-mclapply/26892969#26892969
library(parallel)
##------------------------------------------------------------------------------
##' Wrapper around mclapply to track progress
##'
##' Based on http://stackoverflow.com/questions/10984556
##'
##' @param X a vector (atomic or list) or an expressions vector. Other
##' objects (including classed objects) will be coerced by
##' ‘as.list’
##' @param FUN the function to be applied to
##' @param ... optional arguments to ‘FUN’
##' @param mc.preschedule see mclapply
##' @param mc.set.seed see mclapply
##' @param mc.silent see mclapply
##' @param mc.cores see mclapply
##' @param mc.cleanup see mclapply
##' @param mc.allow.recursive see mclapply
##' @param mc.progress track progress?
##' @param mc.style style of progress bar (see txtProgressBar)
##'
##' @examples
##' x <- mclapply2(1:1000, function(i, y) Sys.sleep(0.01))
##' x <- mclapply2(1:3, function(i, y) Sys.sleep(1), mc.cores=1)
##------------------------------------------------------------------------------
mclapply2 <- function(X, FUN, ...,
mc.preschedule = TRUE, mc.set.seed = TRUE,
mc.silent = FALSE, mc.cores = getOption("mc.cores", 2L),
mc.cleanup = TRUE, mc.allow.recursive = TRUE,
mc.progress=TRUE, mc.style=3)
{
if (!is.vector(X) || is.object(X)) X <- as.list(X)
if (mc.progress) {
f <- fifo(tempfile(), open="w+b", blocking=T)
p <- parallel:::mcfork()
pb <- txtProgressBar(0, length(X), style=mc.style)
setTxtProgressBar(pb, 0)
progress <- 0
if (inherits(p, "masterProcess")) {
while (progress < length(X)) {
readBin(f, "double")
progress <- progress + 1
setTxtProgressBar(pb, progress)
}
cat("\n")
parallel:::mcexit()
}
}
tryCatch({
result <- mclapply(X, function(...) {
res <- FUN(...)
if (mc.progress) writeBin(1, f)
res
},
mc.preschedule = mc.preschedule, mc.set.seed = mc.set.seed,
mc.silent = mc.silent, mc.cores = mc.cores,
mc.cleanup = mc.cleanup, mc.allow.recursive = mc.allow.recursive
)
}, finally = {
if (mc.progress) close(f)
})
result
}
@SBien
Copy link

SBien commented Feb 17, 2022

HI there, this function would be so helpful for me but for some reason I can't get it to track past 0% even with your examples. I've spent some time trying to troubleshoot, but I haven't had any luck. Any chance you could test this out again and see if it works for you on R versions 3.6.1+ ?

@BERENZ
Copy link
Author

BERENZ commented Feb 18, 2022

Hi, this code was developed quite long ago (around 6 years) and I do not know if it still works. I suggest looking for more up-to-date routines or packages (e.g. future).

@SBien
Copy link

SBien commented Feb 18, 2022 via email

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment