pbapply/0000755000175100001440000000000013005565504011742 5ustar hornikuserspbapply/NAMESPACE0000644000175100001440000000072413005516275013165 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/0000755000175100001440000000000013005516275012144 5ustar hornikuserspbapply/R/pbreplicate.R0000644000175100001440000000024513005516275014562 0ustar hornikuserspbreplicate <- function (n, expr, simplify = "array", cl = NULL) pbsapply(integer(n), eval.parent(substitute(function(...) expr)), simplify = simplify, cl = cl) pbapply/R/splitpb.R0000644000175100001440000000056513005516275013752 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.R0000644000175100001440000002623113005516275015565 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 .showpb <- FALSE getVal <- function() .i 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/0000755000175100001440000000000013005516275013636 5ustar hornikuserspbapply/R/windows/dopb.R0000644000175100001440000000046413005516275014711 0ustar hornikusersdopb <- function() { progress.bar <- getOption("pboptions")$type if (!is.null(progress.bar)) { progress.bar <- match.arg(progress.bar, c("timer", "txt", "win", "tk", "none")) if (progress.bar == "none") progress.bar <- NULL } !is.null(progress.bar) } pbapply/R/windows/getpb.R0000644000175100001440000000054213005516275015063 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.R0000644000175100001440000000203513005516275015440 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.R0000644000175100001440000000066413005516275015104 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/0000755000175100001440000000000013005516275013127 5ustar hornikuserspbapply/R/unix/dopb.R0000644000175100001440000000045513005516275014202 0ustar hornikusersdopb <- function() { progress.bar <- getOption("pboptions")$type if (!is.null(progress.bar)) { progress.bar <- match.arg(progress.bar, c("timer", "txt", "tk", "none")) if (progress.bar == "none") progress.bar <- NULL } !is.null(progress.bar) } pbapply/R/unix/getpb.R0000644000175100001440000000047113005516275014355 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.R0000644000175100001440000000152313005516275014732 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.R0000644000175100001440000000055513005516275014374 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.R0000644000175100001440000000573713005516275013752 0ustar hornikuserspbapply <- function (X, MARGIN, FUN, ...) { 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) 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 } 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.R0000644000175100001440000000055513005516275014311 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.R0000644000175100001440000000063213005516275014122 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.R0000644000175100001440000000443213005516275014115 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 (inherits(cl, "cluster") && length(cl) < 2L) cl <- NULL if (!inherits(cl, "cluster") && cl < 2) cl <- NULL if (!inherits(cl, "cluster") && .Platform$OS.type == "windows") 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.R0000644000175100001440000000013113005516275013711 0ustar hornikusersclosepb <- function(pb) { if (is.null(pb)) invisible(NULL) else close(pb) } pbapply/R/zzz.R0000644000175100001440000000130713005516275013125 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/MD50000644000175100001440000000215213005565504012252 0ustar hornikusersef36f9ff6e20de5bbca998a0a4254c21 *DESCRIPTION fe00b090c7e865872b8643fd9d8ff621 *NAMESPACE c9afd75355061c7922a002ec6ddb33c9 *R/closepb.R 8ee9c58d8c3128791a5631d8197bbf94 *R/pbapply.R 55817ee443c99bdf263d86364de6af9e *R/pblapply.R 56640b298b3c95255a1dc60302a23fee *R/pboptions.R 85fb7bf9dec3cba585b01fe5c5ff9914 *R/pbreplicate.R d40dc483c2eb8643b6e329da442ff74d *R/pbsapply.R f353dd9c023034a3dd7b554481f2cb0b *R/splitpb.R 7013cc42f3d3aaaa1bb90a721c363f6f *R/timerProgressBar.R 3613eb69cfe2d3f92462dfc7184067fd *R/unix/dopb.R 2a9e06eaae38c714caef04394e528f4f *R/unix/getpb.R d7ade2ac6cca19205c48196f676b4c2d *R/unix/setpb.R abbfcb9ec095f9e6a1a5066a1b463549 *R/unix/startpb.R 71301142c5e1d161737f508ab41f2444 *R/windows/dopb.R 5efeb944a3107a583c0f9bd13632d7dc *R/windows/getpb.R 311c277daa16a7d14792f97178cf34e9 *R/windows/setpb.R 6709ac3060b2a1167e16e51124ed31b7 *R/windows/startpb.R 08953ef66f94e65f7263665337682cbc *R/zzz.R a49ccf3c9af3ad53199034a41875a4b4 *man/pbapply.Rd 1c08f0bfe6a10e33c11624ec8b0ca3a0 *man/pboptions.Rd f032d5b07255b3ca4062e0c06c6136fd *man/splitpb.Rd 97eceee05baa3f9d45d0695a8129b79e *man/timerProgressBar.Rd pbapply/DESCRIPTION0000644000175100001440000000153213005565504013451 0ustar hornikusersPackage: pbapply Type: Package Title: Adding Progress Bar to '*apply' Functions Version: 1.3-1 Date: 2016-10-30 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. Functions can exploit parallel processing resources. 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: 2016-10-31 01:22:05 UTC; root Repository: CRAN Date/Publication: 2016-10-31 07:57:08 pbapply/man/0000755000175100001440000000000013005516275012516 5ustar hornikuserspbapply/man/timerProgressBar.Rd0000644000175100001440000001041213005516275016275 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{ test_fun <- function(...) { pb <- timerProgressBar(...) on.exit(close(pb)) for(i in seq(0, 1, 0.05)) { Sys.sleep(0.05) 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) ## 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.Rd0000644000175100001440000000230413005516275014461 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.Rd0000644000175100001440000001047213005516275015026 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("pbapply.pb")} (\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("pbapply.pb")}. 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() } \keyword{ IO } \keyword{ utilities } pbapply/man/pbapply.Rd0000644000175100001440000002106213005516275014455 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, ...) 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}} 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]))) ## 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)) 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 }