[r-cran-pbapply] 01/01: New upstream version 1.3-1
Andreas Tille
tille at debian.org
Wed Nov 9 16:35:35 UTC 2016
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to annotated tag upstream/1.3-1
in repository r-cran-pbapply.
commit 1d5e91afcc7507a0dbeb8313b9dd4a2b409f6148
Author: Andreas Tille <tille at debian.org>
Date: Wed Nov 9 17:25:41 2016 +0100
New upstream version 1.3-1
---
DESCRIPTION | 20 ++-
MD5 | 44 ++---
NAMESPACE | 18 +-
R/closepb.R | 12 +-
R/pbapply.R | 198 ++++++++++-----------
R/pblapply.R | 86 +++++++--
R/pboptions.R | 32 ++--
R/pbreplicate.R | 8 +-
R/pbsapply.R | 22 +--
R/splitpb.R | 16 ++
R/timerProgressBar.R | 304 +++++++++++++++++++++++++++++++
R/unix/dopb.R | 25 +--
R/unix/getpb.R | 27 +--
R/unix/setpb.R | 27 +--
R/unix/startpb.R | 37 ++--
R/windows/dopb.R | 25 +--
R/windows/getpb.R | 29 +--
R/windows/setpb.R | 29 +--
R/windows/startpb.R | 43 +++--
R/zzz.R | 41 +++--
inst/ChangeLog | 58 ------
man/pbapply.Rd | 463 ++++++++++++++++++++++++++++--------------------
man/pboptions.Rd | 286 ++++++++++++++++--------------
man/splitpb.Rd | 49 +++++
man/timerProgressBar.Rd | 125 +++++++++++++
tests/tests.R | 41 -----
26 files changed, 1330 insertions(+), 735 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index a61e41f..022039b 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,20 +1,24 @@
Package: pbapply
Type: Package
Title: Adding Progress Bar to '*apply' Functions
-Version: 1.1-3
-Date: 2015-10-24
-Author: Peter Solymos
+Version: 1.3-1
+Date: 2016-10-30
+Author: Peter Solymos [aut, cre], Zygmunt Zawadzki [aut]
Maintainer: Peter Solymos <solymos at ualberta.ca>
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 for the user (e.g. bootstrap).
+ to functions where showing the progress is
+ useful (e.g. bootstrap). The type and style of the
+ progress bar (with percentages or remaining time)
+ can be set through options.
+ Functions can exploit parallel processing resources.
Depends: R (>= 3.2.0)
+Imports: parallel
License: GPL-2
URL: https://github.com/psolymos/pbapply
-LazyLoad: yes
+BugReports: https://github.com/psolymos/pbapply/issues
NeedsCompilation: no
-Packaged: 2015-11-24 21:31:30 UTC; Peter
+Packaged: 2016-10-31 01:22:05 UTC; root
Repository: CRAN
-Date/Publication: 2015-11-24 23:59:18
+Date/Publication: 2016-10-31 07:57:08
diff --git a/MD5 b/MD5
index 1b8b0d1..d085a5c 100644
--- a/MD5
+++ b/MD5
@@ -1,21 +1,23 @@
-badf18455877103e846b35d478ee82cd *DESCRIPTION
-0e4fec8b5e37ccc7d06d4203b3acc231 *NAMESPACE
-178d8a843fd01f8e5968a2040e40ed51 *R/closepb.R
-394b77aae0a3e0f6e6c14a349b1ab175 *R/pbapply.R
-9d26834a07284c218a07a37ac866b3ff *R/pblapply.R
-13fbfb5aabeadfe8e67088d674315061 *R/pboptions.R
-cef7560e586710dc6e68330216dd9080 *R/pbreplicate.R
-7b3f3f92847dd3815e0c8a03926c61d8 *R/pbsapply.R
-c82e65d8522884460bc3c9b219140878 *R/unix/dopb.R
-bfbda3087e5af96d27d719d225338ddf *R/unix/getpb.R
-f286024b6cd0cdd5b58eb686dd7c7588 *R/unix/setpb.R
-d34f1b434df5b2cc1909c9d2ff514e0d *R/unix/startpb.R
-3c99369dbbb2e6bdea6e04e2a620fc37 *R/windows/dopb.R
-9a1b072ea37e8dc30770c6381683f423 *R/windows/getpb.R
-514f8bb3db324d9ab299f4cfb4b048ce *R/windows/setpb.R
-9cc645e5fc2d13c8998ba19983ec3311 *R/windows/startpb.R
-3eef430429c51829c9c21dd570f22fa9 *R/zzz.R
-3a959a314344a7065667e5275aad3b32 *inst/ChangeLog
-27f6a88705a9d730f8e06ca1afb949f7 *man/pbapply.Rd
-9b09d9f7ddfb93adbefe2e23254c1c0a *man/pboptions.Rd
-f679e4e4972fb9bfe188ac1cd5a51027 *tests/tests.R
+ef36f9ff6e20de5bbca998a0a4254c21 *DESCRIPTION
+fe00b090c7e865872b8643fd9d8ff621 *NAMESPACE
+c9afd75355061c7922a002ec6ddb33c9 *R/closepb.R
+8ee9c58d8c3128791a5631d8197bbf94 *R/pbapply.R
+55817ee443c99bdf263d86364de6af9e *R/pblapply.R
+56640b298b3c95255a1dc60302a23fee *R/pboptions.R
+85fb7bf9dec3cba585b01fe5c5ff9914 *R/pbreplicate.R
+d40dc483c2eb8643b6e329da442ff74d *R/pbsapply.R
+f353dd9c023034a3dd7b554481f2cb0b *R/splitpb.R
+7013cc42f3d3aaaa1bb90a721c363f6f *R/timerProgressBar.R
+3613eb69cfe2d3f92462dfc7184067fd *R/unix/dopb.R
+2a9e06eaae38c714caef04394e528f4f *R/unix/getpb.R
+d7ade2ac6cca19205c48196f676b4c2d *R/unix/setpb.R
+abbfcb9ec095f9e6a1a5066a1b463549 *R/unix/startpb.R
+71301142c5e1d161737f508ab41f2444 *R/windows/dopb.R
+5efeb944a3107a583c0f9bd13632d7dc *R/windows/getpb.R
+311c277daa16a7d14792f97178cf34e9 *R/windows/setpb.R
+6709ac3060b2a1167e16e51124ed31b7 *R/windows/startpb.R
+08953ef66f94e65f7263665337682cbc *R/zzz.R
+a49ccf3c9af3ad53199034a41875a4b4 *man/pbapply.Rd
+1c08f0bfe6a10e33c11624ec8b0ca3a0 *man/pboptions.Rd
+f032d5b07255b3ca4062e0c06c6136fd *man/splitpb.Rd
+97eceee05baa3f9d45d0695a8129b79e *man/timerProgressBar.Rd
diff --git a/NAMESPACE b/NAMESPACE
index 3e955eb..714f793 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,7 +1,11 @@
-if (Sys.getenv("R_OSTYPE") == "windows" || .Platform$OS.type == "windows") {
- importFrom(utils, winProgressBar, getWinProgressBar, setWinProgressBar)
-}
-importFrom(utils, txtProgressBar, getTxtProgressBar, setTxtProgressBar)
-export(pbapply, pbsapply, pblapply, pbreplicate,
- startpb, setpb, getpb, closepb, dopb, pboptions)
-
+if (Sys.getenv("R_OSTYPE") == "windows" || .Platform$OS.type == "windows") {
+ importFrom(utils, winProgressBar, getWinProgressBar, setWinProgressBar)
+}
+importFrom(utils, txtProgressBar, getTxtProgressBar, setTxtProgressBar,
+ flush.console)
+importFrom(parallel, mclapply, parLapply)
+export(pbapply, pbsapply, pblapply, pbreplicate,
+ startpb, setpb, getpb, closepb, dopb, pboptions,
+ timerProgressBar, setTimerProgressBar, getTimerProgressBar,
+ splitpb)
+
diff --git a/R/closepb.R b/R/closepb.R
index 51b87ba..ab8df1d 100644
--- a/R/closepb.R
+++ b/R/closepb.R
@@ -1,5 +1,7 @@
-closepb <-
-function(pb)
- if (is.null(pb))
- invisible(NULL) else close(pb)
-
+closepb <-
+function(pb)
+{
+ if (is.null(pb))
+ invisible(NULL) else close(pb)
+}
+
diff --git a/R/pbapply.R b/R/pbapply.R
index c18cd75..0061a5f 100644
--- a/R/pbapply.R
+++ b/R/pbapply.R
@@ -1,99 +1,99 @@
-pbapply <-
-function (X, MARGIN, FUN, ...)
-{
- FUN <- match.fun(FUN)
- dl <- length(dim(X))
- if (!dl)
- stop("dim(X) must have a positive length")
- if (is.object(X))
- X <- if (dl == 2L)
- as.matrix(X)
- else as.array(X)
- d <- dim(X)
- dn <- dimnames(X)
- ds <- seq_len(dl)
- if (is.character(MARGIN)) {
- if (is.null(dnn <- names(dn)))
- stop("'X' must have named dimnames")
- MARGIN <- match(MARGIN, dnn)
- if (anyNA(MARGIN))
- stop("not all elements of 'MARGIN' are names of dimensions")
- }
- s.call <- ds[-MARGIN]
- s.ans <- ds[MARGIN]
- d.call <- d[-MARGIN]
- d.ans <- d[MARGIN]
- dn.call <- dn[-MARGIN]
- dn.ans <- dn[MARGIN]
- d2 <- prod(d.ans)
- if (d2 == 0L) {
- newX <- array(vector(typeof(X), 1L), dim = c(prod(d.call),
- 1L))
- ans <- forceAndCall(1, FUN, if (length(d.call) < 2L) newX[,
- 1] else array(newX[, 1L], d.call, dn.call), ...)
- return(if (is.null(ans)) ans else if (length(d.ans) <
- 2L) ans[1L][-1L] else array(ans, d.ans, dn.ans))
- }
- newX <- aperm(X, c(s.call, s.ans))
- dim(newX) <- c(prod(d.call), d2)
- ans <- vector("list", d2)
-
- pb <- startpb(0, d2) # pb_specific_code
-
- if (length(d.call) < 2L) {
- if (length(dn.call))
- dimnames(newX) <- c(dn.call, list(NULL))
- for (i in 1L:d2) {
- tmp <- forceAndCall(1, FUN, newX[, i], ...)
- if (!is.null(tmp))
- ans[[i]] <- tmp
-
- setpb(pb, i) # pb_specific_code
-
- }
- }
- else for (i in 1L:d2) {
- tmp <- forceAndCall(1, FUN, array(newX[, i], d.call,
- dn.call), ...)
- if (!is.null(tmp))
- ans[[i]] <- tmp
-
- setpb(pb, i) # pb_specific_code
-
- }
-
- closepb(pb) # pb_specific_code
-
- ans.list <- is.recursive(ans[[1L]])
- l.ans <- length(ans[[1L]])
- ans.names <- names(ans[[1L]])
- if (!ans.list)
- ans.list <- any(unlist(lapply(ans, length)) != l.ans)
- if (!ans.list && length(ans.names)) {
- all.same <- vapply(ans, function(x) identical(names(x),
- ans.names), NA)
- if (!all(all.same))
- ans.names <- NULL
- }
- len.a <- if (ans.list)
- d2
- else length(ans <- unlist(ans, recursive = FALSE))
- if (length(MARGIN) == 1L && len.a == d2) {
- names(ans) <- if (length(dn.ans[[1L]]))
- dn.ans[[1L]]
- return(ans)
- }
- if (len.a == d2)
- return(array(ans, d.ans, dn.ans))
- if (len.a && len.a%%d2 == 0L) {
- if (is.null(dn.ans))
- dn.ans <- vector(mode = "list", length(d.ans))
- dn1 <- if (length(dn.call) && length(ans.names) == length(dn.call[[1L]]))
- dn.call[1L]
- else list(ans.names)
- dn.ans <- c(dn1, dn.ans)
- return(array(ans, c(len.a%/%d2, d.ans), if (!is.null(names(dn.ans)) ||
- !all(vapply(dn.ans, is.null, NA))) dn.ans))
- }
- return(ans)
-}
+pbapply <-
+function (X, MARGIN, FUN, ...)
+{
+ FUN <- match.fun(FUN)
+ dl <- length(dim(X))
+ if (!dl)
+ stop("dim(X) must have a positive length")
+ if (is.object(X))
+ X <- if (dl == 2L)
+ as.matrix(X)
+ else as.array(X)
+ d <- dim(X)
+ dn <- dimnames(X)
+ ds <- seq_len(dl)
+ if (is.character(MARGIN)) {
+ if (is.null(dnn <- names(dn)))
+ stop("'X' must have named dimnames")
+ MARGIN <- match(MARGIN, dnn)
+ if (anyNA(MARGIN))
+ stop("not all elements of 'MARGIN' are names of dimensions")
+ }
+ s.call <- ds[-MARGIN]
+ s.ans <- ds[MARGIN]
+ d.call <- d[-MARGIN]
+ d.ans <- d[MARGIN]
+ dn.call <- dn[-MARGIN]
+ dn.ans <- dn[MARGIN]
+ d2 <- prod(d.ans)
+ if (d2 == 0L) {
+ newX <- array(vector(typeof(X), 1L), dim = c(prod(d.call),
+ 1L))
+ ans <- forceAndCall(1, FUN, if (length(d.call) < 2L) newX[,
+ 1] else array(newX[, 1L], d.call, dn.call), ...)
+ return(if (is.null(ans)) ans else if (length(d.ans) <
+ 2L) ans[1L][-1L] else array(ans, d.ans, dn.ans))
+ }
+ newX <- aperm(X, c(s.call, s.ans))
+ dim(newX) <- c(prod(d.call), d2)
+ ans <- vector("list", d2)
+
+ pb <- startpb(0, d2) # pb_specific_code
+
+ if (length(d.call) < 2L) {
+ if (length(dn.call))
+ dimnames(newX) <- c(dn.call, list(NULL))
+ for (i in 1L:d2) {
+ tmp <- forceAndCall(1, FUN, newX[, i], ...)
+ if (!is.null(tmp))
+ ans[[i]] <- tmp
+
+ setpb(pb, i) # pb_specific_code
+
+ }
+ }
+ else for (i in 1L:d2) {
+ tmp <- forceAndCall(1, FUN, array(newX[, i], d.call,
+ dn.call), ...)
+ if (!is.null(tmp))
+ ans[[i]] <- tmp
+
+ setpb(pb, i) # pb_specific_code
+
+ }
+
+ closepb(pb) # pb_specific_code
+
+ ans.list <- is.recursive(ans[[1L]])
+ l.ans <- length(ans[[1L]])
+ ans.names <- names(ans[[1L]])
+ if (!ans.list)
+ ans.list <- any(unlist(lapply(ans, length)) != l.ans)
+ if (!ans.list && length(ans.names)) {
+ all.same <- vapply(ans, function(x) identical(names(x),
+ ans.names), NA)
+ if (!all(all.same))
+ ans.names <- NULL
+ }
+ len.a <- if (ans.list)
+ d2
+ else length(ans <- unlist(ans, recursive = FALSE))
+ if (length(MARGIN) == 1L && len.a == d2) {
+ names(ans) <- if (length(dn.ans[[1L]]))
+ dn.ans[[1L]]
+ return(ans)
+ }
+ if (len.a == d2)
+ return(array(ans, d.ans, dn.ans))
+ if (len.a && len.a%%d2 == 0L) {
+ if (is.null(dn.ans))
+ dn.ans <- vector(mode = "list", length(d.ans))
+ dn1 <- if (length(dn.call) && length(ans.names) == length(dn.call[[1L]]))
+ dn.call[1L]
+ else list(ans.names)
+ dn.ans <- c(dn1, dn.ans)
+ return(array(ans, c(len.a%/%d2, d.ans), if (!is.null(names(dn.ans)) ||
+ !all(vapply(dn.ans, is.null, NA))) dn.ans))
+ }
+ return(ans)
+}
diff --git a/R/pblapply.R b/R/pblapply.R
index 07d1287..e2d92ea 100644
--- a/R/pblapply.R
+++ b/R/pblapply.R
@@ -1,19 +1,67 @@
-pblapply <-
-function (X, FUN, ...)
-{
- FUN <- match.fun(FUN)
- if (!is.vector(X) || is.object(X))
- X <- as.list(X)
- B <- length(X)
- if (!(interactive() && dopb() && B >= 1))
- return(lapply(X, FUN, ...))
- pb <- startpb(0, B)
- rval <- vector("list", B)
- for (i in 1:B) {
- rval[i] <- list(FUN(X[[i]], ...))
- setpb(pb, i)
- }
- close(pb)
- names(rval) <- names(X)
- rval
-}
+pblapply <-
+function (X, FUN, ..., cl = NULL)
+{
+ FUN <- match.fun(FUN)
+ if (!is.vector(X) || is.object(X))
+ X <- as.list(X)
+ ## catch single node requests and forking on Windows
+ if (!is.null(cl)) {
+ if (inherits(cl, "cluster") && length(cl) < 2L)
+ cl <- NULL
+ if (!inherits(cl, "cluster") && cl < 2)
+ cl <- NULL
+ if (!inherits(cl, "cluster") && .Platform$OS.type == "windows")
+ cl <- NULL
+ }
+ nout <- as.integer(getOption("pboptions")$nout)
+ ## sequential evaluation
+ if (is.null(cl)) {
+ if (!dopb())
+ return(lapply(X, FUN, ...))
+ Split <- splitpb(length(X), 1L, nout = nout)
+ B <- length(Split)
+ pb <- startpb(0, B)
+ on.exit(closepb(pb), add = TRUE)
+ rval <- vector("list", B)
+ for (i in seq_len(B)) {
+ rval[i] <- list(lapply(X[Split[[i]]], FUN, ...))
+ setpb(pb, i)
+ }
+ ## parallel evaluation
+ } else {
+ ## snow type cluster
+ if (inherits(cl, "cluster")) {
+ if (!dopb())
+ return(parallel::parLapply(cl, X, FUN, ...))
+ ## define split here and use that for counter
+ Split <- splitpb(length(X), length(cl), nout = nout)
+ B <- length(Split)
+ pb <- startpb(0, B)
+ on.exit(closepb(pb), add = TRUE)
+ rval <- vector("list", B)
+ for (i in seq_len(B)) {
+ rval[i] <- list(parallel::parLapply(cl, X[Split[[i]]], FUN, ...))
+ setpb(pb, i)
+ }
+ ## multicore type forking
+ } else {
+ if (!dopb())
+ return(parallel::mclapply(X, FUN, ..., mc.cores = as.integer(cl)))
+ ## define split here and use that for counter
+ Split <- splitpb(length(X), as.integer(cl), nout = nout)
+ B <- length(Split)
+ pb <- startpb(0, B)
+ on.exit(closepb(pb), add = TRUE)
+ rval <- vector("list", B)
+ for (i in seq_len(B)) {
+ rval[i] <- list(parallel::mclapply(X[Split[[i]]], FUN, ...,
+ mc.cores = as.integer(cl)))
+ setpb(pb, i)
+ }
+ }
+ }
+ ## assemble output list
+ rval <- do.call(c, rval, quote = TRUE)
+ names(rval) <- names(X)
+ rval
+}
diff --git a/R/pboptions.R b/R/pboptions.R
index d6cfcfb..0899042 100644
--- a/R/pboptions.R
+++ b/R/pboptions.R
@@ -1,16 +1,16 @@
-pboptions <-
-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)
-}
+pboptions <-
+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)
+}
diff --git a/R/pbreplicate.R b/R/pbreplicate.R
index 905f811..e421772 100644
--- a/R/pbreplicate.R
+++ b/R/pbreplicate.R
@@ -1,4 +1,4 @@
-pbreplicate <-
-function (n, expr, simplify = "array")
-pbsapply(integer(n), eval.parent(substitute(function(...) expr)),
- simplify = simplify)
+pbreplicate <-
+function (n, expr, simplify = "array", cl = NULL)
+pbsapply(integer(n), eval.parent(substitute(function(...) expr)),
+ simplify = simplify, cl = cl)
diff --git a/R/pbsapply.R b/R/pbsapply.R
index b0c3e7b..3ccaf31 100644
--- a/R/pbsapply.R
+++ b/R/pbsapply.R
@@ -1,11 +1,11 @@
-pbsapply <-
-function (X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE)
-{
- FUN <- match.fun(FUN)
- answer <- pblapply(X = X, FUN = FUN, ...) # 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
-}
+pbsapply <-
+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
+}
diff --git a/R/splitpb.R b/R/splitpb.R
new file mode 100644
index 0000000..d2f747e
--- /dev/null
+++ b/R/splitpb.R
@@ -0,0 +1,16 @@
+splitpb <-
+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)
+}
diff --git a/R/timerProgressBar.R b/R/timerProgressBar.R
new file mode 100644
index 0000000..c7800a8
--- /dev/null
+++ b/R/timerProgressBar.R
@@ -0,0 +1,304 @@
+timerProgressBar <-
+function(min = 0, max = 1, initial = 0, char = "=",
+width = NA, title, label, style = 1, file = "", min_time = 0)
+{
+ if (!identical(file, "") && !(inherits(file, "connection") &&
+ isOpen(file)))
+ stop("'file' must be \"\" or an open connection object")
+ if (max <= min)
+ stop("must have 'max' > 'min'")
+ if (!(style %in% 1:6))
+ style <- 1
+ if (style %in% c(2, 4)) # throbber only
+ .counter <- force(1)
+
+ .start <- proc.time()[["elapsed"]]
+ .min <- force(min)
+ .max <- force(max)
+ .i <- force(initial)
+ .killed <- FALSE
+ .showpb <- FALSE
+
+ getVal <- function() .i
+
+ if (nchar(char, "w") > 1 && style %in% 1:4)
+ char <- substr(char, 1, 1)
+ if (nchar(char, "w") > 4 && style %in% 5:6)
+ char <- substr(char, 1, 4)
+ if (style %in% 5:6) {
+ if (nchar(char, "w") == 1)
+ char <- c("|", char, " ", "|")
+ else if (nchar(char, "w") == 2)
+ char <- c(substr(char,1,1), substr(char,2,2), " ", substr(char,1,1))
+ else if (nchar(char, "w") == 3)
+ char <- c(substr(char,1,1), substr(char,2,2),
+ substr(char,3,3), substr(char,1,1))
+ else if (nchar(char, "w") == 4)
+ char <- c(substr(char,1,1), substr(char,2,2),
+ substr(char,3,3), substr(char,4,4))
+ if (char[2] == char[3])
+ char[3] <- " "
+ }
+ if (is.na(width))
+ width <- options("width")[[1]]
+
+ ## |= | style progress bar with elapsed and remaining time
+ up1 <- function(value) {
+ if (!is.finite(value) || value < min || value > max)
+ return()
+ time0 <- proc.time()[["elapsed"]] - .start
+ .i <<- value
+ i <- .i - .min
+ n <- .max - .min
+ time <- time0 / (i / n) - time0
+
+ if (.i > .min && sum(time0, time, na.rm=TRUE) > min_time)
+ .showpb <<- TRUE
+ if (.showpb) {
+ spentTime <- paste0(" elapsed =", getTimeAsString(time0))
+ leftTime <- if (i == 0)
+ "" else paste0(", remaining ~", getTimeAsString(time))
+ minLetters <- nchar("%%%% ~00h 00m 00s", "w")
+
+ ## 79-24=55 > 50
+ txtWidth <- max(width, width - minLetters - 4)
+
+ text <- paste0(sprintf("%-2.0f%%", 100 * i / n), spentTime, leftTime)
+ if(nchar(text, "w") < minLetters)
+ text <- paste(text, paste(rep(" ", minLetters - nchar(text, "w")),
+ collapse = ""))
+ if(txtWidth < 0)
+ cat("\r ", text, file = file)
+
+ bb <- paste(rep(char, ceiling(txtWidth * i / n)), collapse = "")
+ empty <- paste(rep(" ", floor(txtWidth * (1 - i / n))), collapse = "")
+ bar <- paste(" |", bb, empty, "|", sep = "")
+ cat(paste("\r", bar, text), file = file)
+ flush.console()
+ }
+ }
+ ## throbber with elapsed and remaining time
+ up2 <- function(value) {
+ if (!is.finite(value) || value < min || value > max)
+ return()
+ time0 <- proc.time()[["elapsed"]] - .start
+ .i <<- value
+ i <- .i - .min
+ n <- .max - .min
+ time <- time0 / (i / n) - time0
+ if (i != 0)
+ .counter <<- .counter + 1
+
+ if (.i > .min && sum(time0, time, na.rm=TRUE) > min_time)
+ .showpb <<- TRUE
+ if (.showpb) {
+ spentTime <- paste0(" elapsed =", getTimeAsString(time0))
+ leftTime <- if (i == 0)
+ "" else paste0(", remaining ~", getTimeAsString(time))
+ minLetters <- nchar("%%%% ~00h 00m 00s", "w")
+
+ ## 79-24=55 > 50
+ txtWidth <- max(width, width - minLetters - 4)
+
+ text <- paste0(sprintf("%-2.0f%%", 100 * i / n), spentTime, leftTime)
+ if(nchar(text, "w") < minLetters)
+ text <- paste(text, paste(rep(" ", minLetters - nchar(text, "w")),
+ collapse = ""))
+ if(txtWidth < 0)
+ cat("\r ", text, file = file)
+ bb <- paste(rep(char, ceiling(txtWidth * i / n)), collapse = "")
+ bar <- c("|", "/", "-", "\\")[(.counter %% 4) + 1]
+ cat(paste("\r", bar, text), file = file)
+ flush.console()
+ }
+ }
+ ## |= | style progress bar with remaining time
+ up3 <- function(value) {
+ if (!is.finite(value) || value < min || value > max)
+ return()
+ time0 <- proc.time()[["elapsed"]] - .start
+ .i <<- value
+ i <- .i - .min
+ n <- .max - .min
+ time <- time0 / (i / n) - time0
+
+ if (.i > .min && sum(time0, time, na.rm=TRUE) > min_time)
+ .showpb <<- TRUE
+ if (.showpb) {
+ prefix <- if (i != n)
+ " ~" else " elapsed = "
+
+ leftTime <- if (i == 0)
+ getTimeAsString(NULL) else
+ if (i != n)
+ getTimeAsString(time) else getTimeAsString(time0)
+ minLetters <- nchar("%%%% ~00h 00m 00s", "w")
+
+ ## 79-24=55 > 50
+ txtWidth <- max(width, width - minLetters - 4)
+
+ text <- paste0(sprintf("%-2.0f%%", 100 * i / n), prefix, leftTime)
+ if(nchar(text, "w") < minLetters)
+ text <- paste(text, paste(rep(" ", minLetters - nchar(text, "w")),
+ collapse = ""))
+ if(txtWidth < 0)
+ cat("\r ", text, file = file)
+ bb <- paste(rep(char, ceiling(txtWidth * i / n)), collapse = "")
+ empty <- paste(rep(" ", floor(txtWidth * (1 - i / n))), collapse = "")
+ bar <- paste(" |", bb, empty, "|", sep = "")
+ cat(paste("\r", bar, text), file = file)
+ flush.console()
+ }
+ }
+ ## throbber with remaining time
+ up4 <- function(value) {
+ if (!is.finite(value) || value < min || value > max)
+ return()
+ time0 <- proc.time()[["elapsed"]] - .start
+ .i <<- value
+ i <- .i - .min
+ n <- .max - .min
+ time <- time0 / (i / n) - time0
+
+ if (i != 0)
+ .counter <<- .counter + 1
+
+ if (.i > .min && sum(time0, time, na.rm=TRUE) > min_time)
+ .showpb <<- TRUE
+ if (.showpb) {
+ prefix <- if (i != n)
+ " ~" else " elapsed = "
+ leftTime <- if (i == 0)
+ getTimeAsString(NULL) else
+ if (i != n)
+ getTimeAsString(time) else getTimeAsString(time0)
+ minLetters <- nchar("%%%% ~00h 00m 00s", "w")
+
+ ## 79-24=55 > 50
+ txtWidth <- max(width, width - minLetters - 4)
+
+ text <- paste0(sprintf("%-2.0f%%", 100 * i / n), prefix, leftTime)
+ if(nchar(text, "w") < minLetters)
+ text <- paste(text, paste(rep(" ", minLetters - nchar(text, "w")),
+ collapse = ""))
+ if(txtWidth < 0)
+ cat("\r ", text, file = file)
+ bb <- paste(rep(char, ceiling(txtWidth * i / n)), collapse = "")
+ bar <- c("|", "/", "-", "\\")[(.counter %% 4) + 1]
+ cat(paste("\r", bar, text), file = file)
+ flush.console()
+ }
+ }
+ ## [=-] style progress bar with elapsed and remaining time
+ up5 <- function(value) {
+ if (!is.finite(value) || value < min || value > max)
+ return()
+ time0 <- proc.time()[["elapsed"]] - .start
+ .i <<- value
+ i <- .i - .min
+ n <- .max - .min
+ time <- time0 / (i / n) - time0
+
+ if (.i > .min && sum(time0, time, na.rm=TRUE) > min_time)
+ .showpb <<- TRUE
+ if (.showpb) {
+ spentTime <- paste0(" elapsed =", getTimeAsString(time0))
+ leftTime <- if (i == 0)
+ "" else paste0(", remaining ~", getTimeAsString(time))
+ minLetters <- nchar("%%%% ~00h 00m 00s", "w")
+
+ ## 79-24=55 > 50
+ txtWidth <- max(width, width - minLetters - 4)
+
+ text <- paste0(sprintf("%-2.0f%%", 100 * i / n), spentTime, leftTime)
+ if(nchar(text, "w") < minLetters)
+ text <- paste(text, paste(rep(" ", minLetters - nchar(text, "w")),
+ collapse = ""))
+ if(txtWidth < 0)
+ cat("\r ", text, file = file)
+
+ bb <- paste(rep(char[2], ceiling(txtWidth * i / n)), collapse = "")
+ empty <- paste(rep(char[3], floor(txtWidth * (1 - i / n))), collapse = "")
+ bar <- paste(" ", char[1], bb, empty, char[4], sep = "")
+ cat(paste("\r", bar, text), file = file)
+ flush.console()
+ }
+ }
+ ## [=-] style progress bar with remaining time
+ up6 <- function(value) {
+ if (!is.finite(value) || value < min || value > max)
+ return()
+ time0 <- proc.time()[["elapsed"]] - .start
+ .i <<- value
+ i <- .i - .min
+ n <- .max - .min
+ time <- time0 / (i / n) - time0
+
+ if (.i > .min && sum(time0, time, na.rm=TRUE) > min_time)
+ .showpb <<- TRUE
+ if (.showpb) {
+ prefix <- if (i != n)
+ " ~" else " elapsed = "
+ leftTime <- if (i == 0)
+ getTimeAsString(NULL) else
+ if (i != n)
+ getTimeAsString(time) else getTimeAsString(time0)
+ minLetters <- nchar("%%%% ~00h 00m 00s", "w")
+
+ ## 79-24=55 > 50
+ txtWidth <- max(width, width - minLetters - 4)
+
+ text <- paste0(sprintf("%-2.0f%%", 100 * i / n), prefix, leftTime)
+ if(nchar(text, "w") < minLetters)
+ text <- paste(text, paste(rep(" ", minLetters - nchar(text, "w")),
+ collapse = ""))
+ if(txtWidth < 0)
+ cat("\r ", text, file = file)
+ bb <- paste(rep(char[2], ceiling(txtWidth * i / n)), collapse = "")
+ empty <- paste(rep(char[3], floor(txtWidth * (1 - i / n))), collapse = "")
+ bar <- paste(" ", char[1], bb, empty, char[4], sep = "")
+ cat(paste("\r", bar, text), file = file)
+ flush.console()
+ }
+ }
+ kill <- function() if (!.killed) {
+ if (.showpb) {
+ cat("\n", file = file)
+ flush.console()
+ }
+ .killed <<- TRUE
+ }
+ up <- switch(style, up1, up2, up3, up4, up5, up6)
+ up(initial)
+ structure(list(getVal = getVal, up = up, kill = kill),
+ class = c("timerProgressBar","txtProgressBar"))
+}
+
+setTimerProgressBar <- setTxtProgressBar
+getTimerProgressBar <- getTxtProgressBar
+
+## converts time in seconds into ~HHh MMm SSs format
+getTimeAsString <- function(time) {
+ if (is.null(time)) {
+ return("calculating")
+ } else {
+ if(is.infinite(time))
+ return("Inf")
+ }
+ sec <- round(time %% 60)
+ time <- floor(time / 60)
+ minutes <- floor(time %% 60)
+ time <- floor(time / 60)
+ days <- floor(time / 24)
+ time <- floor(time %% 24)
+ hours <- floor(time %% 60)
+ resTime <- ""
+ if (days > 0)
+ resTime <- sprintf("%02id ", days)
+ if (hours > 0 || days > 0)
+ resTime <- paste(resTime, sprintf("%02ih ", hours), sep = "")
+ if (minutes > 0 || hours > 0 || days > 0)
+ resTime <- paste(resTime, sprintf("%02im ", minutes), sep = "")
+ resTime <- paste0(resTime, sprintf("%02is", sec))
+ resTime
+}
diff --git a/R/unix/dopb.R b/R/unix/dopb.R
index 2aa7f9e..d027ce3 100644
--- a/R/unix/dopb.R
+++ b/R/unix/dopb.R
@@ -1,12 +1,13 @@
-dopb <-
-function()
-{
- progress.bar <- getOption("pboptions")$type
- if (!is.null(progress.bar)) {
- progress.bar <- match.arg(progress.bar, c("txt", "tk", "none"))
- if (progress.bar == "none")
- progress.bar <- NULL
- }
- interactive() && !is.null(progress.bar)
-}
-
+dopb <-
+function()
+{
+ progress.bar <- getOption("pboptions")$type
+ if (!is.null(progress.bar)) {
+ progress.bar <- match.arg(progress.bar,
+ c("timer", "txt", "tk", "none"))
+ if (progress.bar == "none")
+ progress.bar <- NULL
+ }
+ !is.null(progress.bar)
+}
+
diff --git a/R/unix/getpb.R b/R/unix/getpb.R
index e6115b3..e34fea5 100644
--- a/R/unix/getpb.R
+++ b/R/unix/getpb.R
@@ -1,12 +1,15 @@
-getpb <-
-function(pb)
-{
- if (dopb()) {
- progress.bar <- getOption("pboptions")$type
- rval <- switch(progress.bar,
- txt = getTxtProgressBar(pb),
- tk = tcltk::getTkProgressBar(pb))
- } else rval <- NULL
- rval
-}
-
+getpb <-
+function(pb)
+{
+ if (dopb()) {
+ progress.bar <- getOption("pboptions")$type
+ rval <- switch(progress.bar,
+ timer = getTxtProgressBar(pb),
+ txt = getTxtProgressBar(pb),
+ tk = tcltk::getTkProgressBar(pb))
+ } else {
+ rval <- NULL
+ }
+ rval
+}
+
diff --git a/R/unix/setpb.R b/R/unix/setpb.R
index 89f9dfb..8f8c69b 100644
--- a/R/unix/setpb.R
+++ b/R/unix/setpb.R
@@ -1,12 +1,15 @@
-setpb <-
-function(pb, value)
-{
- if (dopb()) {
- control <- getOption("pboptions")
- rval <- switch(control$type,
- txt = setTxtProgressBar(pb, value),
- tk = tcltk::setTkProgressBar(pb, value, label=control$label))
- } else rval <- NULL
- invisible(rval)
-}
-
+setpb <-
+function(pb, value)
+{
+ if (dopb()) {
+ control <- getOption("pboptions")
+ rval <- switch(control$type,
+ timer = setTxtProgressBar(pb, value),
+ txt = setTxtProgressBar(pb, value),
+ tk = tcltk::setTkProgressBar(pb, value, label = control$label))
+ } else {
+ rval <- NULL
+ }
+ invisible(rval)
+}
+
diff --git a/R/unix/startpb.R b/R/unix/startpb.R
index 7654402..5ca3b3a 100644
--- a/R/unix/startpb.R
+++ b/R/unix/startpb.R
@@ -1,13 +1,24 @@
-startpb <-
-function(min=0, max=1)
-{
- if (dopb()) {
- control <- getOption("pboptions")
- pb <- switch(control$type,
- txt = txtProgressBar(min, max, initial=control$initial,
- style = control$style, width = control$txt.width, char = control$char),
- tk = tcltk::tkProgressBar(min=min, max=max, initial=control$initial,
- title = control$title, label = control$label, width = control$gui.width))
- } else pb <- NULL
- invisible(pb)
-}
+startpb <-
+function(min=0, max=1)
+{
+ if (dopb()) {
+ control <- getOption("pboptions")
+ pb <- switch(control$type,
+ timer = timerProgressBar(min = min, max = max,
+ initial = control$initial,
+ style = control$style, width = control$txt.width,
+ char = control$char,
+ min_time = control$min_time),
+ txt = txtProgressBar(min = min, max = max,
+ initial = control$initial,
+ style = control$style, width = control$txt.width,
+ char = control$char),
+ tk = tcltk::tkProgressBar(min = min, max = max,
+ initial = control$initial,
+ title = control$title, label = control$label,
+ width = control$gui.width))
+ } else {
+ pb <- NULL
+ }
+ invisible(pb)
+}
diff --git a/R/windows/dopb.R b/R/windows/dopb.R
index 8265c23..4678231 100644
--- a/R/windows/dopb.R
+++ b/R/windows/dopb.R
@@ -1,12 +1,13 @@
-dopb <-
-function()
-{
- progress.bar <- getOption("pboptions")$type
- if (!is.null(progress.bar)) {
- progress.bar <- match.arg(progress.bar, c("txt", "win", "tk", "none"))
- if (progress.bar == "none")
- progress.bar <- NULL
- }
- interactive() && !is.null(progress.bar)
-}
-
+dopb <-
+function()
+{
+ progress.bar <- getOption("pboptions")$type
+ if (!is.null(progress.bar)) {
+ progress.bar <- match.arg(progress.bar,
+ c("timer", "txt", "win", "tk", "none"))
+ if (progress.bar == "none")
+ progress.bar <- NULL
+ }
+ !is.null(progress.bar)
+}
+
diff --git a/R/windows/getpb.R b/R/windows/getpb.R
index e0485ef..e53cc70 100644
--- a/R/windows/getpb.R
+++ b/R/windows/getpb.R
@@ -1,13 +1,16 @@
-getpb <-
-function(pb)
-{
- if (dopb()) {
- progress.bar <- getOption("pboptions")$type
- rval <- switch(progress.bar,
- txt = getTxtProgressBar(pb),
- win = getWinProgressBar(pb),
- tk = tcltk::getTkProgressBar(pb))
- } else rval <- NULL
- rval
-}
-
+getpb <-
+function(pb)
+{
+ if (dopb()) {
+ progress.bar <- getOption("pboptions")$type
+ rval <- switch(progress.bar,
+ timer = getTxtProgressBar(pb),
+ txt = getTxtProgressBar(pb),
+ win = getWinProgressBar(pb),
+ tk = tcltk::getTkProgressBar(pb))
+ } else {
+ rval <- NULL
+ }
+ rval
+}
+
diff --git a/R/windows/setpb.R b/R/windows/setpb.R
index 1d3b9f4..bee6820 100644
--- a/R/windows/setpb.R
+++ b/R/windows/setpb.R
@@ -1,13 +1,16 @@
-setpb <-
-function(pb, value)
-{
- if (dopb()) {
- control <- getOption("pboptions")
- rval <- switch(control$type,
- txt = setTxtProgressBar(pb, value),
- win = setWinProgressBar(pb, value, label=control$label),
- tk = tcltk::setTkProgressBar(pb, value, label=control$label))
- } else rval <- NULL
- invisible(rval)
-}
-
+setpb <-
+function(pb, value)
+{
+ if (dopb()) {
+ control <- getOption("pboptions")
+ rval <- switch(control$type,
+ timer = setTxtProgressBar(pb, value),
+ txt = setTxtProgressBar(pb, value),
+ win = setWinProgressBar(pb, value, label = control$label),
+ tk = tcltk::setTkProgressBar(pb, value, label = control$label))
+ } else {
+ rval <- NULL
+ }
+ invisible(rval)
+}
+
diff --git a/R/windows/startpb.R b/R/windows/startpb.R
index cf9ba1b..39ea1a4 100644
--- a/R/windows/startpb.R
+++ b/R/windows/startpb.R
@@ -1,15 +1,28 @@
-startpb <-
-function(min=0, max=1)
-{
- if (dopb()) {
- control <- getOption("pboptions")
- pb <- switch(control$type,
- txt = txtProgressBar(min, max, initial=control$initial,
- style = control$style, width = control$txt.width, char = control$char),
- win = winProgressBar(min=min, max=max, initial=control$initial,
- title = control$title, label = control$label, width = control$gui.width),
- tk = tcltk::tkProgressBar(min=min, max=max, initial=control$initial,
- title = control$title, label = control$label, width = control$gui.width))
- } else pb <- NULL
- invisible(pb)
-}
+startpb <-
+function(min=0, max=1)
+{
+ if (dopb()) {
+ control <- getOption("pboptions")
+ pb <- switch(control$type,
+ timer = timerProgressBar(min = min, max = max,
+ initial = control$initial,
+ style = control$style, width = control$txt.width,
+ char = control$char,
+ min_time = control$min_time),
+ txt = txtProgressBar(min = min, max = max,
+ initial = control$initial,
+ style = control$style, width = control$txt.width,
+ char = control$char),
+ win = winProgressBar(min = min, max = max,
+ initial = control$initial,
+ title = control$title, label = control$label,
+ width = control$gui.width),
+ tk = tcltk::tkProgressBar(min = min, max = max,
+ initial=control$initial,
+ title = control$title, label = control$label,
+ width = control$gui.width))
+ } else {
+ pb <- NULL
+ }
+ invisible(pb)
+}
diff --git a/R/zzz.R b/R/zzz.R
index 36b4152..c4b84d5 100644
--- a/R/zzz.R
+++ b/R/zzz.R
@@ -1,13 +1,28 @@
-.onLoad <- function(libname, pkgname){
- if (is.null(getOption("pboptions")))
- options("pboptions"=list(type="txt",
- char="+", txt.width=50, gui.width=300, style=3, initial=0,
- title="R progress bar", label=""))
- invisible(NULL)
-}
-
-.onUnload <- function(libpath){
- options("pboptions"=NULL)
- invisible(NULL)
-}
-
+.onLoad <- function(libname, pkgname){
+ opts <- list(
+ type = if (interactive()) "timer" else "none",
+ char = "+",
+ txt.width = 50,
+ gui.width = 300,
+ style = 3,
+ initial = 0,
+ title = "R progress bar",
+ label = "",
+ nout = 100L,
+ min_time = 0)
+ optsx <- getOption("pboptions")
+ if (!is.null(optsx)) {
+ for (i in intersect(names(opts), names(optsx)))
+ opts[[i]] <- optsx[[i]]
+ for (i in setdiff(names(optsx), names(opts)))
+ opts[[i]] <- optsx[[i]]
+ }
+ options("pboptions" = opts)
+ invisible(NULL)
+}
+
+.onUnload <- function(libpath){
+ options("pboptions" = NULL)
+ invisible(NULL)
+}
+
diff --git a/inst/ChangeLog b/inst/ChangeLog
deleted file mode 100644
index 8f962c5..0000000
--- a/inst/ChangeLog
+++ /dev/null
@@ -1,58 +0,0 @@
-# pbapply package version history
-
-## 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 is part of the apply() 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 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 check.
-
-## 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 reworked
-* functions simplified
-
-## Version 1.0-1, September 3, 2010
-
-* pbreplicate added
-* tests directory created
-* check failed on unix systems:
- man an R directory reworked
-
-## Version 1.0-0, September 2, 2010
-
-* first release
diff --git a/man/pbapply.Rd b/man/pbapply.Rd
index 74eb428..1190e55 100644
--- a/man/pbapply.Rd
+++ b/man/pbapply.Rd
@@ -1,194 +1,269 @@
-\name{pbapply}
-\alias{pbapply}
-\alias{pbsapply}
-\alias{pblapply}
-\alias{pbreplicate}
-\title{
-Adding Progress Bar to '*apply' Functions
-}
-\description{
-Adding progress bar to \code{*apply} functions}
-\usage{
-pblapply(X, FUN, ...)
-pbapply(X, MARGIN, FUN, ...)
-pbsapply(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE)
-pbreplicate(n, expr, simplify = "array")
-}
-\arguments{
- \item{X}{
-For \code{pbsapply} and \code{pblapply},
-a vector (atomic or list) or an expressions vector
-(other objects including classed objects will be
-coerced by \code{\link{as.list}}.)
-For \code{pbapply} an array, including a matrix.
-}
- \item{MARGIN}{
-A vector giving the subscripts which the function will be applied over.
-\code{1} indicates rows, \code{2} indicates columns, \code{c(1,2)}
-indicates rows and columns.
-}
- \item{FUN}{
-The function to be applied to each element of \code{X}:
-see \code{\link{apply}}, \code{\link{sapply}}, and \code{\link{lapply}}.
-}
- \item{\dots}{
-Optional arguments to \code{FUN}.
-}
- \item{simplify}{
-Logical; should the result be simplified to a vector or matrix if possible?
-}
- \item{USE.NAMES}{
-Logical; if \code{TRUE} and if \code{X} is character,
-use \code{X} as names for the result unless it had names already.
-}
- \item{n}{
-Number of replications.
-}
- \item{expr}{
-Expression (language object, usually a call) to evaluate repeatedly.
-}
-}
-\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[utils]{txtProgressBar}} (for \code{"pbapply.txt"} option),
-#ifdef windows
-\code{\link[utils]{winProgressBar}},
-#endif
-and \code{\link[tcltk]{tkProgressBar}}.
-
-See \code{\link{pboptions}} for how to conveniently set these.
-}
-\value{
-Similar to the value returned by the standard \code{*apply} functions.
-
-A progress bar is showed as a side effect.
-}
-\author{
-Peter Solymos <solymos at ualberta.ca>
-}
-\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}}
-
-Standard \code{*apply} functions:
-\code{\link{apply}}, \code{\link{sapply}},
-\code{\link{lapply}}, \code{\link{replicate}}
-
-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 ---
-n <- 200
-x <- rnorm(n)
-y <- rnorm(n, 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) {
- ndat <- ndat[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))
-## 'pb*apply' functions
-## try different settings:
-## "none", "txt", "tk"
-options("pbapply.pb"="txt")
-system.time(res4 <- pblapply(1:B, function(i) fun(bid[,i])))
-system.time(res5 <- pbsapply(1:B, function(i) fun(bid[,i])))
-system.time(res6 <- pbapply(bid, 2, fun))
-
-## --- Examples taken from standard '*apply' functions ---
-
-## --- sapply, lapply, and replicate ---
-
-require(stats); require(graphics)
-
-x <- list(a = 1:10, beta = exp(-3:3), logic = c(TRUE,FALSE,FALSE,TRUE))
-# compute the list mean for each list element
-pblapply(x, mean)
-# median and quartiles for each list element
-pblapply(x, quantile, probs = 1:3/4)
-pbsapply(x, quantile)
-i39 <- sapply(3:9, seq) # list of vectors
-pbsapply(i39, fivenum)
-
-## sapply(*, "array") -- artificial example
-(v <- structure(10*(5:8), names = LETTERS[1:4]))
-f2 <- function(x, y) outer(rep(x, length.out = 3), y)
-(a2 <- pbsapply(v, f2, y = 2*(1:5), simplify = "array"))
-
-hist(pbreplicate(100, mean(rexp(10))))
-
-## use of replicate() with parameters:
-foo <- function(x = 1, y = 2) c(x, y)
-# does not work: bar <- function(n, ...) replicate(n, foo(...))
-bar <- function(n, x) pbreplicate(n, foo(x = x))
-bar(5, x = 3)
-
-## --- apply ---
-
-## Compute row and column sums for a matrix:
-x <- cbind(x1 = 3, x2 = c(4:1, 2:5))
-dimnames(x)[[1]] <- letters[1:8]
-pbapply(x, 2, mean, trim = .2)
-col.sums <- pbapply(x, 2, sum)
-row.sums <- pbapply(x, 1, sum)
-rbind(cbind(x, Rtot = row.sums), Ctot = c(col.sums, sum(col.sums)))
-
-stopifnot( pbapply(x, 2, is.vector))
-
-## Sort the columns of a matrix
-pbapply(x, 2, sort)
-
-## keeping named dimnames
-names(dimnames(x)) <- c("row", "col")
-x3 <- array(x, dim = c(dim(x),3),
- dimnames = c(dimnames(x), list(C = paste0("cop.",1:3))))
-identical(x, pbapply( x, 2, identity))
-identical(x3, pbapply(x3, 2:3, identity))
-
-##- function with extra args:
-cave <- function(x, c1, c2) c(mean(x[c1]), mean(x[c2]))
-pbapply(x, 1, cave, c1 = "x1", c2 = c("x1","x2"))
-
-ma <- matrix(c(1:4, 1, 6:8), nrow = 2)
-ma
-pbapply(ma, 1, table) #--> a list of length 2
-pbapply(ma, 1, stats::quantile) # 5 x n matrix with rownames
-
-stopifnot(dim(ma) == dim(pbapply(ma, 1:2, sum)))
-
-## Example with different lengths for each call
-z <- array(1:24, dim = 2:4)
-zseq <- pbapply(z, 1:2, function(x) seq_len(max(x)))
-zseq ## a 2 x 3 matrix
-typeof(zseq) ## list
-dim(zseq) ## 2 3
-zseq[1,]
-pbapply(z, 3, function(x) seq_len(max(x)))
-# a list without a dim attribute
-}
-\keyword{ manip }
-\keyword{ utilities }
+\name{pbapply}
+\alias{pbapply}
+\alias{pbsapply}
+\alias{pblapply}
+\alias{pbreplicate}
+\title{
+Adding Progress Bar to '*apply' Functions
+}
+\description{
+Adding progress bar to \code{*apply} functions, possibly leveraging
+parallel processing.
+}
+\usage{
+pblapply(X, FUN, ..., cl = NULL)
+pbapply(X, MARGIN, FUN, ...)
+pbsapply(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE, cl = NULL)
+pbreplicate(n, expr, simplify = "array", cl = NULL)
+}
+\arguments{
+ \item{X}{
+For \code{pbsapply} and \code{pblapply},
+a vector (atomic or list) or an expressions vector
+(other objects including classed objects will be
+coerced by \code{\link{as.list}}.)
+For \code{pbapply} an array, including a matrix.
+}
+ \item{MARGIN}{
+A vector giving the subscripts which the function will be applied over.
+\code{1} indicates rows, \code{2} indicates columns, \code{c(1,2)}
+indicates rows and columns.
+}
+ \item{FUN}{
+The function to be applied to each element of \code{X}:
+see \code{\link{apply}}, \code{\link{sapply}}, and \code{\link{lapply}}.
+}
+ \item{\dots}{
+Optional arguments to \code{FUN}.
+}
+ \item{simplify}{
+Logical; should the result be simplified to a vector or matrix if possible?
+}
+ \item{USE.NAMES}{
+Logical; if \code{TRUE} and if \code{X} is character,
+use \code{X} as names for the result unless it had names already.
+}
+ \item{n}{
+Number of replications.
+}
+ \item{expr}{
+Expression (language object, usually a call) to evaluate repeatedly.
+}
+ \item{cl}{
+A cluster object created by \code{\link[parallel]{makeCluster}},
+or an integer to indicate number of child-processes
+(integer values are ignored on Windows) for parallel evaluations.
+}
+}
+\details{
+The behaviour of the progress bar is controlled by the option
+\code{type} in \code{\link{pboptions}},
+it can take values \code{c("txt", "win", "tk", "none",)} on Windows,
+and \code{c("txt", "tk", "none",)} on Unix systems.
+
+Other options have elements that are arguments used in the functions
+\code{\link{timerProgressBar}}, \code{\link[utils]{txtProgressBar}},
+#ifdef windows
+\code{\link[utils]{winProgressBar}},
+#endif
+and \code{\link[tcltk]{tkProgressBar}}.
+See \code{\link{pboptions}} for how to conveniently set these.
+
+Parallel processing can be enabled through the \code{cl} argument.
+\code{\link[parallel]{parLapply}} is called when \code{cl} is a 'cluster' object,
+\code{\link[parallel]{mclapply}} is called when \code{cl} is an integer.
+Showing the progress bar increases the communication overhead
+between the main process and nodes / child processes compared to the
+parallel equivalents of the functions without the progress bar.
+The functions fall back to their original equivalents when the progress bar is
+disabled (i.e. \code{getOption("pboptions")$type == "none"} or \code{dopb()} is
+\code{FALSE}). This is the default when \code{interactive()} if \code{FALSE}
+(i.e. called from command line R script).
+
+When doing parallel processing, other objects might need to pushed to the
+workers, and random numbers must be handled with care (see Examples).
+}
+\value{
+Similar to the value returned by the standard \code{*apply} functions.
+
+A progress bar is showed as a side effect.
+}
+\author{
+Peter Solymos <solymos at ualberta.ca>
+}
+\note{
+Progress bar can add an overhead to the computation.
+}
+\seealso{
+Progress bars used in the functions:
+#ifdef windows
+\code{\link[utils]{winProgressBar}},
+#endif
+\code{\link[utils]{txtProgressBar}},
+\code{\link[tcltk]{tkProgressBar}}
+
+Sequential \code{*apply} functions:
+\code{\link{apply}}, \code{\link{sapply}},
+\code{\link{lapply}}, \code{\link{replicate}}
+
+Parallel \code{*apply} functions from package 'parallel':
+\code{\link[parallel]{parLapply}},
+\code{\link[parallel]{mclapply}}.
+
+Setting the options: \code{\link{pboptions}}
+
+Conveniently add progress bar to \code{for}-like loops:
+\code{\link{startpb}}, \code{\link{setpb}}, \code{\link{getpb}},
+\code{\link{closepb}}
+}
+\examples{
+## --- simple linear model simulation ---
+set.seed(1234)
+n <- 200
+x <- rnorm(n)
+y <- rnorm(n, crossprod(t(model.matrix(~ x)), c(0, 1)), sd = 0.5)
+d <- data.frame(y, x)
+## model fitting and bootstrap
+mod <- lm(y ~ x, d)
+ndat <- model.frame(mod)
+B <- 100
+bid <- sapply(1:B, function(i) sample(nrow(ndat), nrow(ndat), TRUE))
+fun <- function(z) {
+ if (missing(z))
+ z <- sample(nrow(ndat), nrow(ndat), TRUE)
+ coef(lm(mod$call$formula, data=ndat[z,]))
+}
+
+## standard '*apply' functions
+system.time(res1 <- lapply(1:B, function(i) fun(bid[,i])))
+system.time(res2 <- sapply(1:B, function(i) fun(bid[,i])))
+system.time(res3 <- apply(bid, 2, fun))
+system.time(res4 <- replicate(B, fun()))
+
+## 'pb*apply' functions
+## try different settings:
+## "none", "txt", "tk", "win", "timer"
+op <- pboptions(type = "timer") # default
+system.time(res1pb <- pblapply(1:B, function(i) fun(bid[,i])))
+pboptions(op)
+
+pboptions(type = "txt")
+system.time(res2pb <- pbsapply(1:B, function(i) fun(bid[,i])))
+pboptions(op)
+
+pboptions(type = "txt", style = 1, char = "=")
+system.time(res3pb <- pbapply(bid, 2, fun))
+pboptions(op)
+
+pboptions(type = "txt", char = ":")
+system.time(res4pb <- pbreplicate(B, fun()))
+pboptions(op)
+
+\dontrun{
+## parallel evaluation using the parallel package
+## (n = 2000 and B = 1000 will give visible timing differences)
+
+library(parallel)
+cl <- makeCluster(2L)
+clusterExport(cl, c("fun", "mod", "ndat", "bid"))
+
+## parallel with no progress bar: snow type cluster
+## (RNG is set in the main process to define the object bid)
+system.time(res1cl <- parLapply(cl = cl, 1:B, function(i) fun(bid[,i])))
+system.time(res2cl <- parSapply(cl = cl, 1:B, function(i) fun(bid[,i])))
+
+## parallel with progress bar: snow type cluster
+## (RNG is set in the main process to define the object bid)
+system.time(res1pbcl <- pblapply(1:B, function(i) fun(bid[,i]), cl = cl))
+system.time(res2pbcl <- pbsapply(1:B, function(i) fun(bid[,i]), cl = cl))
+## (RNG needs to be set when not using bid)
+parallel::clusterSetRNGStream(cl, iseed = 0L)
+system.time(res4pbcl <- pbreplicate(B, fun(), cl = cl))
+
+stopCluster(cl)
+
+if (.Platform$OS.type != "windows") {
+ ## parallel with no progress bar: multicore type forking
+ ## (mc.set.seed = TRUE in parallel::mclapply by default)
+ system.time(res2mc <- mclapply(1:B, function(i) fun(bid[,i]), mc.cores = 2L))
+ ## parallel with progress bar: multicore type forking
+ ## (mc.set.seed = TRUE in parallel::mclapply by default)
+ system.time(res1pbmc <- pblapply(1:B, function(i) fun(bid[,i]), cl = 2L))
+ system.time(res2pbmc <- pbsapply(1:B, function(i) fun(bid[,i]), cl = 2L))
+ system.time(res4pbmc <- pbreplicate(B, fun(), cl = 2L))
+}
+}
+
+## --- Examples taken from standard '*apply' functions ---
+
+## --- sapply, lapply, and replicate ---
+
+require(stats); require(graphics)
+
+x <- list(a = 1:10, beta = exp(-3:3), logic = c(TRUE,FALSE,FALSE,TRUE))
+# compute the list mean for each list element
+pblapply(x, mean)
+# median and quartiles for each list element
+pblapply(x, quantile, probs = 1:3/4)
+pbsapply(x, quantile)
+i39 <- sapply(3:9, seq) # list of vectors
+pbsapply(i39, fivenum)
+
+## sapply(*, "array") -- artificial example
+(v <- structure(10*(5:8), names = LETTERS[1:4]))
+f2 <- function(x, y) outer(rep(x, length.out = 3), y)
+(a2 <- pbsapply(v, f2, y = 2*(1:5), simplify = "array"))
+
+hist(pbreplicate(100, mean(rexp(10))))
+
+## use of replicate() with parameters:
+foo <- function(x = 1, y = 2) c(x, y)
+# does not work: bar <- function(n, ...) replicate(n, foo(...))
+bar <- function(n, x) pbreplicate(n, foo(x = x))
+bar(5, x = 3)
+
+## --- apply ---
+
+## Compute row and column sums for a matrix:
+x <- cbind(x1 = 3, x2 = c(4:1, 2:5))
+dimnames(x)[[1]] <- letters[1:8]
+pbapply(x, 2, mean, trim = .2)
+col.sums <- pbapply(x, 2, sum)
+row.sums <- pbapply(x, 1, sum)
+rbind(cbind(x, Rtot = row.sums), Ctot = c(col.sums, sum(col.sums)))
+
+stopifnot( pbapply(x, 2, is.vector))
+
+## Sort the columns of a matrix
+pbapply(x, 2, sort)
+
+## keeping named dimnames
+names(dimnames(x)) <- c("row", "col")
+x3 <- array(x, dim = c(dim(x),3),
+ dimnames = c(dimnames(x), list(C = paste0("cop.",1:3))))
+identical(x, pbapply( x, 2, identity))
+identical(x3, pbapply(x3, 2:3, identity))
+
+##- function with extra args:
+cave <- function(x, c1, c2) c(mean(x[c1]), mean(x[c2]))
+pbapply(x, 1, cave, c1 = "x1", c2 = c("x1","x2"))
+
+ma <- matrix(c(1:4, 1, 6:8), nrow = 2)
+ma
+pbapply(ma, 1, table) #--> a list of length 2
+pbapply(ma, 1, stats::quantile) # 5 x n matrix with rownames
+
+stopifnot(dim(ma) == dim(pbapply(ma, 1:2, sum)))
+
+## Example with different lengths for each call
+z <- array(1:24, dim = 2:4)
+zseq <- pbapply(z, 1:2, function(x) seq_len(max(x)))
+zseq ## a 2 x 3 matrix
+typeof(zseq) ## list
+dim(zseq) ## 2 3
+zseq[1,]
+pbapply(z, 3, function(x) seq_len(max(x)))
+# a list without a dim attribute
+}
+\keyword{ manip }
+\keyword{ utilities }
diff --git a/man/pboptions.Rd b/man/pboptions.Rd
index 07df2d3..400a2bd 100644
--- a/man/pboptions.Rd
+++ b/man/pboptions.Rd
@@ -1,137 +1,149 @@
-\name{pboptions}
-\alias{pboptions}
-\alias{startpb}
-\alias{setpb}
-\alias{getpb}
-\alias{closepb}
-\alias{dopb}
-\title{
-Creating Progress Bar and Setting Options
-}
-\description{
-Creating progress bar and setting options.
-}
-\usage{
-pboptions(...)
-startpb(min = 0, max = 1)
-setpb(pb, value)
-getpb(pb)
-closepb(pb)
-dopb()
-}
-\arguments{
- \item{\dots}{
-Arguments in \code{tag = value} form, or a list of tagged values.
-The tags must come from the parameters described below.
-}
- \item{pb}{
-A progress bar object created by \code{startpb}.
-}
- \item{min, max}{
-Finite numeric values for the extremes of the progress bar.
-Must have \code{min < max}.
-}
- \item{value}{
-New value for the progress bar.
-}
-}
-\details{
-\code{pboptions} is a convenient way of handling options
-related to progress bar.
-
-Other functions can be used for conveniently adding progress
-bar to \code{for}-like loops
-(see Examples).
-}
-\value{
-When parameters are set by \code{pboptions}, their former values are
-returned in an invisible named list. Such a list can be passed as an
-argument to \code{pboptions} to restore the parameter values.
-Tags are the following:
-
- \item{type}{Type of the progress bar: text (\code{"txt"}),
- Windows (\code{"win"}), TclTk (\code{"tk"}), or none (\code{"none"}).
- Default value is \code{"txt"}.}
- \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}}. 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{""}.}
-
-For \code{startpb} a progress bar object.
-
-For \code{getpb} and \code{setpb}, a length-one numeric vector giving
-the previous value (invisibly for \code{setpb}).
-The return value is \code{NULL} if the progress bar is turned off by
-\code{getOption("pbapply.pb")} (\code{"none"} or \code{NULL} value).
-
-\code{dopb} returns a logical value if progress bar is to be shown
-based on the option \code{getOption("pbapply.pb")}.
-It is \code{FALSE} if the type of progress bar is \code{"none"} or
-\code{NULL}.
-
-For \code{closepb} closes the connection for the progress bar.
-}
-\author{
-Peter Solymos <solymos at ualberta.ca>
-}
-\seealso{
-Progress bars used in the functions:
-#ifdef windows
-\code{\link[utils]{winProgressBar}},
-#endif
-\code{\link[utils]{txtProgressBar}},
-\code{\link[tcltk]{tkProgressBar}}
-}
-\examples{
-## for loop
-fun1 <- function() {
- pb <- startpb(0, 10)
- on.exit(closepb(pb))
- for (i in 1:10) {
- Sys.sleep(0.15)
- setpb(pb, i)
- }
- invisible(NULL)
-}
-## while loop
-fun2 <- function() {
- pb <- startpb(0, 10-1)
- on.exit(closepb(pb))
- i <- 1
- while (i < 10) {
- Sys.sleep(0.15)
- setpb(pb, i)
- i <- i + 1
- }
- invisible(NULL)
-}
-## using original settings
-fun1()
-## resetting pboptions
-opb <- pboptions(style=1, char=">")
-## check new settings
-getOption("pboptions")
-## running again with new settings
-fun2()
-## resetting original
-pboptions(opb)
-## check reset
-getOption("pboptions")
-fun1()
-}
-\keyword{ IO }
-\keyword{ utilities }
+\name{pboptions}
+\alias{pboptions}
+\alias{startpb}
+\alias{setpb}
+\alias{getpb}
+\alias{closepb}
+\alias{dopb}
+\title{
+Creating Progress Bar and Setting Options
+}
+\description{
+Creating progress bar and setting options.
+}
+\usage{
+pboptions(...)
+startpb(min = 0, max = 1)
+setpb(pb, value)
+getpb(pb)
+closepb(pb)
+dopb()
+}
+\arguments{
+ \item{\dots}{
+Arguments in \code{tag = value} form, or a list of tagged values.
+The tags must come from the parameters described below.
+}
+ \item{pb}{
+A progress bar object created by \code{startpb}.
+}
+ \item{min, max}{
+Finite numeric values for the extremes of the progress bar.
+Must have \code{min < max}.
+}
+ \item{value}{
+New value for the progress bar.
+}
+}
+\details{
+\code{pboptions} is a convenient way of handling options
+related to progress bar.
+
+Other functions can be used for conveniently adding progress
+bar to \code{for}-like loops
+(see Examples).
+}
+\value{
+When parameters are set by \code{pboptions}, their former values are
+returned in an invisible named list. Such a list can be passed as an
+argument to \code{pboptions} to restore the parameter values.
+Tags are the following:
+
+ \item{type}{Type of the progress bar: timer (\code{"timer"}),
+ text (\code{"txt"}),
+ Windows (\code{"win"}), TclTk (\code{"tk"}), or none (\code{"none"}).
+ Default value is \code{"timer"} progress bar with estimated remaining time
+ when in interactive mode, and \code{"none"} otherwise.}
+ \item{char}{The character (or character string) to form the progress bar.
+ Default value is \code{"+"}.}
+ \item{txt.width}{The width of the text based progress bar, as a multiple
+ of the width of \code{char}.
+ If \code{NA}, the number of characters is that which fits into
+ \code{getOption("width")}.
+ Default value is \code{50}.}
+ \item{gui.width}{The width of the GUI based progress bar in pixels:
+ the dialogue box will be 40 pixels wider (plus frame).
+ Default value is \code{300}.}
+ \item{style}{The style of the bar, see
+ \code{\link[utils]{txtProgressBar}} and \code{\link{timerProgressBar}}.
+ Default value is \code{3}.}
+ \item{initial}{Initial value for the progress bar. Default value is
+ \code{0}.}
+ \item{title}{Character string giving the window title
+ on the GUI dialogue box. Default value is \code{"R progress bar"}.}
+ \item{label}{Character string giving the window label
+ on the GUI dialogue box. Default value is \code{""}.}
+ \item{nout}{Integer, the maximum number of times the progress bar is updated.
+ The default value is 100. Smaller value minimizes the
+ running time overhead related to updating the progress bar.
+ This can be especially important for forking type parallel runs.}
+ \item{min_time}{Minimum time in seconds.
+ \code{\link{timerProgressBar}} output is printed only if
+ estimated completion time is higher than this value.
+ The default value is 0.}
+
+For \code{startpb} a progress bar object.
+
+For \code{getpb} and \code{setpb}, a length-one numeric vector giving
+the previous value (invisibly for \code{setpb}).
+The return value is \code{NULL} if the progress bar is turned off by
+\code{getOption("pbapply.pb")} (\code{"none"} or \code{NULL} value).
+
+\code{dopb} returns a logical value if progress bar is to be shown
+based on the option \code{getOption("pbapply.pb")}.
+It is \code{FALSE} if the type of progress bar is \code{"none"} or
+\code{NULL}.
+
+For \code{closepb} closes the connection for the progress bar.
+}
+\author{
+Peter Solymos <solymos at ualberta.ca>
+}
+\seealso{
+Progress bars used in the functions:
+#ifdef windows
+\code{\link[utils]{winProgressBar}},
+#endif
+\code{\link{timerProgressBar}},
+\code{\link[utils]{txtProgressBar}},
+\code{\link[tcltk]{tkProgressBar}}
+}
+\examples{
+## for loop
+fun1 <- function() {
+ pb <- startpb(0, 10)
+ on.exit(closepb(pb))
+ for (i in 1:10) {
+ Sys.sleep(0.15)
+ setpb(pb, i)
+ }
+ invisible(NULL)
+}
+## while loop
+fun2 <- function() {
+ pb <- startpb(0, 10-1)
+ on.exit(closepb(pb))
+ i <- 1
+ while (i < 10) {
+ Sys.sleep(0.15)
+ setpb(pb, i)
+ i <- i + 1
+ }
+ invisible(NULL)
+}
+## using original settings
+fun1()
+## resetting pboptions
+opb <- pboptions(style = 1, char = ">")
+## check new settings
+getOption("pboptions")
+## running again with new settings
+fun2()
+## resetting original
+pboptions(opb)
+## check reset
+getOption("pboptions")
+fun1()
+}
+\keyword{ IO }
+\keyword{ utilities }
diff --git a/man/splitpb.Rd b/man/splitpb.Rd
new file mode 100644
index 0000000..00c2e20
--- /dev/null
+++ b/man/splitpb.Rd
@@ -0,0 +1,49 @@
+\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 <solymos at ualberta.ca>
+}
+\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 }
diff --git a/man/timerProgressBar.Rd b/man/timerProgressBar.Rd
new file mode 100644
index 0000000..8a2f0cd
--- /dev/null
+++ b/man/timerProgressBar.Rd
@@ -0,0 +1,125 @@
+\name{timerProgressBar}
+\alias{timerProgressBar}
+\alias{setTimerProgressBar}
+\alias{getTimerProgressBar}
+\title{
+Timer Progress Bar
+}
+\description{
+Text progress bar with timer in the R console.
+}
+\usage{
+timerProgressBar(min = 0, max = 1, initial = 0, char = "=",
+ width = NA, title, label, style = 1, file = "", min_time = 0)
+getTimerProgressBar(pb)
+setTimerProgressBar(pb, value, title = NULL, label = NULL)
+}
+\arguments{
+ \item{min, max}{
+(finite) numeric values for the extremes of the progress bar.
+Must have \code{min} < \code{max}.
+}
+ \item{initial, value}{
+initial or new value for the progress bar.
+See Details for what happens with invalid values.
+}
+ \item{char}{
+he character (or character string) to form the progress bar.
+If number of characters is >1, it is silently stripped to length 1
+unless \code{style} is 5 or 6 (see Details).
+}
+ \item{width}{
+the width of the progress bar, as a multiple of the width of char.
+If \code{NA}, the default, the number of characters is that
+which fits into \code{getOption("width")}.
+}
+ \item{style}{
+the style taking values between 1 and 6.
+1: progress bar with elapsed and remaining time,
+remaining percentage is indicated by spaces between pipes
+(default for this function),
+2: throbber with elapsed and remaining time,
+3: progress bar with remaining time printing elapsed time at the end,
+remaining percentage is indicated by spaces between pipes
+(default for \code{style} option in \code{\link{pboptions}}),
+4: throbber with remaining time printing elapsed time at the end,
+5: progress bar with elapsed and remaining time
+with more flexible styling (see Details and Examples),
+6: progress bar with remaining time printing elapsed time at the end
+with more flexible styling (see Details and Examples).
+}
+ \item{file}{
+an open connection object or \code{""} which indicates the console.
+}
+ \item{min_time}{
+numeric, minimum processing time (in seconds) required to show a progress bar.
+}
+ \item{pb}{
+an object of class \code{"timerProgressBar"}.
+}
+ \item{title, label}{
+ignored, for compatibility with other progress bars.
+}
+}
+\details{
+\code{timerProgressBar} will display a progress bar on the R console
+(or a connection) via a text representation.
+
+\code{setTimerProgessBar} will update the value. Missing (\code{NA}) and out-of-range values of value will be (silently) ignored. (Such values of \code{initial}
+cause the progress bar not to be displayed until a valid value is set.)
+
+The progress bar should be closed when finished with: this outputs the final newline character (see \code{\link{closepb}}).
+
+If \code{style} is 5 or 6, it is possible to define up to 4 characters
+for the \code{char} argument (as a single string) for the left end,
+elapsed portion, remaining portion, and right end of the progress bar
+(\code{|= |} by default). Remaining portion cannot be the same as the
+elapsed portion (space is used for remaining in such cases).
+If 1 character is defined, it is taken for the elapsed portion.
+If 2-4 characters are defined, those are interpreted in sequence
+(left and right end being the same when 2-3 characters defined),
+see Examples.
+}
+\value{
+For \code{timerProgressBar} an object of class \code{"timerProgressBar"}
+inheriting from \code{"txtProgressBar"}.
+
+For \code{getTimerProgressBar} and \code{setTimerProgressBar},
+a length-one numeric vector giving the previous
+value (invisibly for \code{setTimerProgressBar}).
+}
+\author{
+Zygmunt Zawadzki <zawadzkizygmunt at gmail.com>
+
+Peter Solymos <solymos at ualberta.ca>
+}
+\seealso{
+The \code{timerProgressBar} implementation
+follows closely the code of \code{\link[utils]{txtProgressBar}}.
+}
+\examples{
+test_fun <- function(...)
+{
+ pb <- timerProgressBar(...)
+ on.exit(close(pb))
+ for(i in seq(0, 1, 0.05)) {
+ Sys.sleep(0.05)
+ setTimerProgressBar(pb, i)
+ }
+ invisible(NULL)
+}
+
+## check the different styles
+test_fun(width = 35, char = "+", style = 1)
+test_fun(style = 2)
+test_fun(width = 50, char = ".", style = 3)
+test_fun(style = 4)
+test_fun(width = 35, char = "[=-]", style = 5)
+test_fun(width = 50, char = "{*.}", style = 6)
+
+## this should produce a progress bar based on min_time
+(elapsed <- system.time(test_fun(width = 35, min_time = 0))["elapsed"])
+## this should not produce a progress bar based on min_time
+system.time(test_fun(min_time = 2 * elapsed))["elapsed"]
+}
+\keyword{ utilities }
diff --git a/tests/tests.R b/tests/tests.R
deleted file mode 100644
index 635c4b6..0000000
--- a/tests/tests.R
+++ /dev/null
@@ -1,41 +0,0 @@
-library(pbapply)
-example(pboptions)
-example(pbapply)
-example(lapply)
-example(apply)
-
-##
-#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 around FUN
- 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
-}
-system.time(x1 <- lapply(1:10, function(i) Sys.sleep(0.2)))
-system.time(x1 <- lapply_pb(1:10, function(i) Sys.sleep(0.2)))
-#system.time(x1 <- l_ply(1:10, function(i) Sys.sleep(0.2), .progress=create_progress_bar(name = "text")))
-system.time(x1 <- pblapply(1:10, function(i) Sys.sleep(0.2)))
-
-## 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))
-
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/r-cran-pbapply.git
More information about the debian-science-commits
mailing list