diff --git a/DESCRIPTION b/DESCRIPTION index 3092d33f5d..ecfcdcd062 100644 --- a/DESCRIPTION +++ b/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' diff --git a/R/block.R b/R/block.R index 6958c7aba0..86846fc43c 100644 --- a/R/block.R +++ b/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)) } diff --git a/R/knit_progress.R b/R/knit_progress.R new file mode 100644 index 0000000000..10190d7f44 --- /dev/null +++ b/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) +} diff --git a/R/output.R b/R/output.R index ed50cbe9f7..8b05146749 100644 --- a/R/output.R +++ b/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 } + diff --git a/R/parser.R b/R/parser.R index 156a700d82..bbcdee0b75 100644 --- a/R/parser.R +++ b/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