pbapply/0000755000176200001440000000000013532400452011717 5ustar liggesuserspbapply/NAMESPACE0000644000176200001440000000102213525060414013133 0ustar liggesusersif (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, parLapplyLB) export(pbapply, pbsapply, pblapply, pbreplicate, pbmapply, startpb, setpb, getpb, closepb, dopb, pboptions, pbtypes, timerProgressBar, setTimerProgressBar, getTimerProgressBar, splitpb, getTimeAsString, .pb_env) pbapply/man/0000755000176200001440000000000013513007174012475 5ustar liggesuserspbapply/man/pboptions.Rd0000644000176200001440000001224613225316471015011 0ustar liggesusers\name{pboptions} \alias{pboptions} \alias{startpb} \alias{setpb} \alias{getpb} \alias{closepb} \alias{dopb} \alias{pbtypes} \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() pbtypes() } \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. See \code{pbtypes()} for available progress bar types depending on operating system.} \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.} \item{use_lb}{Switch for using load balancing when running in parallel clusters. The default value is \code{FALSE}.} 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. \code{pbtypes} prints the available progress bar types depending on the operating system (i.e. \code{"win"} available on Windows only). } \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{ ## increase sluggishness to admire the progress bar longer sluggishness <- 0.01 ## for loop fun1 <- function() { pb <- startpb(0, 10) on.exit(closepb(pb)) for (i in 1:10) { Sys.sleep(sluggishness) 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(sluggishness) 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(sluggishness) 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) ## list available pb types pbtypes() } \keyword{ IO } \keyword{ utilities } pbapply/man/pbapply.Rd0000644000176200001440000002301113513007174014430 0ustar liggesusers\name{pbapply} \alias{pbapply} \alias{pbsapply} \alias{pblapply} \alias{pbreplicate} \alias{pbmapply} \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) pbmapply(FUN, ..., MoreArgs = NULL, SIMPLIFY = TRUE, USE.NAMES = TRUE) } \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, 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 (see Details on performance). } \item{MoreArgs}{ a list of other arguments to \code{FUN}. } } \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). Updating the progress bar with \code{\link[parallel]{mclapply}} can be slightly slower compared to using a Fork cluster (i.e. calling \code{\link[parallel]{makeForkCluster}}). Care must be taken to set appropriate random numbers in this case. } \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}}, \code{\link{mapply}} 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 ## --- mapply --- pbmapply(rep, 1:4, 4:1) pbmapply(rep, times = 1:4, x = 4:1) pbmapply(rep, times = 1:4, MoreArgs = list(x = 42)) pbmapply(function(x, y) seq_len(x) + y, c(a = 1, b = 2, c = 3), # names from first c(A = 10, B = 0, C = -10)) word <- function(C, k) paste(rep.int(C, k), collapse = "") utils::str(pbmapply(word, LETTERS[1:6], 6:1, SIMPLIFY = FALSE)) } \keyword{ manip } \keyword{ utilities } pbapply/man/splitpb.Rd0000644000176200001440000000230412765312734014451 0ustar liggesusers\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/timerProgressBar.Rd0000644000176200001440000001230313225303230016245 0ustar liggesusers\name{timerProgressBar} \alias{timerProgressBar} \alias{setTimerProgressBar} \alias{getTimerProgressBar} \alias{getTimeAsString} \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) getTimeAsString(time) } \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. } \item{time}{ numeric of length 1, time in seconds. } } \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. \code{getTimeAsString} converts time in seconds into ~HHh MMm SSs format to be printed by \code{timerProgressBar}. } \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}). \code{getTimeAsString} returns time in ~HHh MMm SSs format as character. Returns \code{"calculating"} when \code{time=NULL}. } \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"] ## time formatting getTimeAsString(NULL) getTimeAsString(15) getTimeAsString(65) getTimeAsString(6005) ## example usage of getTimeAsString, use sluggishness <- 1 n <- 10 t0 <- proc.time()[3] ETA <- NULL for (i in seq_len(n)) { cat(i, "/", n, "- ETA:", getTimeAsString(ETA)) flush.console() Sys.sleep(sluggishness) dt <- proc.time()[3] - t0 cat(" - elapsed:", getTimeAsString(dt), "\n") ETA <- (n - i) * dt / i } } \keyword{ utilities } pbapply/DESCRIPTION0000644000176200001440000000153113532400452013425 0ustar liggesusersPackage: pbapply Type: Package Title: Adding Progress Bar to '*apply' Functions Version: 1.4-2 Date: 2019-08-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. 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: 2019-08-31 02:39:23 UTC; Peter Repository: CRAN Date/Publication: 2019-08-31 05:10:02 UTC pbapply/tests/0000755000176200001440000000000013426373757013104 5ustar liggesuserspbapply/tests/tests.R0000644000176200001440000000616213255561432014363 0ustar liggesusers#devtools::install_github("psolymos/pbapply") ## --- standard examples --- library(pbapply) example(apply) example(lapply) ## run examples without progress bar pboptions(type = "none") example(splitpb, run.dontrun = TRUE) example(timerProgressBar, run.dontrun = TRUE) example(pbapply, run.dontrun = TRUE) example(pboptions, run.dontrun = TRUE) ## run examples with progress bar pboptions(type = "timer") example(splitpb, run.dontrun = TRUE) example(timerProgressBar, run.dontrun = TRUE) example(pbapply, run.dontrun = TRUE) example(pboptions, run.dontrun = TRUE) ## --- test for NULL case in lapply --- l <- list(a = 1, 2, c = -1) f <- function(z) if (z < 0) return(NULL) else return(2 * z) r1 <- lapply(l, f) r2 <- pblapply(l, f) r1 r2 stopifnot(identical(r1, r2)) ## --- timings --- if (FALSE) { #library(plyr) ## from http://ryouready.wordpress.com/2010/01/11/progress-bars-in-r-part-ii-a-wrapper-for-apply-functions/#comment-122 lapply_pb <- function(X, FUN, ...) { env <- environment() pb_Total <- length(X) counter <- 0 pb <- txtProgressBar(min = 0, max = pb_Total, style = 3) wrapper <- function(...){ curVal <- get("counter", envir = env) assign("counter", curVal +1 ,envir = env) setTxtProgressBar(get("pb", envir = env), curVal + 1) FUN(...) } res <- lapply(X, wrapper, ...) close(pb) res } i <- seq_len(100) t1 <- system.time(lapply(i, function(i) Sys.sleep(0.1))) t2 <- system.time(lapply_pb(i, function(i) Sys.sleep(0.1))) #t3 <- system.time(l_ply(i, function(i) Sys.sleep(0.1), .progress="text")) t4 <- system.time(pblapply(i, function(i) Sys.sleep(0.1))) } ## --- knitr related tests --- if (FALSE) { sink("~/repos/pbapply/tests/pb.Rmd") cat("--- title: \"Test pbapply with knitr\" date: \"`r format(Sys.time(), '%B %d, %Y')`\" output: pdf_document --- # Introduction Play nice! ```{r setup} library(knitr) library(pbapply) interactive() getOption(\"knitr.in.progress\") is.null(getOption(\"knitr.in.progress\")) pboptions()$type ``` ```{r chunk} pbsapply(1:100, function(z) {Sys.sleep(0.01); sqrt(z)}) ``` ") sink() #knitr::knit("~/repos/pbapply/tests/pb.Rmd", "~/repos/pbapply/tests/pb.md") unlink("~/repos/pbapply/tests/pb.Rmd") unlink("~/repos/pbapply/tests/pb.md") } ## --- tests for issue #17: single core in cl --- f <- function(i) Sys.sleep(0.1) library(parallel) cl <- makeCluster(1L) pblapply(1:10, f, cl = cl) stopCluster(cl) ## --- tests for issue #33: return empty list for empty vector --- tmp1 <- lapply(character(0), identity) tmp2 <- pblapply(character(0), identity) stopifnot(length(tmp1) == length(tmp2)) stopifnot(identical(tmp1, tmp2)) tmp1 <- sapply(character(0), identity) tmp2 <- pbsapply(character(0), identity) stopifnot(length(tmp1) == length(tmp2)) stopifnot(identical(tmp1, tmp2)) tmp1 <- apply(matrix(numeric(0), 0, 0), 1, identity) tmp2 <- pbapply(matrix(numeric(0), 0, 0), 1, identity) stopifnot(length(tmp1) == length(tmp2)) stopifnot(identical(tmp1, tmp2)) tmp1 <- apply(matrix(numeric(0), 0, 0), 2, identity) tmp2 <- pbapply(matrix(numeric(0), 0, 0), 2, identity) stopifnot(length(tmp1) == length(tmp2)) stopifnot(identical(tmp1, tmp2)) pbapply/R/0000755000176200001440000000000013532356733012134 5ustar liggesuserspbapply/R/unix/0000755000176200001440000000000013074241155013107 5ustar liggesuserspbapply/R/unix/startpb.R0000644000176200001440000000152312775344126014723 0ustar liggesusersstartpb <- 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/getpb.R0000644000176200001440000000047112661525700014337 0ustar liggesusersgetpb <- 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/setpb.R0000644000176200001440000000055512661525700014356 0ustar liggesuserssetpb <- 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.R0000644000176200001440000001015713150146714013722 0ustar liggesuserspbapply <- 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 ## this will handle load balancing as well 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/pbtypes.R0000644000176200001440000000022213142061743013730 0ustar liggesuserspbtypes <- function() { TYPES <- c("timer", "txt", "tk", "none") if (.Platform$OS.type == "windows") c(TYPES, "win") else TYPES } pbapply/R/zzz.R0000644000176200001440000000133713150146714013110 0ustar liggesusers.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, use_lb = FALSE) 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/R/dopb.R0000644000176200001440000000054113142061743013172 0ustar liggesusersdopb <- function() { progress.bar <- getOption("pboptions")$type if (!is.null(progress.bar)) { progress.bar <- match.arg(progress.bar, pbtypes()) if (progress.bar == "none") progress.bar <- NULL if (!is.null(getOption("knitr.in.progress"))) progress.bar <- NULL } !is.null(progress.bar) } pbapply/R/pboptions.R0000644000176200001440000000055512530013625014264 0ustar liggesuserspboptions <- 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/timerProgressBar.R0000644000176200001440000002635613513532314015553 0ustar liggesuserstimerProgressBar <- 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) } else { done <- ceiling(txtWidth * i / n) bb <- strrep(char, done) empty <- strrep(" ", txtWidth - done) bar <- paste(" |", bb, empty, "|", sep = "") cat("\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 = "")) bb <- strrep(char, ceiling(txtWidth * i / n)) bar <- c("|", "/", "-", "\\")[(.counter %% 4) + 1] cat("\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) } else { done <- ceiling(txtWidth * i / n) bb <- strrep(char, done) empty <- strrep(" ", txtWidth - done) bar <- paste(" |", bb, empty, "|", sep = "") cat("\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 = "")) bb <- strrep(char, ceiling(txtWidth * i / n)) bar <- c("|", "/", "-", "\\")[(.counter %% 4) + 1] cat("\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) } else { done <- ceiling(txtWidth * i / n) bb <- strrep(char[2], done) empty <- strrep(char[3], txtWidth - done) bar <- paste(" ", char[1], bb, empty, char[4], sep = "") cat("\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) } else { done <- ceiling(txtWidth * i / n) bb <- strrep(char[2], done) empty <- strrep(char[3], txtWidth - done) bar <- paste(" ", char[1], bb, empty, char[4], sep = "") cat("\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 (length(time) > 1L) stop("length of input must be 1") 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/pblapply.R0000644000176200001440000000512313255105573014077 0ustar liggesuserspblapply <- function (X, FUN, ..., cl = NULL) { FUN <- match.fun(FUN) if (!is.vector(X) || is.object(X)) X <- as.list(X) if (!length(X)) return(lapply(X, FUN, ...)) ## 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")) { ## switch on load balancing if needed PAR_FUN <- if (isTRUE(getOption("pboptions")$use_lb)) parallel::parLapplyLB else parallel::parLapply if (!dopb()) return(PAR_FUN(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(PAR_FUN(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/splitpb.R0000644000176200001440000000056512775344126013743 0ustar liggesuserssplitpb <- 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/pbmapply.R0000644000176200001440000000151313525060455014076 0ustar liggesusers.pb_env <- new.env(parent=emptyenv()) pbmapply <- function(FUN, ..., MoreArgs = NULL, SIMPLIFY = TRUE, USE.NAMES = TRUE) { ## setting up counter in .pb_env .pb_env$FUN <- FUN .pb_env$MAX <- max(sapply(list(...), length)) .pb_env$VALUE <- 0 .pb_env$pb <- startpb(0, .pb_env$MAX) on.exit(closepb(.pb_env$pb), add=TRUE) on.exit(rm(list=ls(envir=.pb_env), envir=.pb_env), add=TRUE) ## setting tracer suppressWarnings(suppressMessages(trace(quote(FUN), exit = quote({ .pb_env <- pbapply::.pb_env .pb_env$VALUE <- .pb_env$VALUE + 1 pbapply::setpb(.pb_env$pb, .pb_env$VALUE) }), where = .pb_env, print = FALSE))) ## piggy back on mapply mapply(.pb_env$FUN, ..., MoreArgs = MoreArgs, SIMPLIFY = SIMPLIFY, USE.NAMES = USE.NAMES) } pbapply/R/pbsapply.R0000644000176200001440000000063212764410600014100 0ustar liggesuserspbsapply <- 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/pbreplicate.R0000644000176200001440000000024512764410600014540 0ustar liggesuserspbreplicate <- function (n, expr, simplify = "array", cl = NULL) pbsapply(integer(n), eval.parent(substitute(function(...) expr)), simplify = simplify, cl = cl) pbapply/R/closepb.R0000644000176200001440000000013112775344126013702 0ustar liggesusersclosepb <- function(pb) { if (is.null(pb)) invisible(NULL) else close(pb) } pbapply/R/windows/0000755000176200001440000000000013074241155013616 5ustar liggesuserspbapply/R/windows/startpb.R0000644000176200001440000000203512775344126015431 0ustar liggesusersstartpb <- 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/getpb.R0000644000176200001440000000054212661525700015045 0ustar liggesusersgetpb <- 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/setpb.R0000644000176200001440000000066412661525700015066 0ustar liggesuserssetpb <- 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/MD50000644000176200001440000000227713532400452012237 0ustar liggesusersbeb27a85755e42d99dbae01c0991cd38 *DESCRIPTION 868cd0e8eb98dcaa7f8798d0cb9714a8 *NAMESPACE c9afd75355061c7922a002ec6ddb33c9 *R/closepb.R 41a4c3404c4c5a5268bd061394f126f4 *R/dopb.R b7c0b0e5a63dedaa08807875be80111e *R/pbapply.R da0d9c357a7851a5f3ea0d8f98fba4f5 *R/pblapply.R d177ab848f1dc27a6d07ab69ef9b4b61 *R/pbmapply.R 56640b298b3c95255a1dc60302a23fee *R/pboptions.R 85fb7bf9dec3cba585b01fe5c5ff9914 *R/pbreplicate.R d40dc483c2eb8643b6e329da442ff74d *R/pbsapply.R 21b0f6a695aec62bfecdb1d5dc84c48d *R/pbtypes.R f353dd9c023034a3dd7b554481f2cb0b *R/splitpb.R 95ef9ddd43419513066d540cbc743419 *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 9becb214351484d70c673190fc52ebea *R/zzz.R c6fda63d55232282681bdb043a49b388 *man/pbapply.Rd ac2ab753708e6cdacb203d4d905cb2e6 *man/pboptions.Rd f032d5b07255b3ca4062e0c06c6136fd *man/splitpb.Rd 0b1cc9b59c2601f9cd96a2cfa1c05f5d *man/timerProgressBar.Rd 5bf6009c5bfc0018b0b921b51e559c4a *tests/tests.R