pbapply/0000755000176200001440000000000014446523552011733 5ustar liggesuserspbapply/NAMESPACE0000644000176200001440000000123314337500774013151 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, pb.mapply, pbtapply, pbwalk, pbeapply, pbvapply, pbby, pbMap, startpb, setpb, getpb, closepb, dopb, doshiny, pboptions, pbtypes, timerProgressBar, setTimerProgressBar, getTimerProgressBar, splitpb, getTimeAsString, .pb_env) S3method("pbby", "default") S3method("pbby", "data.frame") pbapply/man/0000755000176200001440000000000014337500774012506 5ustar liggesuserspbapply/man/pboptions.Rd0000644000176200001440000001267314334320722015011 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"}), none (\code{"none"}), or Shiny (\code{"shiny"}). 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.Rd0000644000176200001440000003726014446503261014447 0ustar liggesusers\name{pbapply} \alias{pbapply} \alias{pbsapply} \alias{pblapply} \alias{pbwalk} \alias{pbreplicate} \alias{pbmapply} \alias{pb.mapply} \alias{pbtapply} \alias{pbeapply} \alias{pbvapply} \alias{pbby} \alias{pbMap} \alias{.pb_env} \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) pbeapply(env, FUN, ..., all.names = FALSE, USE.NAMES = TRUE, cl = NULL) pbwalk(X, FUN, ..., cl = NULL) pbapply(X, MARGIN, FUN, ..., simplify = TRUE, cl = NULL) pbsapply(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE, cl = NULL) pbvapply(X, FUN, FUN.VALUE, ..., USE.NAMES = TRUE, cl = NULL) pbreplicate(n, expr, simplify = "array", cl = NULL) .pb_env pbmapply(FUN, ..., MoreArgs = NULL, SIMPLIFY = TRUE, USE.NAMES = TRUE) pb.mapply(FUN, dots, MoreArgs) pbMap(f, ...) pbtapply(X, INDEX, FUN = NULL, ..., default = NA, simplify = TRUE, cl = NULL) pbby(data, INDICES, FUN, ..., simplify = TRUE, cl = NULL) } \arguments{ \item{X}{ For \code{pbsapply}, \code{pblapply}, and \code{pbwalk} 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, f}{ 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{dots}{ List of arguments to vectorize over (vectors or lists of strictly positive length, or all of zero length); see \code{\link{.mapply}}. } \item{env}{ Environment to be used. } \item{FUN.VALUE}{ A (generalized) vector; a template for the return value from \code{FUN}. See 'Details' for \code{\link{vapply}}. } \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{all.names}{ Logical, indicating whether to apply the function to all values. } \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). It can also be \code{"future"} to use a future backend (see Details), \code{NULL} (default) refers to sequential evaluation. } \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{INDICES}{ A factor or a list of factors, each of length \code{nrow(data)}. } \item{data}{ An R object, normally a data frame, possibly a matrix. } \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 behavior 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 control. \code{pbwalk} is similar to \code{pblapply} but it calls \code{FUN} only for its side-effect and returns the input \code{X} invisibly (this behavior is modeled after `purrr::walk`). Note that when \code{cl = "future"}, you might have to specify the \code{future.seed} argument (passed as part of \code{...}) when using random numbers in parallel. Note also that if your code prints messages or you encounter warnings during execution, the condition messages might cause the progress bar to break up and continue on a new line. } \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{.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) pbwalk(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) pbvapply(i39, fivenum, c(Min. = 0, "1st Qu." = 0, Median = 0, "3rd Qu." = 0, Max. = 0)) ## 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")) a.2 <- pbvapply(v, f2, outer(1:3, 1:5), y = 2*(1:5)) stopifnot(dim(a2) == c(3,5,4), all.equal(a2, a.2), identical(dimnames(a2), list(NULL,NULL,LETTERS[1:4]))) summary(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 and .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)) pb.mapply(rep, dots = list(1:4, 4:1), MoreArgs = list()) pb.mapply(rep, dots = list(times = 1:4, x = 4:1), MoreArgs = list()) pb.mapply(rep, dots = list(times = 1:4), MoreArgs = list(x = 42)) pb.mapply(function(x, y) seq_len(x) + y, dots = list(c(a = 1, b = 2, c = 3), # names from first c(A = 10, B = 0, C = -10)), MoreArgs = list()) ## --- Map --- pbMap(`+`, 1, 1 : 3) ; 1 + 1:3 ## --- eapply --- env <- new.env(hash = FALSE) env$a <- 1:10 env$beta <- exp(-3:3) env$logic <- c(TRUE, FALSE, FALSE, TRUE) pbeapply(env, mean) unlist(pbeapply(env, mean, USE.NAMES = FALSE)) pbeapply(env, quantile, probs = 1:3/4) pbeapply(env, quantile) ## --- 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))))) ## --- by --- pbby(warpbreaks[, 1:2], warpbreaks[,"tension"], summary) pbby(warpbreaks[, 1], warpbreaks[, -1], summary) pbby(warpbreaks, warpbreaks[,"tension"], function(x) lm(breaks ~ wool, data = x)) tmp <- with(warpbreaks, pbby(warpbreaks, tension, function(x) lm(breaks ~ wool, data = x))) sapply(tmp, coef) } \keyword{ manip } \keyword{ utilities } pbapply/man/splitpb.Rd0000644000176200001440000000230414334320722014437 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.Rd0000644000176200001440000001230314334320722016254 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/DESCRIPTION0000644000176200001440000000301714446523552013442 0ustar liggesusersPackage: pbapply Type: Package Title: Adding Progress Bar to '*apply' Functions Version: 1.7-2 Date: 2023-06-27 Authors@R: c(person(given = "Peter", family = "Solymos", comment = c(ORCID = "0000-0001-7337-1740"), role = c("aut", "cre"), email = "psolymos@gmail.com"), person(given = "Zygmunt", family = "Zawadzki", role = "aut", email = "zygmunt@zstat.pl"), person(given = "Henrik", family = "Bengtsson", role = "ctb", email = "henrikb@braju.com"), person("R Core Team", role = c("cph", "ctb"))) 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 including future. Depends: R (>= 3.2.0) Imports: parallel Suggests: shiny, future, future.apply License: GPL (>= 2) URL: https://github.com/psolymos/pbapply BugReports: https://github.com/psolymos/pbapply/issues NeedsCompilation: no Packaged: 2023-06-27 07:08:27 UTC; Peter Author: Peter Solymos [aut, cre] (), Zygmunt Zawadzki [aut], Henrik Bengtsson [ctb], R Core Team [cph, ctb] Repository: CRAN Date/Publication: 2023-06-27 09:10:02 UTC pbapply/tests/0000755000176200001440000000000014337500774013075 5ustar liggesuserspbapply/tests/tests.R0000644000176200001440000001472014337500774014366 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) ## check potential changes in formal arguments check_args <- function(fun1, fun2, cl=TRUE) { f1 <- formals(fun1) f2 <- formals(fun2) args1 <- names(f1) args2cl <- names(f2) args2 <- if (cl) args2cl[seq_len(length(args2cl)-1L)] else args2cl vals1 <- unname(f1) vals2cl <- unname(f2) vals2 <- if (cl) vals2cl[seq_len(length(vals2cl)-1L)] else vals2cl if (length(args1) != length(args2)) { msg <- c("Number of arguments is different:\n - fun1 [", length(args1), "]: ", paste0(args1, collapse=", "), "\n - fun2 [", length(args2), "]: ", paste0(args2, collapse=", ")) stop(paste0(msg, collapse="")) } if (!all(args1 == args2)) { msg <- c("Argument mismatches:\n - in fun1 but not fun2: ", paste0(setdiff(args1, args2), collapse=", "), "\n - in fun2 but not fun1: ", paste0(setdiff(args2, args1), collapse=", ")) stop(paste0(msg, collapse="")) } if (!all(sapply(1:length(vals1),function(i) identical(vals1[[i]], vals2[[i]])))) { msg <- c("Number of arguments is different:\n - fun1: ", paste0(vals1, collapse=", "), "\n - fun2: ", paste0(vals2, collapse=", ")) stop(paste0(msg, collapse="")) } invisible(TRUE) } check_args(lapply, pblapply) check_args(lapply, pbwalk) check_args(apply, pbapply) check_args(sapply, pbsapply) check_args(replicate, pbreplicate) check_args(tapply, pbtapply) check_args(eapply, pbeapply) check_args(vapply, pbvapply) check_args(by, pbby) check_args(mapply, pbmapply, cl=FALSE) check_args(Map, pbMap, cl=FALSE) check_args(.mapply, pb.mapply, cl=FALSE) ## --- 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)) ## --- tests for issue #48: pbwalk --- tmp <- tempdir() # f <- function(i, dir) { # x <- rnorm(100) # png(file.path(dir, paste0("plot-", i, ".png"))) # hist(x, col=i) # dev.off() # x # } f <- function(i, dir) { x <- data.frame(i=i, j=rnorm(5)) write.csv(x, row.names=FALSE, file=file.path(dir, paste0("file-", i, ".csv"))) x } # pblapply(1:3, f, dir=tmp) pbwalk(1:3, f, dir=tmp) # unlink(file.path(tmp, paste0("plot-", 1:3, ".png"))) unlink(file.path(tmp, paste0("file-", 1:3, ".csv"))) pbwalk(1:3, f, dir=tmp, cl=2) # unlink(file.path(tmp, paste0("plot-", 1:3, ".png"))) unlink(file.path(tmp, paste0("file-", 1:3, ".csv"))) cl <- parallel::makeCluster(2) pbwalk(1:3, f, dir=tmp, cl=cl) parallel::stopCluster(cl) # unlink(file.path(tmp, paste0("plot-", 1:3, ".png"))) unlink(file.path(tmp, paste0("file-", 1:3, ".csv"))) ## this could be a quartz issue ... # f <- function(i, dir) { # x <- rnorm(100) # png(file.path(dir, paste0("plot-", i, ".png"))) # hist(x, col=i) # dev.off() # x # } ## all this works # f(1, tmp) # pbapply::pblapply(1:3, f, dir=tmp) # pbapply::pbwalk(1:3, f, dir=tmp) # unlink(file.path(tmp, paste0("plot-", 1:3, ".png"))) ## all this does not # pbapply::pbwalk(1:3, f, dir=tmp, cl=2) # parallel::mclapply(1:3, f, dir=tmp, mc.cores=2) library(future) l <- list(a = 1, 2, c = -1) f <- function(z) { Sys.sleep(0.1) if (z < 0) return(NULL) else return(2 * z) } plan(sequential) r2 <- pblapply(l, f, cl = "future") plan(multisession, workers = 2) r2 <- pblapply(l, f, cl = "future") cl <- parallel::makeCluster(2) plan(cluster, workers = cl) r2 <- pblapply(l, f, cl = "future") parallel::stopCluster(cl) plan(sequential) pbapply/R/0000755000176200001440000000000014446505353012133 5ustar liggesuserspbapply/R/unix/0000755000176200001440000000000014334320722013105 5ustar liggesuserspbapply/R/unix/startpb.R0000644000176200001440000000164214334320722014712 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.R0000644000176200001440000000056214334320722014334 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.R0000644000176200001440000000107514334320722014350 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.R0000644000176200001440000001644214356472677013750 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) ## pbapply specific part begins 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 <- pblapply(X = arglist, FUN = FUN, ..., cl = cl) ## pbapply specific part ends 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 } 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 } ## this implementation takes base::apply code as is, but sequential is slooow .pbapply_old <- 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.R0000644000176200001440000000023314334320722013731 0ustar liggesuserspbtypes <- function() { TYPES <- c("timer", "txt", "tk", "none", "shiny") if (.Platform$OS.type == "windows") c(TYPES, "win") else TYPES } pbapply/R/zzz.R0000644000176200001440000000133714334320722013106 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/pbwalk.R0000644000176200001440000000611114334320722013524 0ustar liggesuserspbwalk <- function (X, FUN, ..., cl = NULL) { FUN <- match.fun(FUN) ## wrapper function FUN2 <- function(...) { FUN(...) invisible(NULL) } ## call for side effects only pblapply(X, FUN2, ..., cl = cl) ## output is same as input (for chaining) invisible(X) } # pbwalk <- # function (X, FUN, ..., cl = NULL) # { # FUN <- match.fun(FUN) # FUN2 <- function(...) { # FUN(...) # invisible(NULL) # } # if (!is.vector(X) || is.object(X)) # X <- as.list(X) # if (!length(X)) # return(lapply(X, FUN2, ...)) # ## 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, FUN2, ...)) # 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]]], FUN2, ...)) # 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, FUN2, ...)) # ## 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]]], FUN2, ...)) # setpb(pb, i) # } # ## multicore type forking # } else { # if (!dopb()) # return(parallel::mclapply(X, FUN2, ..., 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]]], FUN2, ..., # mc.cores = as.integer(cl))) # setpb(pb, i) # } # } # } # ## output is same as input (for chaining) # invisible(X) # } pbapply/R/pbby.R0000644000176200001440000000254414337500774013220 0ustar liggesusers# adapted from base::by pbby <- function(data, INDICES, FUN, ..., simplify = TRUE, cl = NULL) { UseMethod("pbby") } pbby.data.frame <- function(data, INDICES, FUN, ..., simplify = TRUE, cl = NULL) { if (!is.list(INDICES)) { IND <- list(INDICES) names(IND) <- deparse(substitute(INDICES))[1L] } else { IND <- INDICES } FUNx <- function(x) FUN(data[x, , drop = FALSE], ...) nd <- nrow(data) structure( eval( substitute( pbtapply(seq_len(nd), IND, FUNx, simplify = simplify, cl = cl) ), data), call = match.call(), class = "by") } pbby.default <- function (data, INDICES, FUN, ..., simplify = TRUE, cl = NULL) { dd <- as.data.frame(data) if (length(dim(data))) { pbby(dd, INDICES, FUN, ..., simplify = simplify) } else { if (!is.list(INDICES)) { IND <- list(INDICES) names(IND) <- deparse(substitute(INDICES))[1L] } else { IND <- INDICES } FUNx <- function(x) FUN(dd[x, ], ...) nd <- nrow(dd) structure( eval( substitute( pbtapply(seq_len(nd), IND, FUNx, simplify = simplify, cl = cl) ), dd), call = match.call(), class = "by") } } pbapply/R/dopb.R0000644000176200001440000000054114334320722013171 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.R0000644000176200001440000000055514340715071014271 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.R0000644000176200001440000002635614340715071015555 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.R0000644000176200001440000000763014432724004014076 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 (identical(cl, "future")) { ## we let future to figure out the future plan ## deal with future's absence and set cl to NULL if (!requireNamespace("future") || !requireNamespace("future.apply")) { warning("You need some packages for cl='future' to work: install.packages('future.apply')") cl <- NULL } } else { ## catch windows & single node when NOT using future 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) } ## future backend } else if (identical(cl, "future")) { requireNamespace("future") requireNamespace("future.apply") if (!dopb()) return(future.apply::future_lapply(X, FUN, ..., future.stdout = FALSE)) Split <- splitpb(length(X), future::nbrOfWorkers(), 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(future.apply::future_lapply(X[Split[[i]]], FUN, ..., future.stdout = FALSE)) setpb(pb, i) } ## multicore type forking } else { if (!dopb()) return(parallel::mclapply(X, FUN, ..., mc.cores = as.integer(cl), mc.silent = TRUE)) ## 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), mc.silent = TRUE)) setpb(pb, i) } } } ## assemble output list rval <- do.call(c, rval, quote = TRUE) names(rval) <- names(X) rval } pbapply/R/doshiny.R0000644000176200001440000000021014334320722013713 0ustar liggesusersdoshiny <- function() { getOption("pboptions")$type == "shiny" && requireNamespace("shiny") && shiny::isRunning() } pbapply/R/splitpb.R0000644000176200001440000000056514340715071013732 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.R0000644000176200001440000000317414337500774014110 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) } pb.mapply <- function(FUN, dots, MoreArgs) { ## setting up counter in .pb_env .pb_env$FUN <- FUN .pb_env$MAX <- max(sapply(dots, 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, dots = dots, MoreArgs = MoreArgs) } pbMap <- function (f, ...) { f <- match.fun(f) pbmapply(FUN = f, ..., SIMPLIFY = FALSE) } pbapply/R/pbsapply.R0000644000176200001440000000063214334320722014100 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.R0000644000176200001440000000024514334320722014540 0ustar liggesuserspbreplicate <- function (n, expr, simplify = "array", cl = NULL) pbsapply(integer(n), eval.parent(substitute(function(...) expr)), simplify = simplify, cl = cl) pbapply/R/pbeapply.R0000644000176200001440000000056414337500774014100 0ustar liggesuserspbeapply <- function(env, FUN, ..., all.names = FALSE, USE.NAMES = TRUE, cl = NULL) { FUN <- match.fun(FUN) # adapted from future.apply::future_eapply names <- ls(envir = env, all.names = all.names, sorted = FALSE) X <- mget(names, envir = env, inherits = FALSE) if (!USE.NAMES) names(X) <- NULL pblapply(X = X, FUN = FUN, ..., cl = cl) } pbapply/R/closepb.R0000644000176200001440000000030014334320722013665 0ustar liggesusersclosepb <- function(pb) { if (is.null(pb)) { invisible(NULL) } else { if (doshiny()) { pb$close() } else { close(pb) } } } pbapply/R/pbtapply.R0000644000176200001440000000302714334320722014102 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/pbvapply.R0000644000176200001440000000562114337500774014120 0ustar liggesuserspbvapply <- function(X, FUN, FUN.VALUE, ..., USE.NAMES = TRUE, cl = NULL) { FUN <- match.fun(FUN) if (!is.vector(X) || is.object(X)) X <- as.list(X) # adapted from future.apply::future_vapply n <- length(X) if(!is.function(FUN)) stop("FUN must be a function") if(!(is.vector(FUN.VALUE) || is.array(FUN.VALUE))) stop("FUN.VALUE must be a vector or an array") type <- typeof(FUN.VALUE) times <- length(FUN.VALUE) dim <- dim(FUN.VALUE) if(!(is.logical(USE.NAMES) && length(USE.NAMES) == 1L && !is.na(USE.NAMES))) stop("USE.NAMES must be TRUE/FALSE") valid_types <- switch(type, logical = "logical", integer = c("logical", "integer"), double = c("logical", "integer", "double"), complex = c("logical", "integer", "double", "complex"), type) x_FUN <- FUN res <- pblapply(X, FUN = function(x, ...) { value <- x_FUN(x, ...) if (length(value) != times) { stop(sprintf("values must be length %d, but FUN(X[[ii]]) result is length %d", times, length(value))) } if (!all(dim(value) == dim)) stop("Dimensions are wrong") if (!(typeof(value) %in% valid_types)) stop("Types are not valid") value }, ..., cl = cl) if (!is.null(dim)) { dim_res <- c(dim, n) } else if (times != 1L) { dim_res <- c(times, n) } else { dim_res <- NULL } if (USE.NAMES && length(res) > 0L) { if (is.null(dim)) { names_FUN.VALUE <- names(FUN.VALUE) if (is.null(names_FUN.VALUE)) names_FUN.VALUE <- names(res[[1]]) } else { names_FUN.VALUE <- dimnames(FUN.VALUE) if (is.null(names_FUN.VALUE)) names_FUN.VALUE <- dimnames(res[[1]]) } } res <- unlist(res, use.names = FALSE) if (is.null(res)) res <- vector(mode = type, length = 0L) if (!is.null(dim_res)) dim(res) <- dim_res if (USE.NAMES) { if (is.array(res)) { n_dim <- length(dim(res)) dimnames <- vector("list", length = n_dim) if (is.null(dim)) { names <- names(X) if (!is.null(names)) dimnames[[2]] <- names names <- names_FUN.VALUE if (!is.null(names)) dimnames[[1]] <- names } else { names <- names(X) if (!is.null(names)) dimnames[[n_dim]] <- names names <- names_FUN.VALUE if (!is.null(names)) dimnames[-n_dim] <- names } if (!all(unlist(lapply(dimnames, FUN = is.null), use.names = FALSE))) { dimnames(res) <- dimnames } } else { names(res) <- names(X) } } res } pbapply/R/windows/0000755000176200001440000000000014334320722013614 5ustar liggesuserspbapply/R/windows/startpb.R0000644000176200001440000000215414334320722015420 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.R0000644000176200001440000000063314334320722015042 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.R0000644000176200001440000000120414334320722015051 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/NEWS.md0000644000176200001440000001223114446505137013027 0ustar liggesusers# Version 1.7-2, June 27, 2023 * Documented `.pb_env` environment to address WARNING after CRAN submission. # Version 1.7-1, June 26, 2023 * Future backend not working on Windows (#63), implemented fix similar to PR #64. # Version 1.7-0, Jan 12, 2023 * New functions: `pbeapply`, `pbvapply`, `pbby`, `pbMap` (#50, #51, #52, #53). * Added support for future backends (#54), and the future and future.apply packages are now Suggested. * Henrik Bengtsson (@HenrikBengtsson) and R Core Team added as contributors. * `NEWS.md` file is not excluded from package tarball (#58). * `pbapply` performance issue (#62) addressed. * License for the package is now GPL (>=2) (#61). # Version 1.6-0, Nov 13, 2022 * New function `pbwalk` that can be called for side-effects (#48). # Version 1.5-0, Sept 15, 2021 * New progress bar type `"shiny"` to show the progress bar in the Shiny UI. * Following R changes to `apply`, fixing dimnames issue (#44). # Version 1.4-3, August 11, 2020 * Following R 3.6.2 changes to `apply` (#41). * Adding `pbtapply` (#21). # Version 1.4-2, August 30, 2019 * Fixed environment issue inside the tracer in `pbmapply` in non-interactive session (issue #39). This came up in a package suggesting pbapply, reported by @Nowosad. # Version 1.4-1, July 14, 2019 * Use `base::strrep` instead of `paste(rep(), collapse='')` in `timerProgressBar`. * Fixed space printing glitch (due to rounding), causing issue #37. # Version 1.4-0, February 5, 2019 * `pblapply` returns empty list for empty vector consistent with `lapply` behavior (#33 by @kendonB); tests also added. * `pbmapply` function added (#29) without parallel option. # Version 1.3-4, January 9, 2018 * New function `pbtypes()` to print available pb types depending on OS. * `getTimeAsString` is now exported, with description and examples. * New `pboption` `use_lb` to switch on load balancing for parallel clusters, `FALSE` by default (feature request #28). # Version 1.3-3, July 3, 2017 * Bar did not show up at start. This could happen if it was waiting to calculate total time to compare it to `min_time` option. Bar is shown right away if `min_time=0` (issue #18). * `pbapply` gained `cl` argument to be consistent with other parallelized functions with progress bar (issue #24). # Version 1.3-2, February 28, 2017 * `timerProgressBar` makes sure `char` argument is not empty (`""` is replaced by the default `"="`). * Progress bar is only shown when `interactive() && is.null(getOption("knitr.in.progress"))` to avoid printing progress bar during interactive knitr rendering (request #15 from Sergio Oller). * Bugfix: functions failed with single cluster `cl` argument (issue #17). # Version 1.3-1, October 30, 2016 * `timerProgressBar` gained 2 new styles with flexible styling including left/right end and elapsed/remaining components of the progress bar. * `timerProgressBar` gained `min_time` argument for minimum processing time (in seconds) that is required to show a progress bar. The global `min_time` can be set via `pboptions`. # Version 1.3-0, September 25, 2016 * Progress bar is added for parallel (cluster and forking) jobs (request #9 from Kendon Bell). Package parallel is now imported as a result. * `timerProgressBar` prints days when job is expected to be >24h (PR #11 from Phil Chalmers). # Version 1.2-2, August 25, 2016 * Stylistic changes in printed messages. * Default pb type is `'none'` when `!interactive()`. # Version 1.2-1, March 2, 2016 * Double tilde `~` in `timerProgressBar` cleaned up (`~~calculating`). * `timerProgressBar` gained 4 styles as documented on the help page. Showing elapsed and remaining time, throbber and bar formats. # Version 1.2-0, Feb 29, 2016 * New function: `timerProgressBar` written by Zygmunt Zawadzki. * Zygmunt added as package author. # Version 1.1-3, Nov 24, 2015 * R (>= 3.2.0) dependency added because check failed on R-oldrelease (R-3.1.3) with error `'could not find function "forceAndCall"'` that was part of the `apply` function source code. Reported by Uwe Ligges. # Version 1.1-2, Nov 21, 2015 * Using on.exit and invisible(`NULL`) in examples. * `pblapply` did not return `NULL` values, reported by J. Barrett, now fixed. * `pblapply` did not return list names, now fixed. * `pbapply`, `pbsapply`, `pbreplicate`: code follows base original. * Examples updated to follow base R examples. * Rd file updated to to match code changes. # Version 1.1-1, Feb 3, 2014 * pblapply did not pass `...` when not in interactive mode. Bug reported by R. D. Morey (U Groningen). # Version 1.1-0, Sept 25, 2013 * Removed `:::` to satisfy R 3.0.2 checks. # Version 1.0-5, July 6, 2012 * `inst/COPYING` removed. * `.Internal` call removed from `pblapply`. # Version 1.0-4, September 8, 2011 * `.onLoad` added to `zzz.R` * Help files a bit reworked. # Version 1.0-3, September 9, 2010 * `pboptions.Rd` modified: pb type values added. # Version 1.0-2, September 4, 2010 * `pboptions` function reworked. * Functions simplified. # Version 1.0-1, September 3, 2010 * `pbreplicate` added. * `/tests` directory created. * `R CMD check` failed on unix systems: `/man` and `/R` directories reworked. # Version 1.0-0, September 2, 2010 * First release. pbapply/MD50000644000176200001440000000305414446523552012245 0ustar liggesusers5e675a912167a64898c981e1bc6fa493 *DESCRIPTION f48d9a6721a18a82c2b686fd3ce5f00e *NAMESPACE 2cd2eae2f8420c25eba98ac618c54716 *NEWS.md 433d100654601a1d53f3d1ebe7d03a84 *R/closepb.R 41a4c3404c4c5a5268bd061394f126f4 *R/dopb.R 6871ea5b03b9c44fb88ad30a0571afe5 *R/doshiny.R 1fc3c173222884b86fca6dab59b7032c *R/pbapply.R 3fa977e6dd2d692aa8e23177fa534543 *R/pbby.R 476a1aac11680fcf52c7013a2bbe252a *R/pbeapply.R 76b152331ed562c396b6f9d4aedefea8 *R/pblapply.R 55009f89c333af73f4ce0f3b8501928f *R/pbmapply.R 56640b298b3c95255a1dc60302a23fee *R/pboptions.R 85fb7bf9dec3cba585b01fe5c5ff9914 *R/pbreplicate.R d40dc483c2eb8643b6e329da442ff74d *R/pbsapply.R 57a9da7cc343460cc86c716d4108bfd6 *R/pbtapply.R b968cb6437d87e54771d6b48abc5d5fa *R/pbtypes.R 868ab3f43e9ad6e787267d96a7ca661d *R/pbvapply.R b86ca53a4f18eb4caccafcf229ed775c *R/pbwalk.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 15b310a8294963b6abb601d92998d8a2 *inst/WORDLIST 694ce7d545c7beb99f9cb8ce824ad345 *man/pbapply.Rd dcd875a0ccf284ed8fd482e234c81c3b *man/pboptions.Rd f032d5b07255b3ca4062e0c06c6136fd *man/splitpb.Rd 0b1cc9b59c2601f9cd96a2cfa1c05f5d *man/timerProgressBar.Rd 9e18725fc0670f720a3fac64e9c849c5 *tests/tests.R pbapply/inst/0000755000176200001440000000000014433020425012673 5ustar liggesuserspbapply/inst/WORDLIST0000644000176200001440000000031014357733712014076 0ustar liggesusersBugfix Grolemund's Groningen HHh Kendon Ligges MMm Morey Oller RStudio SSs TclTk UI Uwe gmail knitr oldrelease pb pblapply purrr roxygen solymos throbber ualberta vectorize vectorized zawadzkizygmunt