New progress bar with estimated remaining time.

.Rbuildignore

@@ -3,3 +3,5 @@
 .DS_Store
 .*~
 .travis.yml
+^.*\.Rproj$
+^\.Rproj\.user$

.gitignore

@@ -0,0 +1,5 @@
+.Rproj.user*
+
+.Rproj.user
+
+.Rhistory

R/closepb.R

@@ -1,5 +1,7 @@
 closepb <-
 function(pb)
-    if (is.null(pb))
+{
+    if (is.null(pb) || getOption("pboptions")$type == "timer")
         invisible(NULL) else close(pb)
+}
 

R/pblapply.R

@@ -13,7 +13,7 @@ function (X, FUN, ...)
         rval[i] <- list(FUN(X[[i]], ...))
         setpb(pb, i)
     }
-    close(pb)
+    closepb(pb)
     names(rval) <- names(X)
     rval
 }

R/timerProgressBar.R

@@ -0,0 +1,78 @@
+timerProgressBar <-
+function(min = 0, max = 1, initial = 0)
+{
+    .start <- proc.time()[["elapsed"]]
+    .min   <- force(min)
+    .max   <- force(max)
+    .i     <- force(initial)
+
+
+    getVal <- function()  .i
+
+
+    ## up function similar to TxtProgressBar
+    up <- function(value) {
+    time <- proc.time()[["elapsed"]] - .start
+    .i <<- value
+
+    i <- .i - .min
+    n <- .max - .min
+
+    if (.i > .max)
+        stop("Bar is over!")
+    time <- time / (i / n) - time
+
+    leftTime <- if (i == 0)
+        getTimeAsString(NULL) else getTimeAsString(time)
+
+    char <- getOption("pboptions")$char
+    width <- options("width")[[1]]
+
+    minLetters <- nchar("%%%.%%% ~00h 00m 00s")
+    txtWidth <- width - minLetters - 4
+    text <- paste0(sprintf("%-2.2f%%", 100 * i / n), " ~", leftTime)
+
+    if(nchar(text) < minLetters)
+        text <- paste(text, paste(rep(" ",minLetters - nchar(text)), collapse = ""))
+    if(txtWidth < 0 && interactive())
+        cat("\r ",text)
+
+    bb <- paste(rep(char, ceiling(txtWidth * i / n)), collapse = "")
+    empty <- paste(rep(" ", floor(txtWidth * (1 - i / n))), collapse = "")
+
+    bar <- paste("  |", bb, empty, "|", sep = "")
+
+    if(interactive())
+        cat(paste("\r", bar, text))
+    } # end of return function
+
+    kill <- function() invisible(NULL)
+
+    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)
+    hours <- time
+    resTime <- ""
+    if (hours > 0)
+        resTime <- sprintf("%02ih ", hours)
+    if (minutes > 0 || hours > 0)
+        resTime <- paste(resTime, sprintf("%02im ", minutes), sep = "")
+    resTime <- paste0(resTime, sprintf("%02is", sec))
+    resTime
+}
+

R/unix/dopb.R

@@ -3,8 +3,9 @@ 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 <- match.arg(progress.bar,
+            c("timer", "txt", "tk", "none"))
+        if (progress.bar == "none")
             progress.bar <- NULL
     }
     interactive() && !is.null(progress.bar)

R/unix/getpb.R

@@ -3,10 +3,13 @@ function(pb)
 {
     if (dopb()) {
         progress.bar <- getOption("pboptions")$type
-        rval <- switch(progress.bar, 
-            txt = getTxtProgressBar(pb), 
+        rval <- switch(progress.bar,
+            timer = getTxtProgressBar(pb),
+            txt = getTxtProgressBar(pb),
             tk = tcltk::getTkProgressBar(pb))
-    } else rval <- NULL
+    } else {
+        rval <- NULL
+    }
     rval
 }
 

R/unix/setpb.R

@@ -3,10 +3,13 @@ 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
+        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)
 }
 

R/unix/startpb.R

@@ -3,11 +3,17 @@ 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
+        pb <- switch(control$type,
+            timer = timerProgressBar(min, max, control$initial),
+            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)
 }

R/windows/dopb.R

@@ -3,8 +3,9 @@ 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 <- match.arg(progress.bar,
+            c("timer", "txt", "win", "tk", "none"))
+        if (progress.bar == "none")
             progress.bar <- NULL
     }
     interactive() && !is.null(progress.bar)

R/windows/getpb.R

@@ -3,11 +3,14 @@ function(pb)
 {
     if (dopb()) {
         progress.bar <- getOption("pboptions")$type
-        rval <- switch(progress.bar, 
-            txt = getTxtProgressBar(pb), 
+        rval <- switch(progress.bar,
+            timer = getTxtProgressBar(pb),
+            txt = getTxtProgressBar(pb),
             win = getWinProgressBar(pb),
             tk = tcltk::getTkProgressBar(pb))
-    } else rval <- NULL
+    } else {
+        rval <- NULL
+    }
     rval
 }
 

R/windows/setpb.R

@@ -3,11 +3,14 @@ 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
+        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)
 }
 

R/windows/startpb.R

@@ -3,13 +3,21 @@ 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
+        pb <- switch(control$type,
+            timer = timerProgressBar(min, max, control$initial),
+            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)
 }

R/zzz.R

@@ -1,8 +1,14 @@
 .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=""))
+        options("pboptions" = list(
+            type = "timer",
+            char = "+",
+            txt.width = 50,
+            gui.width = 300,
+            style = 3,
+            initial = 0,
+            title = "R progress bar",
+            label = ""))
     invisible(NULL)
 }
 

man/pboptions.Rd

@@ -49,9 +49,9 @@ 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"}), 
+  \item{type}{Type of the progress bar: custom (\code{"custom"}), text (\code{"txt"}), 
     Windows (\code{"win"}), TclTk (\code{"tk"}), or none (\code{"none"}).
-    Default value is \code{"txt"}.}
+    Default value is \code{"custom"} progress bar with estimated remaining time.}
   \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 

pbapply.Rproj

@@ -0,0 +1,20 @@
+Version: 1.0
+
+RestoreWorkspace: Default
+SaveWorkspace: Default
+AlwaysSaveHistory: Default
+
+EnableCodeIndexing: Yes
+UseSpacesForTab: Yes
+NumSpacesForTab: 4
+Encoding: UTF-8
+
+RnwWeave: knitr
+LaTeX: XeLaTeX
+
+AutoAppendNewline: Yes
+StripTrailingWhitespace: Yes
+
+BuildType: Package
+PackageUseDevtools: Yes
+PackageInstallArgs: --no-multiarch --with-keep.source