Control keeping package startup messages

These are often unwanted in knitr output, so this allows control of
whether to display them or not

Fixes yihui/knitr#1583

NEWS

@@ -1,3 +1,6 @@
+* Add keep_package_startup_message to control keeping the package startup
+  messages (@jimhester)knitr/#1583)
+
 Version 0.11
 ------------------------------------------------------------------------------
 

R/eval.r

@@ -20,7 +20,8 @@
 #'   without signaling the error, and you will get back all results up to that
 #'   point. If \code{0} will continue running all code, just as if you'd pasted
 #'   the code into the command line.
-#' @param keep_warning,keep_message whether to record warnings and messages.
+#' @param keep_warning,keep_message,keep_package_startup_message whether to
+#'   record warnings, messages and package startup messages.
 #' @param new_device if \code{TRUE}, will open a new graphics device and
 #'   automatically close it after completion. This prevents evaluation from
 #'   interfering with your existing graphics environment.
@@ -35,8 +36,9 @@
 #' @import graphics grDevices stringr utils
 evaluate <- function(input, envir = parent.frame(), enclos = NULL, debug = FALSE,
                      stop_on_error = 0L, keep_warning = TRUE, keep_message = TRUE,
-                     new_device = TRUE, output_handler = default_output_handler,
-                     filename = NULL, include_timing = FALSE) {
+                     keep_package_startup_message = TRUE, new_device = TRUE,
+                     output_handler = default_output_handler, filename = NULL,
+                     include_timing = FALSE) {
   stop_on_error <- as.integer(stop_on_error)
   stopifnot(length(stop_on_error) == 1)
 
@@ -75,6 +77,7 @@ evaluate <- function(input, envir = parent.frame(), enclos = NULL, debug = FALSE
       envir = envir, enclos = enclos, debug = debug, last = i == length(out),
       use_try = stop_on_error != 2L,
       keep_warning = keep_warning, keep_message = keep_message,
+      keep_package_startup_message = keep_package_startup_message,
       output_handler = output_handler,
       include_timing = include_timing)
 
@@ -93,6 +96,7 @@ evaluate_call <- function(call, src = NULL,
                           envir = parent.frame(), enclos = NULL,
                           debug = FALSE, last = FALSE, use_try = FALSE,
                           keep_warning = TRUE, keep_message = TRUE,
+                          keep_package_startup_message = TRUE,
                           output_handler = new_output_handler(), include_timing = FALSE) {
   if (debug) message(src)
 
@@ -159,6 +163,11 @@ evaluate_call <- function(call, src = NULL,
     output_handler$message(m)
     invokeRestart("muffleMessage")
   } else identity
+  psmHandler <- if (keep_package_startup_message) function(m) {
+    handle_condition(m)
+    output_handler$package_startup_message(m)
+    invokeRestart("muffleMessage")
+  } else function(m) invokeRestart("muffleMessage")
 
   ev <- list(value = NULL, visible = FALSE)
 
@@ -188,7 +197,9 @@ evaluate_call <- function(call, src = NULL,
     srcindex <- length(output)
     time <- timing_fn(handle(ev <- withCallingHandlers(
       withVisible(eval(expr, envir, enclos)),
-      warning = wHandler, error = eHandler, message = mHandler)))
+      warning = wHandler, error = eHandler,
+      packageStartupMessage = psmHandler,
+      message = mHandler)))
     handle_output(TRUE)
     if (!is.null(time))
       attr(output[[srcindex]]$src, 'timing') <- time
@@ -201,7 +212,9 @@ evaluate_call <- function(call, src = NULL,
       }
       handle(pv <- withCallingHandlers(withVisible(
         value_fun(ev$value, ev$visible)
-      ), warning = wHandler, error = eHandler, message = mHandler))
+      ), warning = wHandler, error = eHandler,
+         packageStartupMessage = psmHandler,
+         message = mHandler))
       handle_output(TRUE)
       # If the return value is visible, save the value to the output
       if (pv$visible) output <- c(output, list(pv$value))