pbapply/0000755000176200001440000000000014120550666011726 5ustar liggesuserspbapply/NAMESPACE0000644000176200001440000000105114120472571013140 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, pbtapply, startpb, setpb, getpb, closepb, dopb, doshiny, pboptions, pbtypes, timerProgressBar, setTimerProgressBar, getTimerProgressBar, splitpb, getTimeAsString, .pb_env) pbapply/man/0000755000176200001440000000000014120472571012477 5ustar liggesuserspbapply/man/pboptions.Rd0000644000176200001440000001264314120472571015011 0ustar liggesusers\name{pboptions} \alias{pboptions} \alias{startpb} \alias{setpb} \alias{getpb} \alias{closepb} \alias{dopb} \alias{doshiny} \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() doshiny() 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}. \code{doshiny} returns a logical value, \code{TRUE} when the shiny package namespace is available (i.e. the suggested package is installed), the \code{type} option is set to \code{"shiny"}, and a shiny application is running. 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.Rd0000644000176200001440000003127614111053541014436 0ustar liggesusers\name{pbapply} \alias{pbapply} \alias{pbsapply} \alias{pblapply} \alias{pbreplicate} \alias{pbmapply} \alias{pbtapply} \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, ..., simplify = TRUE, 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) pbtapply(X, INDEX, FUN = NULL, ..., default = NA, simplify = TRUE, 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. For \code{pbtapply} an R object for which a \code{\link{split}} method exists. Typically vector-like, allowing subsetting with \code{\link{[}}. } \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}}. In the case of functions like \code{+}, \code{\%*\%}, etc., the function name must be backquoted or quoted. If \code{FUN} is \code{NULL}, \code{pbtapply} returns a vector which can be used to subscript the multi-way array \code{pbtapply} normally produces. } \item{\dots}{ Optional arguments to \code{FUN} and also to underlying functions (e.g. \code{\link{parLapply}} and \code{\link{mclapply}} when \code{cl} is not \code{NULL}). } \item{simplify, SIMPLIFY}{ Logical; should the result be simplified to a vector or matrix if possible? \code{pbtapply} returns an array of mode \code{"list"} (in other words, a list with a dim attribute) when \code{FALSE}; if \code{TRUE} (the default), then if \code{FUN} always returns a scalar, \code{pbtapply} returns an array with the mode of the scalar. } \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{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}. } \item{INDEX}{ a \code{\link{list}} of one or more \code{\link{factor}}s, each of same length as \code{X}. The elements are coerced to factors by \code{\link{as.factor}}. } \item{default}{ (only in the case of simplification to an array) the value with which the array is initialized as \code{\link{array}}\code{(default, dim = ..)}. Before R 3.4.0, this was hard coded to \code{\link{array}}\code{()}'s default \code{NA}. If it is \code{NA} (the default), the missing value of the answer type, e.g. \code{\link{NA_real_}}, is chosen (\code{\link{as.raw}}\code{(0)} for \code{"raw"}). In a numerical case, it may be set, e.g., to \code{FUN(integer(0))}, e.g., in the case of \code{FUN = sum} to \code{0} or \code{0L}. } } \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{parLapply}} is called when \code{cl} is a 'cluster' object, \code{\link{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{mclapply}} can be slightly slower compared to using a Fork cluster (i.e. calling \code{\link{makeForkCluster}}). Care must be taken to set appropriate random numbers in this case. Note the \code{use_lb} option (see \code{\link{pboptions}}) for using load balancing when running in parallel clusters. If using \code{\link{mclapply}}, the \code{...} passes arguments to the underlying function for further contol. } \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}}, \code{\link{tapply}} Parallel \code{*apply} functions from package 'parallel': \code{\link{parLapply}}, \code{\link{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)) ## --- tapply --- require(stats) groups <- as.factor(rbinom(32, n = 5, prob = 0.4)) pbtapply(groups, groups, length) #- is almost the same as table(groups) ## contingency table from data.frame : array with named dimnames pbtapply(warpbreaks$breaks, warpbreaks[,-1], sum) pbtapply(warpbreaks$breaks, warpbreaks[, 3, drop = FALSE], sum) n <- 17; fac <- factor(rep_len(1:3, n), levels = 1:5) table(fac) pbtapply(1:n, fac, sum) pbtapply(1:n, fac, sum, default = 0) # maybe more desirable pbtapply(1:n, fac, sum, simplify = FALSE) pbtapply(1:n, fac, range) pbtapply(1:n, fac, quantile) pbtapply(1:n, fac, length) ## NA's pbtapply(1:n, fac, length, default = 0) # == table(fac) ## example of ... argument: find quarterly means pbtapply(presidents, cycle(presidents), mean, na.rm = TRUE) ind <- list(c(1, 2, 2), c("A", "A", "B")) table(ind) pbtapply(1:3, ind) #-> the split vector pbtapply(1:3, ind, sum) ## Some assertions (not held by all patch propsals): nq <- names(quantile(1:5)) stopifnot( identical(pbtapply(1:3, ind), c(1L, 2L, 4L)), identical(pbtapply(1:3, ind, sum), matrix(c(1L, 2L, NA, 3L), 2, dimnames = list(c("1", "2"), c("A", "B")))), identical(pbtapply(1:n, fac, quantile)[-1], array(list(`2` = structure(c(2, 5.75, 9.5, 13.25, 17), .Names = nq), `3` = structure(c(3, 6, 9, 12, 15), .Names = nq), `4` = NULL, `5` = NULL), dim=4, dimnames=list(as.character(2:5))))) } \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/DESCRIPTION0000644000176200001440000000155114120550666013436 0ustar liggesusersPackage: pbapply Type: Package Title: Adding Progress Bar to '*apply' Functions Version: 1.5-0 Date: 2021-09-15 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 Suggests: shiny License: GPL-2 URL: https://github.com/psolymos/pbapply BugReports: https://github.com/psolymos/pbapply/issues NeedsCompilation: no Packaged: 2021-09-15 23:35:27 UTC; Peter Repository: CRAN Date/Publication: 2021-09-16 05:10:14 UTC pbapply/tests/0000755000176200001440000000000013723746454013102 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/0000755000176200001440000000000014120501477012123 5ustar liggesuserspbapply/R/unix/0000755000176200001440000000000014120472571013110 5ustar liggesuserspbapply/R/unix/startpb.R0000644000176200001440000000164214120472571014715 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)) if (doshiny()) pb <- shiny::Progress$new(min=min, max=max) } else { pb <- NULL } invisible(pb) } pbapply/R/unix/getpb.R0000644000176200001440000000056214120472571014337 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)) if (doshiny()) rval <- pb$getValue() } else { rval <- NULL } rval } pbapply/R/unix/setpb.R0000644000176200001440000000107514120472571014353 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)) if (doshiny()) rval <- pb$set(value, message = if (control$title == "") NULL else control$title, detail = if (control$label == "") NULL else control$label) } else { rval <- NULL } invisible(rval) } pbapply/R/pbapply.R0000644000176200001440000001047614111053541013717 0ustar liggesuserspbapply <- function (X, MARGIN, FUN, ..., simplify = TRUE,cl = NULL) { FUN <- match.fun(FUN) simplify <- isTRUE(simplify) 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") } d.call <- d[-MARGIN] d.ans <- d[ MARGIN] if (anyNA(d.call) || anyNA(d.ans)) stop("'MARGIN' does not match dim(X)") s.call <- ds[-MARGIN] s.ans <- ds[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 <- !simplify || 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 } } 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 <- !simplify || 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]] ans } else if (len.a == d2) array(ans, d.ans, dn.ans) else if (len.a && len.a%%d2 == 0L) { if (is.null(dn.ans)) dn.ans <- vector(mode = "list", length(d.ans)) dn1 <- list(ans.names) if (length(dn.call) && !is.null(n1 <- names(dn <- dn.call[1])) && nzchar(n1) && length(ans.names) == length(dn[[1]])) names(dn1) <- n1 dn.ans <- c(dn1, dn.ans) array(ans, c(len.a%/%d2, d.ans), if (!is.null(names(dn.ans)) || !all(vapply(dn.ans, is.null, NA))) dn.ans) } else ans } pbapply/R/pbtypes.R0000644000176200001440000000023314120472571013734 0ustar liggesuserspbtypes <- function() { TYPES <- c("timer", "txt", "tk", "none", "shiny") 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/doshiny.R0000644000176200001440000000021014120472571013716 0ustar liggesusersdoshiny <- function() { getOption("pboptions")$type == "shiny" && requireNamespace("shiny") && shiny::isRunning() } 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.R0000644000176200001440000000030014120472571013670 0ustar liggesusersclosepb <- function(pb) { if (is.null(pb)) { invisible(NULL) } else { if (doshiny()) { pb$close() } else { close(pb) } } } pbapply/R/pbtapply.R0000644000176200001440000000302713676432751014120 0ustar liggesuserspbtapply <- function (X, INDEX, FUN = NULL, ..., default = NA, simplify = TRUE, cl = NULL) # changed here { FUN <- if (!is.null(FUN)) match.fun(FUN) if (!is.list(INDEX)) INDEX <- list(INDEX) INDEX <- lapply(INDEX, as.factor) nI <- length(INDEX) if (!nI) stop("'INDEX' is of length zero") if (!all(lengths(INDEX) == length(X))) stop("arguments must have same length") namelist <- lapply(INDEX, levels) extent <- lengths(namelist, use.names = FALSE) cumextent <- cumprod(extent) if (cumextent[nI] > .Machine$integer.max) stop("total number of levels >= 2^31") storage.mode(cumextent) <- "integer" ngroup <- cumextent[nI] group <- as.integer(INDEX[[1L]]) if (nI > 1L) for (i in 2L:nI) group <- group + cumextent[i - 1L] * (as.integer(INDEX[[i]]) - 1L) if (is.null(FUN)) return(group) levels(group) <- as.character(seq_len(ngroup)) class(group) <- "factor" ans <- split(X, group) names(ans) <- NULL index <- as.logical(lengths(ans)) ans <- pblapply(X = ans[index], FUN = FUN, ..., cl = cl) # changed here ansmat <- array(if (simplify && all(lengths(ans) == 1L)) { ans <- unlist(ans, recursive = FALSE, use.names = FALSE) if (!is.null(ans) && is.na(default) && is.atomic(ans)) vector(typeof(ans)) else default } else vector("list", prod(extent)), dim = extent, dimnames = namelist) if (length(ans)) { ansmat[index] <- ans } ansmat } pbapply/R/windows/0000755000176200001440000000000014120472571013617 5ustar liggesuserspbapply/R/windows/startpb.R0000644000176200001440000000215414120472571015423 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)) if (doshiny()) pb <- shiny::Progress$new(min=min, max=max) } else { pb <- NULL } invisible(pb) } pbapply/R/windows/getpb.R0000644000176200001440000000063314120472571015045 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)) if (doshiny()) rval <- pb$getValue() } else { rval <- NULL } rval } pbapply/R/windows/setpb.R0000644000176200001440000000120414120472571015054 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)) if (doshiny()) rval <- pb$set(value, message = if (control$title == "") NULL else control$title, detail = if (control$label == "") NULL else control$label) } else { rval <- NULL } invisible(rval) } pbapply/MD50000644000176200001440000000243414120550666012241 0ustar liggesusersb2f9600523eaffa2096e4144afdbebd3 *DESCRIPTION a0206f4ae6418ed1ae546fd1b8d24117 *NAMESPACE 433d100654601a1d53f3d1ebe7d03a84 *R/closepb.R 41a4c3404c4c5a5268bd061394f126f4 *R/dopb.R 6871ea5b03b9c44fb88ad30a0571afe5 *R/doshiny.R cc7b918f1d9c40fcddb88541b814219c *R/pbapply.R da0d9c357a7851a5f3ea0d8f98fba4f5 *R/pblapply.R d177ab848f1dc27a6d07ab69ef9b4b61 *R/pbmapply.R 56640b298b3c95255a1dc60302a23fee *R/pboptions.R 85fb7bf9dec3cba585b01fe5c5ff9914 *R/pbreplicate.R d40dc483c2eb8643b6e329da442ff74d *R/pbsapply.R 57a9da7cc343460cc86c716d4108bfd6 *R/pbtapply.R b968cb6437d87e54771d6b48abc5d5fa *R/pbtypes.R f353dd9c023034a3dd7b554481f2cb0b *R/splitpb.R 95ef9ddd43419513066d540cbc743419 *R/timerProgressBar.R c9f3ee366d88ed8ec9c1608a2c6654b2 *R/unix/getpb.R d419bc6af7d90b1ec1cba977a09a05b6 *R/unix/setpb.R 6d49e8eef9a071958187282aa85d1cd5 *R/unix/startpb.R 1669e20014fe66312868df96fde6c1dd *R/windows/getpb.R e7a82f8e68355636ac84e5813e92ce64 *R/windows/setpb.R 24308ce464045d47469f102e35e05724 *R/windows/startpb.R 9becb214351484d70c673190fc52ebea *R/zzz.R 5402abf2ba3ae119e21a4f53265fd898 *man/pbapply.Rd 511be26d56dac0cee0ea2db58925043b *man/pboptions.Rd f032d5b07255b3ca4062e0c06c6136fd *man/splitpb.Rd 0b1cc9b59c2601f9cd96a2cfa1c05f5d *man/timerProgressBar.Rd 5bf6009c5bfc0018b0b921b51e559c4a *tests/tests.R