use a single-line progress bar, addresses #1880

DESCRIPTION

@@ -102,7 +102,8 @@ Authors@R: c(
     person("Viktoras", "Veitas", role = "ctb"),
     person("Weicheng", "Zhu", role = "ctb"),
     person("Wush", "Wu", role = "ctb"),
-    person("Zachary", "Foster", role = "ctb")
+    person("Zachary", "Foster", role = "ctb"),
+    person("Marius", "Barth", role = "ctb", comment = c(ORCID = "0000-0002-3421-6665"))
     )
 Description: Provides a general-purpose tool for dynamic report generation in R
     using Literate Programming techniques.
@@ -172,6 +173,7 @@ Collate:
     'hooks-rst.R'
     'hooks-textile.R'
     'hooks.R'
+    'knit_progress.R'
     'output.R'
     'package.R'
     'pandoc.R'

R/block.R

@@ -53,7 +53,17 @@ call_block = function(block) {
   # save current chunk options in opts_current
   opts_current$restore(params)
 
-  if (opts_knit$get('progress')) print(block)
+  if (opts_knit$get("progress") && !is_R_CMD_check()) {
+    set_knit_progress("chunk: ", label)
+    if (opts_knit$get('verbose')) {
+      code = knit_code$get(params$label)
+      if(!is_blank(code)) {
+        for (i in seq_along(code)) {
+          set_knit_progress(code[[i]])
+        }
+      }
+    }
+  }
 
   if (!is.null(params$child)) {
     if (!is_blank(params$code)) warning(
@@ -63,6 +73,7 @@ call_block = function(block) {
     if (!params$eval) return('')
     cmds = lapply(sc_split(params$child), knit_child, options = block$params)
     out = one_string(unlist(cmds))
+    set_knit_progress("child: ", params$child)
     return(out)
   }
 
@@ -96,7 +107,7 @@ call_block = function(block) {
     if (cache$exists(hash, params$cache.lazy) &&
         isFALSE(params$cache.rebuild) &&
         params$engine != 'Rcpp') {
-      if (opts_knit$get('verbose')) message('  loading cache from ', hash)
+      if (opts_knit$get('verbose')) set_knit_progress(paste0("Loading cache from ", hash))
       cache$load(hash, lazy = params$cache.lazy)
       cache_engine(params)
       if (!params$include) return('')
@@ -511,7 +522,7 @@ merge_character = function(res) {
 }
 
 call_inline = function(block) {
-  if (opts_knit$get('progress')) print(block)
+  if (opts_knit$get('progress') && !is_R_CMD_check()) print(block)
   in_dir(input_dir(), inline_exec(block))
 }
 

R/knit_progress.R

@@ -0,0 +1,85 @@
+
+# Functions in this file are derived from utils::txtProgressBar(),
+# author: R Core Team and contributors worldwide
+
+knit_progress <- function (
+  max = 1
+  , title
+  , message
+  , style = 1
+) {
+
+  .val <- 0
+  .text <- character(1L)
+  .killed <- FALSE
+  .nb <- 0L
+  .pc <- -1L
+  char = "."
+
+  width <- floor(getOption("width") * 2/5)
+  text_width <- getOption("width") - width - 8
+
+
+  up <- function(value, text, carriage_return = "\r") {
+
+    nb <- round(width * value/max)
+    pc <- round(100 * value/max)
+
+    if (nb == .nb && pc == .pc && text == .text) return()
+    if (!is.finite(value) || value > max) stop("knitr::knit_progress() 'value' is ", value)
+
+    if(isTRUE(knitr::opts_knit$get("verbose")) && text != .text) carriage_return <- "\n"
+
+    .text <<- text
+    .val <<- value
+
+
+    cat(
+      carriage_return
+      , strtrim(encodeString(text, width = text_width), width = text_width)
+      , "|"
+      , rep.int(char, nb)
+      , rep.int(" ", width - nb)
+      , sprintf("| %3d%%", pc)
+      , sep = ""
+    )
+    flush.console()
+    .nb <<- nb
+    .pc <<- pc
+  }
+  getVal <- function() .val
+  getText <- function() .text
+  kill <- function() if (!.killed) {
+    cat("\n")
+    flush.console()
+    .killed <<- TRUE
+  }
+
+  up(value = 0, text = "Knitting...", carriage_return = "\n")
+  structure(list(getVal = getVal, getText = getText, up = up, kill = kill), class = "txtProgressBar")
+}
+
+
+set_knit_progress <- function(x, ...) {
+  UseMethod("set_knit_progress")
+}
+
+set_knit_progress.character <- function(x, ...) {
+  x <- paste0(x, ..., collapse = "")
+
+  pb <- getOption("knitr.knit_progress")
+  if(is.null(pb)) return()
+  oldval <- pb$getVal()
+  oldtext <- pb$getText()
+  pb$up(value = oldval, text = x)
+  invisible(oldval)
+}
+
+set_knit_progress.numeric <- function(x, ...) {
+  pb <- getOption("knitr.knit_progress")
+  if(is.null(pb)) return()
+  oldval <- pb$getVal()
+  oldtext <- pb$getText()
+  pb$up(value = x, text = oldtext)
+  invisible(oldval)
+}

R/output.R

@@ -245,7 +245,7 @@ knit = function(
   }
 
   progress = opts_knit$get('progress')
-  if (in.file && !quiet) message(ifelse(progress, '\n\n', ''), 'processing file: ', input)
+  if (in.file && !quiet && !child_mode()) cat("processing file: ", input)
   res = process_file(text, output)
   res = one_string(knit_hooks$get('document')(res))
   if (tangle) res = c(params, res)
@@ -257,7 +257,7 @@ knit = function(
 
   if (in.file && is.character(output) && file.exists(output)) {
     concord_gen(input, output)
-    if (!quiet) message('output file: ', output, ifelse(progress, '\n', ''))
+    if (!quiet) cat("output file: ", output, "\n\n")
   }
 
   output %n% res
@@ -277,48 +277,102 @@ purl = function(..., documentation = 1L) {
 
 process_file = function(text, output) {
   groups = split_file(lines = text)
-  n = length(groups); res = character(n)
-  tangle = opts_knit$get('tangle')
+  n <- length(groups)
+  res <- character(n)
+  tangle <- opts_knit$get('tangle')
 
   # when in R CMD check, turn off the progress bar (R-exts said the progress bar
   # was not appropriate for non-interactive mode, and I don't want to argue)
-  progress = opts_knit$get('progress') && !is_R_CMD_check()
-  if (progress) {
-    pb = txtProgressBar(0, n, char = '.', style = 3)
-    on.exit(close(pb), add = TRUE)
+  progress <- opts_knit$get('progress') && !is_R_CMD_check()
+  if (progress && !child_mode()) {
+    options(knitr.knit_progress = knit_progress(max = n))
+    on.exit(close(getOption("knitr.knit_progress")), add = TRUE)
   }
   wd = getwd()
-  for (i in 1:n) {
+
+  for (i in seq_len(n)) {
     if (!is.null(.knitEnv$terminate)) {
       if (!child_mode() || !.knitEnv$terminate_fully) {
         # reset the internal variable `terminate` in the top parent
-        res[i] = one_string(.knitEnv$terminate)
+        res[[i]] = one_string(.knitEnv$terminate)
         knit_exit(NULL, NULL)
       }
       break  # must have called knit_exit(), so exit early
     }
-    if (progress) {
-      setTxtProgressBar(pb, i)
-      if (!tangle) cat('\n')  # under tangle mode, only show one progress bar
-      flush.console()
+    if (progress && !child_mode()) {
+      set_knit_progress(i)
+    }
+
+    e.handler <- function(e) {
+      setwd(wd)
+      cat(res, sep = '\n', file = output %n% '')
+      message(
+        'Quitting from lines ', paste(current_lines(i), collapse = '-'),
+        ' (', knit_concord$get('infile'), ') '
+      )
+    }
+    message_env <- new.env()
+    message_env$messages <- character()
+    # message_env$warnings <- character()
+
+    # w.handler <- function(w){ # warning handler, courtesy of Martin Maechler
+    #   message_env$warnings <<- c(evalq(warnings, message_env), w$message)
+    #   invokeRestart("muffleWarning")
+    # }
+    m.handler <- function(m){ # warning handler, courtesy of Martin Maechler
+      message_env$messages <<- c(evalq(messages, message_env), m$message)
+      invokeRestart("muffleMessage")
     }
-    group = groups[[i]]
+
+    # first capture messages, then output them
     res[i] = withCallingHandlers(
-      if (tangle) process_tangle(group) else process_group(group),
-      error = function(e) {
-        setwd(wd)
-        cat(res, sep = '\n', file = output %n% '')
-        message(
-          'Quitting from lines ', paste(current_lines(i), collapse = '-'),
-          ' (', knit_concord$get('infile'), ') '
-        )
-      }
+      if (tangle) process_tangle(groups[[i]]) else process_group(groups[[i]]),
+      error   = e.handler,
+      # warning = w.handler,
+      message = m.handler
     )
+
+    messages <- message_env$messages
+    # warnings <- message_env$warnings
+
+    if(length(messages) > 0L) {
+      message(
+        if (!opts_knit$get("verbose")) "\r" else "\n", strrep(" ", getOption("width")),
+        "\rMessages from lines ",
+        paste(current_lines(i), collapse = '-'),
+        " in ",
+        encodeString(knit_concord$get('infile'), quote = "'"),
+        ":",
+        appendLF = TRUE
+      )
+    }
+
+    for (j in seq_along(messages)) {
+      message("  ", messages[[j]], appendLF = FALSE)
+    }
+
+    # if(length(warnings) > 0L) {
+    #   warning(
+    #     if (!opts_knit$get("verbose")) "\r" else "\n", strrep(" ", getOption("width")),
+    #     "\rWarnings from lines ",
+    #     paste(current_lines(i), collapse = '-'),
+    #     " in ",
+    #     encodeString(knit_concord$get('infile'), quote = "'"),
+    #     ":",
+    #     immediate. = TRUE,
+    #     call. = FALSE
+    #   )
+    # }
+
+    # for (j in seq_along(warnings)) {
+    #   message("  ", warnings[[j]])
+    # }
   }
 
   if (!tangle) res = insert_header(res)  # insert header
   # output line numbers
   if (concord_mode()) knit_concord$set(outlines = line_count(res))
+  if(progress && !child_mode()) close(getOption("knitr.knit_progress")) # ensures that cat('\n') is executed before `print_knitlog()`
   print_knitlog()
   if (tangle) res = strip_white(res)
 
@@ -793,3 +847,4 @@ knit_meta_add = function(meta, label = '') {
   }
   .knitEnv$meta
 }
+

R/parser.R

@@ -222,16 +222,10 @@ parse_inline = function(input, patterns) {
 
 print.inline = function(x, ...) {
   if (nrow(x$location)) {
-    cat('   ')
     if (opts_knit$get('verbose')) {
-      cat(stringr::str_pad(' inline R code fragments ',
-                  getOption('width') - 10L, 'both', '-'), '\n')
-      cat(sprintf('    %s:%s %s', x$location[, 1], x$location[, 2], x$code),
-          sep = '\n')
-      cat('  ', stringr::str_dup('-', getOption('width') - 10L), '\n')
-    } else cat('inline R code fragments\n')
-  } else cat('  ordinary text without R code\n')
-  cat('\n')
+      set_knit_progress("inline code: ", sprintf("%s:%s %s", x$location[, 1], x$location[, 2], x$code))
+    } else  set_knit_progress('inline code')
+  } else set_knit_progress('text')
 }
 
 #' Read chunks from an external script