add a custom printing function record_print() for record() to print v…

…isible values

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: xfun
 Type: Package
 Title: Supporting Functions for Packages Maintained by 'Yihui Xie'
-Version: 0.43.8
+Version: 0.43.9
 Authors@R: c(
   person("Yihui", "Xie", role = c("aut", "cre", "cph"), email = "[email protected]", comment = c(ORCID = "0000-0003-0645-5666")),
   person("Wush", "Wu", role = "ctb"),

NAMESPACE

@@ -6,6 +6,7 @@ S3method(print,xfun_raw_string)
 S3method(print,xfun_record_results)
 S3method(print,xfun_rename_seq)
 S3method(print,xfun_strict_list)
+S3method(record_print,default)
 export(Rcmd)
 export(Rscript)
 export(Rscript_call)
@@ -102,6 +103,7 @@ export(read_all)
 export(read_bin)
 export(read_utf8)
 export(record)
+export(record_print)
 export(relative_path)
 export(rename_seq)
 export(rest_api)

NEWS.md

@@ -8,6 +8,8 @@
 
 - Changed the default value of the argument `error` of `record()` from `FALSE` to `NA`. Now `FALSE` means to suppress error messages, and `NA` means to throw errors normally. This is for consistency with the `message` and `warning` arguments.
 
+- Added an S3 generic function `record_print()`, which is similar to `knitr::knit_print()` but for the purpose of printing visible values in `record()`.
+
 - Exported the internal function `md5()` to calculate the MD5 checksums of R objects. The function is essentially a workaround for `tools::md5sum()` (see HenrikBengtsson/Wishlist-for-R#21).
 
 - `write_utf8()` returns the `con` argument (typically a file path) now. Previously, it returns `NULL`.

R/record.R

@@ -183,6 +183,27 @@ record = function(
   handle_w = handle_message('warning', warning)
   handle_e = handle_message('error', error)
 
+  # don't use withCallingHandlers() if message/warning/error are all NA
+  handle_eval = function(expr) {
+    handle(if (is.na(message) && is.na(warning) && is.na(error)) expr else {
+      withCallingHandlers(
+        expr, message = handle_m, warning = handle_w, error = handle_e
+      )
+    })
+  }
+  # a simplified version of capture.output()
+  handle_output = function(expr) {
+    out = NULL
+    con = textConnection('out', 'w', local = TRUE)
+    on.exit(close(con))
+    sink(con); on.exit(sink(), add = TRUE)
+    expr  # lazy evaluation
+    on.exit()  # if no error occurred, clear up previous on-exit calls
+    sink()
+    close(con)
+    if (length(out)) add_result(out, 'output')
+    expr
+  }
   n = length(codes)
   for (i in seq_len(n)) {
     add_result(code <- codes[[i]], 'source')
@@ -192,13 +213,14 @@ record = function(
     if (verbose == 2 || (verbose == 1 && i == n)) {
       expr = parse_only(c('(', code, ')'))
     }
-    # TODO: replace capture.output() with a custom version of sink() +
-    # withVisible() so we can support a custom printing function like knit_print()
-    out = handle(withCallingHandlers(
-      capture.output(eval(expr, envir)),
-      message = handle_m, warning = handle_w, error = handle_e
-    ))
-    if (length(out) && !is_error(out)) add_result(out, 'output')
+    # evaluate the code and capture output
+    out = handle_output(handle_eval(withVisible(eval(expr, envir))))
+    # print value (via record_print()) if visible
+    if (!is_error(out) && out$visible) {
+      out = handle_eval(record_print(out$value))
+      if (length(out) && !is_error(out))
+        add_result(out, if (inherits(out, 'record_asis')) 'asis' else 'output')
+    }
     handle_plot()
   }
   # shut off the device to write out the last plot if there exists one
@@ -229,6 +251,30 @@ merge_record = function(x) {
   x
 }
 
+#' Print methods for `record()`
+#'
+#' An S3 generic function to be called to print visible values in code when the
+#' code is recorded by [record()]. It is similar to [knitr::knit_print()]. By
+#' default, it captures the normal [print()] output and returns the result as a
+#' character vector. Users and package authors can define other S3 methods to
+#' extend this function.
+#' @param x The value to be printed.
+#' @param ... Other arguments to be passed to `record_print()` methods.
+#' @return A `record_print()` method should return a character vector. The
+#'   returned value may have a special class `record_asis`, which will be stored
+#'   in the `record()` output. All other classes will be discarded.
+#' @export
+record_print = function(x, ...) {
+  UseMethod('record_print')
+}
+
+#' @rdname record_print
+#' @export
+record_print.default = function(x, ...) {
+  # the default print method is just print()/show()
+  capture.output(if (isS4(x)) methods::show(x, ...) else print(x, ...))
+}
+
 dev_open = function(dev, file, args) {
   m = names(formals(dev))
   a = list(units = 'in', onefile = FALSE, width = 8, height = 8, res = 84)