pbapply/0000755000175100001440000000000013126635075011747 5ustar hornikuserspbapply/NAMESPACE0000644000175100001440000000072413126601006013154 0ustar hornikusersif (Sys.getenv("R_OSTYPE") == "windows" || .Platform$OS.type == "windows") { importFrom(utils, winProgressBar, getWinProgressBar, setWinProgressBar) } importFrom(utils, txtProgressBar, getTxtProgressBar, setTxtProgressBar, flush.console) importFrom(parallel, mclapply, parLapply) export(pbapply, pbsapply, pblapply, pbreplicate, startpb, setpb, getpb, closepb, dopb, pboptions, timerProgressBar, setTimerProgressBar, getTimerProgressBar, splitpb) pbapply/R/0000755000175100001440000000000013126601006012133 5ustar hornikuserspbapply/R/pbreplicate.R0000644000175100001440000000024513126601006014551 0ustar hornikuserspbreplicate <- function (n, expr, simplify = "array", cl = NULL) pbsapply(integer(n), eval.parent(substitute(function(...) expr)), simplify = simplify, cl = cl) pbapply/R/dopb.R0000644000175100001440000000073313126601006013205 0ustar hornikusersdopb <- function() { progress.bar <- getOption("pboptions")$type if (!is.null(progress.bar)) { TYPE <- c("timer", "txt", "tk", "none") if (.Platform$OS.type == "windows") TYPE <- c(TYPE, "win") progress.bar <- match.arg(progress.bar, TYPE) if (progress.bar == "none") progress.bar <- NULL if (!is.null(getOption("knitr.in.progress"))) progress.bar <- NULL } !is.null(progress.bar) } pbapply/R/splitpb.R0000644000175100001440000000056513126601006013741 0ustar hornikuserssplitpb <- function(nx, ncl, nout = NULL) { i <- seq_len(nx) if (ncl == 0L) return(list()) if (is.null(nout)) { k <- 1L } else { if (nout < 1L) stop("nout must be > 0") k <- max(1L, ceiling(ceiling(nx / ncl) / nout)) } g <- 1L + (i - 1L) %/% as.integer(ncl * k) structure(split(i, g), names = NULL) } pbapply/R/timerProgressBar.R0000644000175100001440000002644413126601006015562 0ustar hornikuserstimerProgressBar <- function(min = 0, max = 1, initial = 0, char = "=", width = NA, title, label, style = 1, file = "", min_time = 0) { if (!identical(file, "") && !(inherits(file, "connection") && isOpen(file))) stop("'file' must be \"\" or an open connection object") if (max <= min) stop("must have 'max' > 'min'") if (!(style %in% 1:6)) style <- 1 if (style %in% c(2, 4)) # throbber only .counter <- force(1) .start <- proc.time()[["elapsed"]] .min <- force(min) .max <- force(max) .i <- force(initial) .killed <- FALSE ## start showing pb right away when min_time = 0 .showpb <- if (min_time > 0) FALSE else TRUE getVal <- function() .i if (nchar(char, "w") < 1) char <- "=" if (nchar(char, "w") > 1 && style %in% 1:4) char <- substr(char, 1, 1) if (nchar(char, "w") > 4 && style %in% 5:6) char <- substr(char, 1, 4) if (style %in% 5:6) { if (nchar(char, "w") == 1) char <- c("|", char, " ", "|") else if (nchar(char, "w") == 2) char <- c(substr(char,1,1), substr(char,2,2), " ", substr(char,1,1)) else if (nchar(char, "w") == 3) char <- c(substr(char,1,1), substr(char,2,2), substr(char,3,3), substr(char,1,1)) else if (nchar(char, "w") == 4) char <- c(substr(char,1,1), substr(char,2,2), substr(char,3,3), substr(char,4,4)) if (char[2] == char[3]) char[3] <- " " } if (is.na(width)) width <- options("width")[[1]] ## |= | style progress bar with elapsed and remaining time up1 <- function(value) { if (!is.finite(value) || value < min || value > max) return() time0 <- proc.time()[["elapsed"]] - .start .i <<- value i <- .i - .min n <- .max - .min time <- time0 / (i / n) - time0 if (.i > .min && sum(time0, time, na.rm=TRUE) > min_time) .showpb <<- TRUE if (.showpb) { spentTime <- paste0(" elapsed =", getTimeAsString(time0)) leftTime <- if (i == 0) "" else paste0(", remaining ~", getTimeAsString(time)) minLetters <- nchar("%%%% ~00h 00m 00s", "w") ## 79-24=55 > 50 txtWidth <- max(width, width - minLetters - 4) text <- paste0(sprintf("%-2.0f%%", 100 * i / n), spentTime, leftTime) if(nchar(text, "w") < minLetters) text <- paste(text, paste(rep(" ", minLetters - nchar(text, "w")), collapse = "")) if(txtWidth < 0) cat("\r ", text, file = file) bb <- paste(rep(char, ceiling(txtWidth * i / n)), collapse = "") empty <- paste(rep(" ", floor(txtWidth * (1 - i / n))), collapse = "") bar <- paste(" |", bb, empty, "|", sep = "") cat(paste("\r", bar, text), file = file) flush.console() } } ## throbber with elapsed and remaining time up2 <- function(value) { if (!is.finite(value) || value < min || value > max) return() time0 <- proc.time()[["elapsed"]] - .start .i <<- value i <- .i - .min n <- .max - .min time <- time0 / (i / n) - time0 if (i != 0) .counter <<- .counter + 1 if (.i > .min && sum(time0, time, na.rm=TRUE) > min_time) .showpb <<- TRUE if (.showpb) { spentTime <- paste0(" elapsed =", getTimeAsString(time0)) leftTime <- if (i == 0) "" else paste0(", remaining ~", getTimeAsString(time)) minLetters <- nchar("%%%% ~00h 00m 00s", "w") ## 79-24=55 > 50 txtWidth <- max(width, width - minLetters - 4) text <- paste0(sprintf("%-2.0f%%", 100 * i / n), spentTime, leftTime) if(nchar(text, "w") < minLetters) text <- paste(text, paste(rep(" ", minLetters - nchar(text, "w")), collapse = "")) if(txtWidth < 0) cat("\r ", text, file = file) bb <- paste(rep(char, ceiling(txtWidth * i / n)), collapse = "") bar <- c("|", "/", "-", "\\")[(.counter %% 4) + 1] cat(paste("\r", bar, text), file = file) flush.console() } } ## |= | style progress bar with remaining time up3 <- function(value) { if (!is.finite(value) || value < min || value > max) return() time0 <- proc.time()[["elapsed"]] - .start .i <<- value i <- .i - .min n <- .max - .min time <- time0 / (i / n) - time0 if (.i > .min && sum(time0, time, na.rm=TRUE) > min_time) .showpb <<- TRUE if (.showpb) { prefix <- if (i != n) " ~" else " elapsed = " leftTime <- if (i == 0) getTimeAsString(NULL) else if (i != n) getTimeAsString(time) else getTimeAsString(time0) minLetters <- nchar("%%%% ~00h 00m 00s", "w") ## 79-24=55 > 50 txtWidth <- max(width, width - minLetters - 4) text <- paste0(sprintf("%-2.0f%%", 100 * i / n), prefix, leftTime) if(nchar(text, "w") < minLetters) text <- paste(text, paste(rep(" ", minLetters - nchar(text, "w")), collapse = "")) if(txtWidth < 0) cat("\r ", text, file = file) bb <- paste(rep(char, ceiling(txtWidth * i / n)), collapse = "") empty <- paste(rep(" ", floor(txtWidth * (1 - i / n))), collapse = "") bar <- paste(" |", bb, empty, "|", sep = "") cat(paste("\r", bar, text), file = file) flush.console() } } ## throbber with remaining time up4 <- function(value) { if (!is.finite(value) || value < min || value > max) return() time0 <- proc.time()[["elapsed"]] - .start .i <<- value i <- .i - .min n <- .max - .min time <- time0 / (i / n) - time0 if (i != 0) .counter <<- .counter + 1 if (.i > .min && sum(time0, time, na.rm=TRUE) > min_time) .showpb <<- TRUE if (.showpb) { prefix <- if (i != n) " ~" else " elapsed = " leftTime <- if (i == 0) getTimeAsString(NULL) else if (i != n) getTimeAsString(time) else getTimeAsString(time0) minLetters <- nchar("%%%% ~00h 00m 00s", "w") ## 79-24=55 > 50 txtWidth <- max(width, width - minLetters - 4) text <- paste0(sprintf("%-2.0f%%", 100 * i / n), prefix, leftTime) if(nchar(text, "w") < minLetters) text <- paste(text, paste(rep(" ", minLetters - nchar(text, "w")), collapse = "")) if(txtWidth < 0) cat("\r ", text, file = file) bb <- paste(rep(char, ceiling(txtWidth * i / n)), collapse = "") bar <- c("|", "/", "-", "\\")[(.counter %% 4) + 1] cat(paste("\r", bar, text), file = file) flush.console() } } ## [=-] style progress bar with elapsed and remaining time up5 <- function(value) { if (!is.finite(value) || value < min || value > max) return() time0 <- proc.time()[["elapsed"]] - .start .i <<- value i <- .i - .min n <- .max - .min time <- time0 / (i / n) - time0 if (.i > .min && sum(time0, time, na.rm=TRUE) > min_time) .showpb <<- TRUE if (.showpb) { spentTime <- paste0(" elapsed =", getTimeAsString(time0)) leftTime <- if (i == 0) "" else paste0(", remaining ~", getTimeAsString(time)) minLetters <- nchar("%%%% ~00h 00m 00s", "w") ## 79-24=55 > 50 txtWidth <- max(width, width - minLetters - 4) text <- paste0(sprintf("%-2.0f%%", 100 * i / n), spentTime, leftTime) if(nchar(text, "w") < minLetters) text <- paste(text, paste(rep(" ", minLetters - nchar(text, "w")), collapse = "")) if(txtWidth < 0) cat("\r ", text, file = file) bb <- paste(rep(char[2], ceiling(txtWidth * i / n)), collapse = "") empty <- paste(rep(char[3], floor(txtWidth * (1 - i / n))), collapse = "") bar <- paste(" ", char[1], bb, empty, char[4], sep = "") cat(paste("\r", bar, text), file = file) flush.console() } } ## [=-] style progress bar with remaining time up6 <- function(value) { if (!is.finite(value) || value < min || value > max) return() time0 <- proc.time()[["elapsed"]] - .start .i <<- value i <- .i - .min n <- .max - .min time <- time0 / (i / n) - time0 if (.i > .min && sum(time0, time, na.rm=TRUE) > min_time) .showpb <<- TRUE if (.showpb) { prefix <- if (i != n) " ~" else " elapsed = " leftTime <- if (i == 0) getTimeAsString(NULL) else if (i != n) getTimeAsString(time) else getTimeAsString(time0) minLetters <- nchar("%%%% ~00h 00m 00s", "w") ## 79-24=55 > 50 txtWidth <- max(width, width - minLetters - 4) text <- paste0(sprintf("%-2.0f%%", 100 * i / n), prefix, leftTime) if(nchar(text, "w") < minLetters) text <- paste(text, paste(rep(" ", minLetters - nchar(text, "w")), collapse = "")) if(txtWidth < 0) cat("\r ", text, file = file) bb <- paste(rep(char[2], ceiling(txtWidth * i / n)), collapse = "") empty <- paste(rep(char[3], floor(txtWidth * (1 - i / n))), collapse = "") bar <- paste(" ", char[1], bb, empty, char[4], sep = "") cat(paste("\r", bar, text), file = file) flush.console() } } kill <- function() if (!.killed) { if (.showpb) { cat("\n", file = file) flush.console() } .killed <<- TRUE } up <- switch(style, up1, up2, up3, up4, up5, up6) up(initial) structure(list(getVal = getVal, up = up, kill = kill), class = c("timerProgressBar","txtProgressBar")) } setTimerProgressBar <- setTxtProgressBar getTimerProgressBar <- getTxtProgressBar ## converts time in seconds into ~HHh MMm SSs format getTimeAsString <- function(time) { if (is.null(time)) { return("calculating") } else { if(is.infinite(time)) return("Inf") } sec <- round(time %% 60) time <- floor(time / 60) minutes <- floor(time %% 60) time <- floor(time / 60) days <- floor(time / 24) time <- floor(time %% 24) hours <- floor(time %% 60) resTime <- "" if (days > 0) resTime <- sprintf("%02id ", days) if (hours > 0 || days > 0) resTime <- paste(resTime, sprintf("%02ih ", hours), sep = "") if (minutes > 0 || hours > 0 || days > 0) resTime <- paste(resTime, sprintf("%02im ", minutes), sep = "") resTime <- paste0(resTime, sprintf("%02is", sec)) resTime } pbapply/R/windows/0000755000175100001440000000000013126601006013625 5ustar hornikuserspbapply/R/windows/getpb.R0000644000175100001440000000054213126601006015052 0ustar hornikusersgetpb <- function(pb) { if (dopb()) { progress.bar <- getOption("pboptions")$type rval <- switch(progress.bar, timer = getTxtProgressBar(pb), txt = getTxtProgressBar(pb), win = getWinProgressBar(pb), tk = tcltk::getTkProgressBar(pb)) } else { rval <- NULL } rval } pbapply/R/windows/startpb.R0000644000175100001440000000203513126601006015427 0ustar hornikusersstartpb <- function(min=0, max=1) { if (dopb()) { control <- getOption("pboptions") pb <- switch(control$type, timer = timerProgressBar(min = min, max = max, initial = control$initial, style = control$style, width = control$txt.width, char = control$char, min_time = control$min_time), txt = txtProgressBar(min = min, max = max, initial = control$initial, style = control$style, width = control$txt.width, char = control$char), win = winProgressBar(min = min, max = max, initial = control$initial, title = control$title, label = control$label, width = control$gui.width), tk = tcltk::tkProgressBar(min = min, max = max, initial=control$initial, title = control$title, label = control$label, width = control$gui.width)) } else { pb <- NULL } invisible(pb) } pbapply/R/windows/setpb.R0000644000175100001440000000066413126601006015073 0ustar hornikuserssetpb <- function(pb, value) { if (dopb()) { control <- getOption("pboptions") rval <- switch(control$type, timer = setTxtProgressBar(pb, value), txt = setTxtProgressBar(pb, value), win = setWinProgressBar(pb, value, label = control$label), tk = tcltk::setTkProgressBar(pb, value, label = control$label)) } else { rval <- NULL } invisible(rval) } pbapply/R/unix/0000755000175100001440000000000013126601006013116 5ustar hornikuserspbapply/R/unix/getpb.R0000644000175100001440000000047113126601006014344 0ustar hornikusersgetpb <- function(pb) { if (dopb()) { progress.bar <- getOption("pboptions")$type rval <- switch(progress.bar, timer = getTxtProgressBar(pb), txt = getTxtProgressBar(pb), tk = tcltk::getTkProgressBar(pb)) } else { rval <- NULL } rval } pbapply/R/unix/startpb.R0000644000175100001440000000152313126601006014721 0ustar hornikusersstartpb <- function(min=0, max=1) { if (dopb()) { control <- getOption("pboptions") pb <- switch(control$type, timer = timerProgressBar(min = min, max = max, initial = control$initial, style = control$style, width = control$txt.width, char = control$char, min_time = control$min_time), txt = txtProgressBar(min = min, max = max, initial = control$initial, style = control$style, width = control$txt.width, char = control$char), tk = tcltk::tkProgressBar(min = min, max = max, initial = control$initial, title = control$title, label = control$label, width = control$gui.width)) } else { pb <- NULL } invisible(pb) } pbapply/R/unix/setpb.R0000644000175100001440000000055513126601006014363 0ustar hornikuserssetpb <- function(pb, value) { if (dopb()) { control <- getOption("pboptions") rval <- switch(control$type, timer = setTxtProgressBar(pb, value), txt = setTxtProgressBar(pb, value), tk = tcltk::setTkProgressBar(pb, value, label = control$label)) } else { rval <- NULL } invisible(rval) } pbapply/R/pbapply.R0000644000175100001440000001007413126601006013727 0ustar hornikuserspbapply <- function (X, MARGIN, FUN, ..., cl = NULL) { FUN <- match.fun(FUN) dl <- length(dim(X)) if (!dl) stop("dim(X) must have a positive length") if (is.object(X)) X <- if (dl == 2L) as.matrix(X) else as.array(X) d <- dim(X) dn <- dimnames(X) ds <- seq_len(dl) if (is.character(MARGIN)) { if (is.null(dnn <- names(dn))) stop("'X' must have named dimnames") MARGIN <- match(MARGIN, dnn) if (anyNA(MARGIN)) stop("not all elements of 'MARGIN' are names of dimensions") } s.call <- ds[-MARGIN] s.ans <- ds[MARGIN] d.call <- d[-MARGIN] d.ans <- d[MARGIN] dn.call <- dn[-MARGIN] dn.ans <- dn[MARGIN] d2 <- prod(d.ans) if (d2 == 0L) { newX <- array(vector(typeof(X), 1L), dim = c(prod(d.call), 1L)) ans <- forceAndCall(1, FUN, if (length(d.call) < 2L) newX[, 1] else array(newX[, 1L], d.call, dn.call), ...) return(if (is.null(ans)) ans else if (length(d.ans) < 2L) ans[1L][-1L] else array(ans, d.ans, dn.ans)) } newX <- aperm(X, c(s.call, s.ans)) dim(newX) <- c(prod(d.call), d2) ans <- vector("list", d2) if (is.null(cl)) { # sequential follows base::apply pb <- startpb(0, d2) # pb_specific_code if (length(d.call) < 2L) { if (length(dn.call)) dimnames(newX) <- c(dn.call, list(NULL)) for (i in 1L:d2) { tmp <- forceAndCall(1, FUN, newX[, i], ...) if (!is.null(tmp)) ans[[i]] <- tmp setpb(pb, i) # pb_specific_code } } else for (i in 1L:d2) { tmp <- forceAndCall(1, FUN, array(newX[, i], d.call, dn.call), ...) if (!is.null(tmp)) ans[[i]] <- tmp setpb(pb, i) # pb_specific_code } closepb(pb) # pb_specific_code ans.list <- is.recursive(ans[[1L]]) l.ans <- length(ans[[1L]]) ans.names <- names(ans[[1L]]) if (!ans.list) ans.list <- any(unlist(lapply(ans, length)) != l.ans) if (!ans.list && length(ans.names)) { all.same <- vapply(ans, function(x) identical(names(x), ans.names), NA) if (!all(all.same)) ans.names <- NULL } } else { # parallel follows parallel::parApply arglist <- if (length(d.call) < 2L) { if (length(dn.call)) dimnames(newX) <- c(dn.call, list(NULL)) lapply(seq_len(d2), function(i) newX[, i]) } else lapply(seq_len(d2), function(i) array(newX[, i], d.call, dn.call)) #ans <- parallel::parLapply(cl = cl, X = arglist, fun = FUN, ...) ## rely on pblapply for calling parLapply with pb ans <- pblapply(X = arglist, FUN = FUN, ..., cl = cl) ans.list <- is.recursive(ans[[1L]]) l.ans <- length(ans[[1L]]) ans.names <- names(ans[[1L]]) if (!ans.list) ans.list <- any(lengths(ans) != l.ans) if (!ans.list && length(ans.names)) { all.same <- vapply(ans, function(x) identical(names(x), ans.names), NA) if (!all(all.same)) ans.names <- NULL } } # end of parallel portion len.a <- if (ans.list) d2 else length(ans <- unlist(ans, recursive = FALSE)) if (length(MARGIN) == 1L && len.a == d2) { names(ans) <- if (length(dn.ans[[1L]])) dn.ans[[1L]] return(ans) } if (len.a == d2) return(array(ans, d.ans, dn.ans)) if (len.a && len.a%%d2 == 0L) { if (is.null(dn.ans)) dn.ans <- vector(mode = "list", length(d.ans)) dn1 <- if (length(dn.call) && length(ans.names) == length(dn.call[[1L]])) dn.call[1L] else list(ans.names) dn.ans <- c(dn1, dn.ans) return(array(ans, c(len.a%/%d2, d.ans), if (!is.null(names(dn.ans)) || !all(vapply(dn.ans, is.null, NA))) dn.ans)) } return(ans) } pbapply/R/pboptions.R0000644000175100001440000000055513126601006014300 0ustar hornikuserspboptions <- function(...) { opar <- getOption("pboptions") args <- list(...) if (length(args)) { if (length(args)==1 && is.list(args[[1]])) { npar <- args[[1]] } else { npar <- opar npar[match(names(args), names(npar))] <- args } options("pboptions"=npar) } invisible(opar) } pbapply/R/pbsapply.R0000644000175100001440000000063213126601006014111 0ustar hornikuserspbsapply <- function (X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE, cl = NULL) { FUN <- match.fun(FUN) answer <- pblapply(X = X, FUN = FUN, ..., cl = cl) # pb_specific_code if (USE.NAMES && is.character(X) && is.null(names(answer))) names(answer) <- X if (!identical(simplify, FALSE) && length(answer)) simplify2array(answer, higher = (simplify == "array")) else answer } pbapply/R/pblapply.R0000644000175100001440000000460013126601006014101 0ustar hornikuserspblapply <- function (X, FUN, ..., cl = NULL) { FUN <- match.fun(FUN) if (!is.vector(X) || is.object(X)) X <- as.list(X) ## catch single node requests and forking on Windows if (!is.null(cl)) { if (.Platform$OS.type == "windows") { if (!inherits(cl, "cluster")) cl <- NULL } else { if (inherits(cl, "cluster")) { if (length(cl) < 2L) cl <- NULL } else { if (cl < 2) cl <- NULL } } } nout <- as.integer(getOption("pboptions")$nout) ## sequential evaluation if (is.null(cl)) { if (!dopb()) return(lapply(X, FUN, ...)) Split <- splitpb(length(X), 1L, nout = nout) B <- length(Split) pb <- startpb(0, B) on.exit(closepb(pb), add = TRUE) rval <- vector("list", B) for (i in seq_len(B)) { rval[i] <- list(lapply(X[Split[[i]]], FUN, ...)) setpb(pb, i) } ## parallel evaluation } else { ## snow type cluster if (inherits(cl, "cluster")) { if (!dopb()) return(parallel::parLapply(cl, X, FUN, ...)) ## define split here and use that for counter Split <- splitpb(length(X), length(cl), nout = nout) B <- length(Split) pb <- startpb(0, B) on.exit(closepb(pb), add = TRUE) rval <- vector("list", B) for (i in seq_len(B)) { rval[i] <- list(parallel::parLapply(cl, X[Split[[i]]], FUN, ...)) setpb(pb, i) } ## multicore type forking } else { if (!dopb()) return(parallel::mclapply(X, FUN, ..., mc.cores = as.integer(cl))) ## define split here and use that for counter Split <- splitpb(length(X), as.integer(cl), nout = nout) B <- length(Split) pb <- startpb(0, B) on.exit(closepb(pb), add = TRUE) rval <- vector("list", B) for (i in seq_len(B)) { rval[i] <- list(parallel::mclapply(X[Split[[i]]], FUN, ..., mc.cores = as.integer(cl))) setpb(pb, i) } } } ## assemble output list rval <- do.call(c, rval, quote = TRUE) names(rval) <- names(X) rval } pbapply/R/closepb.R0000644000175100001440000000013113126601006013700 0ustar hornikusersclosepb <- function(pb) { if (is.null(pb)) invisible(NULL) else close(pb) } pbapply/R/zzz.R0000644000175100001440000000130713126601006013114 0ustar hornikusers.onLoad <- function(libname, pkgname){ opts <- list( type = if (interactive()) "timer" else "none", char = "+", txt.width = 50, gui.width = 300, style = 3, initial = 0, title = "R progress bar", label = "", nout = 100L, min_time = 0) optsx <- getOption("pboptions") if (!is.null(optsx)) { for (i in intersect(names(opts), names(optsx))) opts[[i]] <- optsx[[i]] for (i in setdiff(names(optsx), names(opts))) opts[[i]] <- optsx[[i]] } options("pboptions" = opts) invisible(NULL) } .onUnload <- function(libpath){ options("pboptions" = NULL) invisible(NULL) } pbapply/MD50000644000175100001440000000206213126635075012257 0ustar hornikusers634ae917da93c0a42dfe88d18df48a5e *DESCRIPTION fe00b090c7e865872b8643fd9d8ff621 *NAMESPACE c9afd75355061c7922a002ec6ddb33c9 *R/closepb.R 221788dffaa31a3b8160079c02c2dc23 *R/dopb.R 87d7e4735a89a0d4089ba9acbe119b75 *R/pbapply.R e1639bff924b07970a9fff10bf40ea3b *R/pblapply.R 56640b298b3c95255a1dc60302a23fee *R/pboptions.R 85fb7bf9dec3cba585b01fe5c5ff9914 *R/pbreplicate.R d40dc483c2eb8643b6e329da442ff74d *R/pbsapply.R f353dd9c023034a3dd7b554481f2cb0b *R/splitpb.R b500c0f2d2260ed4604945490051b71c *R/timerProgressBar.R 2a9e06eaae38c714caef04394e528f4f *R/unix/getpb.R d7ade2ac6cca19205c48196f676b4c2d *R/unix/setpb.R abbfcb9ec095f9e6a1a5066a1b463549 *R/unix/startpb.R 5efeb944a3107a583c0f9bd13632d7dc *R/windows/getpb.R 311c277daa16a7d14792f97178cf34e9 *R/windows/setpb.R 6709ac3060b2a1167e16e51124ed31b7 *R/windows/startpb.R 08953ef66f94e65f7263665337682cbc *R/zzz.R 1615a712313d4377812e2f6287e4050f *man/pbapply.Rd 4ea0a842dc7b0e51ca2a1ad09726494d *man/pboptions.Rd f032d5b07255b3ca4062e0c06c6136fd *man/splitpb.Rd 5a9011ca722467cae6131d1091ee1cd3 *man/timerProgressBar.Rd pbapply/DESCRIPTION0000644000175100001440000000153013126635075013454 0ustar hornikusersPackage: pbapply Type: Package Title: Adding Progress Bar to '*apply' Functions Version: 1.3-3 Date: 2017-07-03 Author: Peter Solymos [aut, cre], Zygmunt Zawadzki [aut] Maintainer: Peter Solymos Description: A lightweight package that adds progress bar to vectorized R functions ('*apply'). The implementation can easily be added to functions where showing the progress is useful (e.g. bootstrap). The type and style of the progress bar (with percentages or remaining time) can be set through options. Supports several parallel processing backends. Depends: R (>= 3.2.0) Imports: parallel License: GPL-2 URL: https://github.com/psolymos/pbapply BugReports: https://github.com/psolymos/pbapply/issues NeedsCompilation: no Packaged: 2017-07-04 02:48:38 UTC; root Repository: CRAN Date/Publication: 2017-07-04 06:48:29 UTC pbapply/man/0000755000175100001440000000000013126601006012505 5ustar hornikuserspbapply/man/timerProgressBar.Rd0000644000175100001440000001066513126601006016276 0ustar hornikusers\name{timerProgressBar} \alias{timerProgressBar} \alias{setTimerProgressBar} \alias{getTimerProgressBar} \title{ Timer Progress Bar } \description{ Text progress bar with timer in the R console. } \usage{ timerProgressBar(min = 0, max = 1, initial = 0, char = "=", width = NA, title, label, style = 1, file = "", min_time = 0) getTimerProgressBar(pb) setTimerProgressBar(pb, value, title = NULL, label = NULL) } \arguments{ \item{min, max}{ (finite) numeric values for the extremes of the progress bar. Must have \code{min} < \code{max}. } \item{initial, value}{ initial or new value for the progress bar. See Details for what happens with invalid values. } \item{char}{ he character (or character string) to form the progress bar. If number of characters is >1, it is silently stripped to length 1 unless \code{style} is 5 or 6 (see Details). } \item{width}{ the width of the progress bar, as a multiple of the width of char. If \code{NA}, the default, the number of characters is that which fits into \code{getOption("width")}. } \item{style}{ the style taking values between 1 and 6. 1: progress bar with elapsed and remaining time, remaining percentage is indicated by spaces between pipes (default for this function), 2: throbber with elapsed and remaining time, 3: progress bar with remaining time printing elapsed time at the end, remaining percentage is indicated by spaces between pipes (default for \code{style} option in \code{\link{pboptions}}), 4: throbber with remaining time printing elapsed time at the end, 5: progress bar with elapsed and remaining time with more flexible styling (see Details and Examples), 6: progress bar with remaining time printing elapsed time at the end with more flexible styling (see Details and Examples). } \item{file}{ an open connection object or \code{""} which indicates the console. } \item{min_time}{ numeric, minimum processing time (in seconds) required to show a progress bar. } \item{pb}{ an object of class \code{"timerProgressBar"}. } \item{title, label}{ ignored, for compatibility with other progress bars. } } \details{ \code{timerProgressBar} will display a progress bar on the R console (or a connection) via a text representation. \code{setTimerProgessBar} will update the value. Missing (\code{NA}) and out-of-range values of value will be (silently) ignored. (Such values of \code{initial} cause the progress bar not to be displayed until a valid value is set.) The progress bar should be closed when finished with: this outputs the final newline character (see \code{\link{closepb}}). If \code{style} is 5 or 6, it is possible to define up to 4 characters for the \code{char} argument (as a single string) for the left end, elapsed portion, remaining portion, and right end of the progress bar (\code{|= |} by default). Remaining portion cannot be the same as the elapsed portion (space is used for remaining in such cases). If 1 character is defined, it is taken for the elapsed portion. If 2-4 characters are defined, those are interpreted in sequence (left and right end being the same when 2-3 characters defined), see Examples. } \value{ For \code{timerProgressBar} an object of class \code{"timerProgressBar"} inheriting from \code{"txtProgressBar"}. For \code{getTimerProgressBar} and \code{setTimerProgressBar}, a length-one numeric vector giving the previous value (invisibly for \code{setTimerProgressBar}). } \author{ Zygmunt Zawadzki Peter Solymos } \seealso{ The \code{timerProgressBar} implementation follows closely the code of \code{\link[utils]{txtProgressBar}}. } \examples{ ## increase sluggishness to admire the progress bar longer sluggishness <- 0.02 test_fun <- function(...) { pb <- timerProgressBar(...) on.exit(close(pb)) for(i in seq(0, 1, 0.05)) { Sys.sleep(sluggishness) setTimerProgressBar(pb, i) } invisible(NULL) } ## check the different styles test_fun(width = 35, char = "+", style = 1) test_fun(style = 2) test_fun(width = 50, char = ".", style = 3) test_fun(style = 4) test_fun(width = 35, char = "[=-]", style = 5) test_fun(width = 50, char = "{*.}", style = 6) ## no bar only percent and elapsed test_fun(width = 0, char = " ", style = 6) ## this should produce a progress bar based on min_time (elapsed <- system.time(test_fun(width = 35, min_time = 0))["elapsed"]) ## this should not produce a progress bar based on min_time system.time(test_fun(min_time = 2 * elapsed))["elapsed"] } \keyword{ utilities } pbapply/man/splitpb.Rd0000644000175100001440000000230413126601006014450 0ustar hornikusers\name{splitpb} \alias{splitpb} \title{ Divide Tasks for Progress-bar Friendly Distribution in a Cluster } \description{ Divides up \code{1:nx} into approximately equal sizes (\code{ncl}) as a way to allocate tasks to nodes in a cluster repeatedly while updating a progress bar. } \usage{ splitpb(nx, ncl, nout = NULL) } \arguments{ \item{nx}{ Number of tasks. } \item{ncl}{ Number of cluster nodes. } \item{nout}{ Integer, maximum number of partitions in the output (must be > 0). } } \value{ A list of length \code{min(nout, ceiling(nx / ncl))}, each element being an integer vector of length \code{ncl * k} or less, where \code{k} is a tuning parameter constrained by the other arguments (\code{k = max(1L, ceiling(ceiling(nx / ncl) / nout))} and \code{k = 1} if \code{nout = NULL}). } \author{ Peter Solymos } \seealso{ Parallel usage of \code{\link{pbapply}} and related functions. } \examples{ ## define 1 job / worker at a time and repeat splitpb(10, 4) ## compare this to the no-progress-bar split ## that defines all the jubs / worker up front parallel::splitIndices(10, 4) ## cap the length of the output splitpb(20, 2, nout = NULL) splitpb(20, 2, nout = 5) } \keyword{ utilities } pbapply/man/pboptions.Rd0000644000175100001440000001123413126601006015012 0ustar hornikusers\name{pboptions} \alias{pboptions} \alias{startpb} \alias{setpb} \alias{getpb} \alias{closepb} \alias{dopb} \title{ Creating Progress Bar and Setting Options } \description{ Creating progress bar and setting options. } \usage{ pboptions(...) startpb(min = 0, max = 1) setpb(pb, value) getpb(pb) closepb(pb) dopb() } \arguments{ \item{\dots}{ Arguments in \code{tag = value} form, or a list of tagged values. The tags must come from the parameters described below. } \item{pb}{ A progress bar object created by \code{startpb}. } \item{min, max}{ Finite numeric values for the extremes of the progress bar. Must have \code{min < max}. } \item{value}{ New value for the progress bar. } } \details{ \code{pboptions} is a convenient way of handling options related to progress bar. Other functions can be used for conveniently adding progress bar to \code{for}-like loops (see Examples). } \value{ When parameters are set by \code{pboptions}, their former values are returned in an invisible named list. Such a list can be passed as an argument to \code{pboptions} to restore the parameter values. Tags are the following: \item{type}{Type of the progress bar: timer (\code{"timer"}), text (\code{"txt"}), Windows (\code{"win"}), TclTk (\code{"tk"}), or none (\code{"none"}). Default value is \code{"timer"} progress bar with estimated remaining time when in interactive mode, and \code{"none"} otherwise.} \item{char}{The character (or character string) to form the progress bar. Default value is \code{"+"}.} \item{txt.width}{The width of the text based progress bar, as a multiple of the width of \code{char}. If \code{NA}, the number of characters is that which fits into \code{getOption("width")}. Default value is \code{50}.} \item{gui.width}{The width of the GUI based progress bar in pixels: the dialogue box will be 40 pixels wider (plus frame). Default value is \code{300}.} \item{style}{The style of the bar, see \code{\link[utils]{txtProgressBar}} and \code{\link{timerProgressBar}}. Default value is \code{3}.} \item{initial}{Initial value for the progress bar. Default value is \code{0}.} \item{title}{Character string giving the window title on the GUI dialogue box. Default value is \code{"R progress bar"}.} \item{label}{Character string giving the window label on the GUI dialogue box. Default value is \code{""}.} \item{nout}{Integer, the maximum number of times the progress bar is updated. The default value is 100. Smaller value minimizes the running time overhead related to updating the progress bar. This can be especially important for forking type parallel runs.} \item{min_time}{Minimum time in seconds. \code{\link{timerProgressBar}} output is printed only if estimated completion time is higher than this value. The default value is 0.} For \code{startpb} a progress bar object. For \code{getpb} and \code{setpb}, a length-one numeric vector giving the previous value (invisibly for \code{setpb}). The return value is \code{NULL} if the progress bar is turned off by \code{getOption("pboptions")$type} (\code{"none"} or \code{NULL} value). \code{dopb} returns a logical value if progress bar is to be shown based on the option \code{getOption("pboptions")$type}. It is \code{FALSE} if the type of progress bar is \code{"none"} or \code{NULL}. For \code{closepb} closes the connection for the progress bar. } \author{ Peter Solymos } \seealso{ Progress bars used in the functions: #ifdef windows \code{\link[utils]{winProgressBar}}, #endif \code{\link{timerProgressBar}}, \code{\link[utils]{txtProgressBar}}, \code{\link[tcltk]{tkProgressBar}} } \examples{ ## for loop fun1 <- function() { pb <- startpb(0, 10) on.exit(closepb(pb)) for (i in 1:10) { Sys.sleep(0.15) setpb(pb, i) } invisible(NULL) } ## while loop fun2 <- function() { pb <- startpb(0, 10-1) on.exit(closepb(pb)) i <- 1 while (i < 10) { Sys.sleep(0.15) setpb(pb, i) i <- i + 1 } invisible(NULL) } ## using original settings fun1() ## resetting pboptions opb <- pboptions(style = 1, char = ">") ## check new settings getOption("pboptions") ## running again with new settings fun2() ## resetting original pboptions(opb) ## check reset getOption("pboptions") fun1() ## dealing with nested progress bars ## when only one the 1st one is needed f <- function(x) Sys.sleep(0.01) g <- function(x) pblapply(1:10, f) tmp <- lapply(1:10, g) # undesirable ## here is the desirable solution h <- function(x) { opb <- pboptions(type="none") on.exit(pboptions(opb)) pblapply(1:10, f) } tmp <- pblapply(1:10, h) } \keyword{ IO } \keyword{ utilities } pbapply/man/pbapply.Rd0000644000175100001440000002130513126601006014444 0ustar hornikusers\name{pbapply} \alias{pbapply} \alias{pbsapply} \alias{pblapply} \alias{pbreplicate} \title{ Adding Progress Bar to '*apply' Functions } \description{ Adding progress bar to \code{*apply} functions, possibly leveraging parallel processing. } \usage{ pblapply(X, FUN, ..., cl = NULL) pbapply(X, MARGIN, FUN, ..., cl = NULL) pbsapply(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE, cl = NULL) pbreplicate(n, expr, simplify = "array", cl = NULL) } \arguments{ \item{X}{ For \code{pbsapply} and \code{pblapply}, a vector (atomic or list) or an expressions vector (other objects including classed objects will be coerced by \code{\link{as.list}}.) For \code{pbapply} an array, including a matrix. } \item{MARGIN}{ A vector giving the subscripts which the function will be applied over. \code{1} indicates rows, \code{2} indicates columns, \code{c(1,2)} indicates rows and columns. } \item{FUN}{ The function to be applied to each element of \code{X}: see \code{\link{apply}}, \code{\link{sapply}}, and \code{\link{lapply}}. } \item{\dots}{ Optional arguments to \code{FUN}. } \item{simplify}{ Logical; should the result be simplified to a vector or matrix if possible? } \item{USE.NAMES}{ Logical; if \code{TRUE} and if \code{X} is character, use \code{X} as names for the result unless it had names already. } \item{n}{ Number of replications. } \item{expr}{ Expression (language object, usually a call) to evaluate repeatedly. } \item{cl}{ A cluster object created by \code{\link[parallel]{makeCluster}}, or an integer to indicate number of child-processes (integer values are ignored on Windows) for parallel evaluations. } } \details{ The behaviour of the progress bar is controlled by the option \code{type} in \code{\link{pboptions}}, it can take values \code{c("txt", "win", "tk", "none",)} on Windows, and \code{c("txt", "tk", "none",)} on Unix systems. Other options have elements that are arguments used in the functions \code{\link{timerProgressBar}}, \code{\link[utils]{txtProgressBar}}, #ifdef windows \code{\link[utils]{winProgressBar}}, #endif and \code{\link[tcltk]{tkProgressBar}}. See \code{\link{pboptions}} for how to conveniently set these. Parallel processing can be enabled through the \code{cl} argument. \code{\link[parallel]{parLapply}} is called when \code{cl} is a 'cluster' object, \code{\link[parallel]{mclapply}} is called when \code{cl} is an integer. Showing the progress bar increases the communication overhead between the main process and nodes / child processes compared to the parallel equivalents of the functions without the progress bar. The functions fall back to their original equivalents when the progress bar is disabled (i.e. \code{getOption("pboptions")$type == "none"} or \code{dopb()} is \code{FALSE}). This is the default when \code{interactive()} if \code{FALSE} (i.e. called from command line R script). When doing parallel processing, other objects might need to pushed to the workers, and random numbers must be handled with care (see Examples). } \value{ Similar to the value returned by the standard \code{*apply} functions. A progress bar is showed as a side effect. } \author{ Peter Solymos } \note{ Progress bar can add an overhead to the computation. } \seealso{ Progress bars used in the functions: #ifdef windows \code{\link[utils]{winProgressBar}}, #endif \code{\link[utils]{txtProgressBar}}, \code{\link[tcltk]{tkProgressBar}}, \code{\link{timerProgressBar}} Sequential \code{*apply} functions: \code{\link{apply}}, \code{\link{sapply}}, \code{\link{lapply}}, \code{\link{replicate}} Parallel \code{*apply} functions from package 'parallel': \code{\link[parallel]{parLapply}}, \code{\link[parallel]{mclapply}}. Setting the options: \code{\link{pboptions}} Conveniently add progress bar to \code{for}-like loops: \code{\link{startpb}}, \code{\link{setpb}}, \code{\link{getpb}}, \code{\link{closepb}} } \examples{ ## --- simple linear model simulation --- set.seed(1234) n <- 200 x <- rnorm(n) y <- rnorm(n, crossprod(t(model.matrix(~ x)), c(0, 1)), sd = 0.5) d <- data.frame(y, x) ## model fitting and bootstrap mod <- lm(y ~ x, d) ndat <- model.frame(mod) B <- 100 bid <- sapply(1:B, function(i) sample(nrow(ndat), nrow(ndat), TRUE)) fun <- function(z) { if (missing(z)) z <- sample(nrow(ndat), nrow(ndat), TRUE) coef(lm(mod$call$formula, data=ndat[z,])) } ## standard '*apply' functions system.time(res1 <- lapply(1:B, function(i) fun(bid[,i]))) system.time(res2 <- sapply(1:B, function(i) fun(bid[,i]))) system.time(res3 <- apply(bid, 2, fun)) system.time(res4 <- replicate(B, fun())) ## 'pb*apply' functions ## try different settings: ## "none", "txt", "tk", "win", "timer" op <- pboptions(type = "timer") # default system.time(res1pb <- pblapply(1:B, function(i) fun(bid[,i]))) pboptions(op) pboptions(type = "txt") system.time(res2pb <- pbsapply(1:B, function(i) fun(bid[,i]))) pboptions(op) pboptions(type = "txt", style = 1, char = "=") system.time(res3pb <- pbapply(bid, 2, fun)) pboptions(op) pboptions(type = "txt", char = ":") system.time(res4pb <- pbreplicate(B, fun())) pboptions(op) \dontrun{ ## parallel evaluation using the parallel package ## (n = 2000 and B = 1000 will give visible timing differences) library(parallel) cl <- makeCluster(2L) clusterExport(cl, c("fun", "mod", "ndat", "bid")) ## parallel with no progress bar: snow type cluster ## (RNG is set in the main process to define the object bid) system.time(res1cl <- parLapply(cl = cl, 1:B, function(i) fun(bid[,i]))) system.time(res2cl <- parSapply(cl = cl, 1:B, function(i) fun(bid[,i]))) system.time(res3cl <- parApply(cl, bid, 2, fun)) ## parallel with progress bar: snow type cluster ## (RNG is set in the main process to define the object bid) system.time(res1pbcl <- pblapply(1:B, function(i) fun(bid[,i]), cl = cl)) system.time(res2pbcl <- pbsapply(1:B, function(i) fun(bid[,i]), cl = cl)) ## (RNG needs to be set when not using bid) parallel::clusterSetRNGStream(cl, iseed = 0L) system.time(res4pbcl <- pbreplicate(B, fun(), cl = cl)) system.time(res3pbcl <- pbapply(bid, 2, fun, cl = cl)) stopCluster(cl) if (.Platform$OS.type != "windows") { ## parallel with no progress bar: multicore type forking ## (mc.set.seed = TRUE in parallel::mclapply by default) system.time(res2mc <- mclapply(1:B, function(i) fun(bid[,i]), mc.cores = 2L)) ## parallel with progress bar: multicore type forking ## (mc.set.seed = TRUE in parallel::mclapply by default) system.time(res1pbmc <- pblapply(1:B, function(i) fun(bid[,i]), cl = 2L)) system.time(res2pbmc <- pbsapply(1:B, function(i) fun(bid[,i]), cl = 2L)) system.time(res4pbmc <- pbreplicate(B, fun(), cl = 2L)) } } ## --- Examples taken from standard '*apply' functions --- ## --- sapply, lapply, and replicate --- require(stats); require(graphics) x <- list(a = 1:10, beta = exp(-3:3), logic = c(TRUE,FALSE,FALSE,TRUE)) # compute the list mean for each list element pblapply(x, mean) # median and quartiles for each list element pblapply(x, quantile, probs = 1:3/4) pbsapply(x, quantile) i39 <- sapply(3:9, seq) # list of vectors pbsapply(i39, fivenum) ## sapply(*, "array") -- artificial example (v <- structure(10*(5:8), names = LETTERS[1:4])) f2 <- function(x, y) outer(rep(x, length.out = 3), y) (a2 <- pbsapply(v, f2, y = 2*(1:5), simplify = "array")) hist(pbreplicate(100, mean(rexp(10)))) ## use of replicate() with parameters: foo <- function(x = 1, y = 2) c(x, y) # does not work: bar <- function(n, ...) replicate(n, foo(...)) bar <- function(n, x) pbreplicate(n, foo(x = x)) bar(5, x = 3) ## --- apply --- ## Compute row and column sums for a matrix: x <- cbind(x1 = 3, x2 = c(4:1, 2:5)) dimnames(x)[[1]] <- letters[1:8] pbapply(x, 2, mean, trim = .2) col.sums <- pbapply(x, 2, sum) row.sums <- pbapply(x, 1, sum) rbind(cbind(x, Rtot = row.sums), Ctot = c(col.sums, sum(col.sums))) stopifnot( pbapply(x, 2, is.vector)) ## Sort the columns of a matrix pbapply(x, 2, sort) ## keeping named dimnames names(dimnames(x)) <- c("row", "col") x3 <- array(x, dim = c(dim(x),3), dimnames = c(dimnames(x), list(C = paste0("cop.",1:3)))) identical(x, pbapply( x, 2, identity)) identical(x3, pbapply(x3, 2:3, identity)) ##- function with extra args: cave <- function(x, c1, c2) c(mean(x[c1]), mean(x[c2])) pbapply(x, 1, cave, c1 = "x1", c2 = c("x1","x2")) ma <- matrix(c(1:4, 1, 6:8), nrow = 2) ma pbapply(ma, 1, table) #--> a list of length 2 pbapply(ma, 1, stats::quantile) # 5 x n matrix with rownames stopifnot(dim(ma) == dim(pbapply(ma, 1:2, sum))) ## Example with different lengths for each call z <- array(1:24, dim = 2:4) zseq <- pbapply(z, 1:2, function(x) seq_len(max(x))) zseq ## a 2 x 3 matrix typeof(zseq) ## list dim(zseq) ## 2 3 zseq[1,] pbapply(z, 3, function(x) seq_len(max(x))) # a list without a dim attribute } \keyword{ manip } \keyword{ utilities }