R/capture_all.R

In SciViews/svMisc: 'SciViews' - Miscellaneous Functions

#' Run an R expression and capture output and messages in a similar way as it
#' would be done at the command line
#'
#' @description This function captures results of evaluating one or several R
#' expressions the same way as it would be issued at the prompt in a R console.
#' The result is returned in a character string. Errors, warnings and other
#' conditions are treated as usual, including the delayed display of the
#' warnings if `options(warn = 0)`.
#'
#' @param expr A  valid R expression to evaluate (names and calls are also
#'   accepted).
#' @param split Do we split output, that is, do we also issue it at the R
#' console too, or do we only capture it silently?
#' @param echo Do we echo each expression in front of the results (like in the
#' console)? In case the expression spans on more than 7 lines, only first and
#' last three lines are echoed, separated by `[...]`.
#' @param file A file, or a valid opened connection where output is sunk. It
#' is closed at the end, and the function returns `NULL` in this case. If
#' `file = NULL` (by default), a `textConnection()` captures the output and it
#' is returned as a character string by the function.
#' @param markStdErr If `TRUE`, stderr is separated from stddout by STX/ETX
#' characters.
#' @return Returns a string with the result of the evaluation done in the user
#' workspace.
#' @note If the expression is provided as a character string that should be
#' evaluated, and you need a similar behavior as at the prompt for incomplete
#' lines of code (that is, to prompt for more), you should not parse the
#' expression with `parse(text = "<some_code>")` because it returns an error
#' instead of an indication of an incomplete code line. Use
#' `parse_text("<some_code>")` instead, like in the examples bellow.
#' Of course, you have to deal with incomplete line management in your GUI/CLI
#' application... the function only returns `NA` instead of a character string.
#' Starting from version 1.1.3, `.Traceback` is not set any more in the base
#' environment, but it is `.Traceback_capture_all` that is set in `temp_env()`.
#' You can get its value with `get_temp(".Traceback_capture_all")`.
#' Also, if there are many warnings, those are now assigned in `temp_env()`
#' instead of `baseenv()`. Consequently, they cannot be viewer with [warnings()]
#' but use `warnings2()` in this case.
#' @export
#' @seealso [parse()], [expression()], [capture.output()]
#' @keywords IO
#' @concept capturing output for GUI clients
#' @examples
#' writeLines(capture_all(expression(1 + 1), split = FALSE))
#' writeLines(capture_all(expression(1 + 1), split = TRUE))
#' writeLines(capture_all(parse_text("search()"), split = FALSE))
#' \dontrun{
#' writeLines(capture_all(parse_text('1:2 + 1:3'), split = FALSE))
#' writeLines(capture_all(parse_text("badname"), split = FALSE))
#' }
#'
#' # Management of incomplete lines
#' capt_res <- capture_all(parse_text("1 +")) # Clearly an incomplete command
#' if (is.na(capt_res)) cat("Incomplete line!\n") else writeLines(capt_res)
#' rm(capt_res)
capture_all <- function(expr, split = TRUE, echo = TRUE, file = NULL,
markStdErr = FALSE) {
  # Inspired by 'capture.output' and the old .try_silent in utils package
  # Requires: R >= 2.13.0

  if (is.null(expr))
    stop("argument is of length zero")
  if (!is.expression(expr)) {
    if (is.na(expr)) return(NA) else
      stop("expr must be an expression or NA")
  }
  # TODO: support for 'file'
  # markStdErr: if TRUE, stderr is separated from sddout by STX/ETX character

  last.warning <- list()
  Traceback <- list()
  n_frame_offset <- sys.nframe() + 23L	# frame of reference (used in traceback)
  # + length of the call stack when a condition occurs
  # Note: if 'expr' is a call, not an expression, 'n_frame_offset' is lower by 2
  # (i.e. 24): -1 for lapply, -1 for unwrapping 'expression()'

  # This may change in course of evaluation, so must be retrieved dynamically
  get_warn_level <- function() options('warn')[[1L]]

  ret_val <- NULL
  conn <- textConnection("ret_val", "w", local = TRUE)
  split <- isTRUE(split)
  if (split) {
    # This is required to print error messages when we are, say, in a
    # browser() environment
    sink(stdout(), type = "message")
  } else {
    # This is the conventional way to do it
    sink(conn, type = "message")
  }
  sink(conn, type = "output", split = split)
  #sink(conn, type = "message")
  on.exit({
    sink(type = "message")
    sink(type = "output")
    close(conn)
  })

  in_stdout <- TRUE

  if (isTRUE(markStdErr)) {
    put_mark <- function(to_stdout, id) {
      if (in_stdout) {
        if (!to_stdout) {
          cat("\x03")
          in_stdout <<- FALSE
        }
      } else {# in StdErr stream
        if (to_stdout) {
          cat("\x02")
          in_stdout <<- TRUE
        }
      }
      #cat("<", id, in_stdout, ">")
    }
  } else {
    put_mark <- function(to_stdout, id) {}
  }

  eval_vis <- function(x) {
    # Do we print the command? (note that it is reformatted here)
    if (isTRUE(echo)) {
      # Reformat long commands... and possibly abbreviate them
      cmd <- deparse(x)
      l <- length(cmd)
      if (l > 7) cmd <- c(cmd[1:3], "[...]", cmd[(l - 2):l])
      cat(":> ", paste(cmd, collapse = "\n:+ "), "\n", sep = "")
    }
    res <- withVisible(eval(x, .GlobalEnv))
    # Do we have result to print?
    if (inherits(res, "list") && res$visible) {
      # Printing is veeery slow on Windows when split = TRUE
      # => unsplit temporarily, and print twice instead!
      #print(res$value)

      if (split) {
        sink(type = "message")
        sink(type = "output")
        # Print first to the console
        try(print(res$value), silent = TRUE)
        sink(conn, type = "message")
        sink(conn, type = "output", split = FALSE)
        # Print a second time to the connection
        try(print(res$value), silent = TRUE)
        # Resink with split = TRUE
        sink(type = "message")
        sink(type = "output")
        sink(stdout(), type = "message")
        sink(conn, type = "output", split = TRUE)
      } else {
        # This is the conventional way to do it
        print(res$value)
      }
    }

    res
  }

  fomat_message <- function(msg) {
    # For some reasons, 'Error: ' and 'Error in ' are not translated,
    # although the rest of the message is correctly translated
    # This is a workaround for this little problem
    res <- .makeMessage(msg)
    res <- sub("^Error: ", ngettext(1, "Error: ", "Error: ", domain = "R"), res)
    sub("^Error in ", ngettext(1, "Error in ", "Error in ", domain = "R"), res)
  }

  restart_error <- function(e, calls) {
    # Remove call (eval(expr, envir, enclos)) from the message
    ncls <- length(calls)

    #DEBUG: cat("n calls: ", ncls, "n_frame_offset: ", n_frame_offset, "\n")
    if (isTRUE(all.equal(calls[[n_frame_offset]], e$call,
      check.attributes = FALSE)))
      e$call <- NULL

    Traceback <<- rev(calls[-c(seq.int(n_frame_offset), (ncls - 1L):ncls)])

    #> cat(captureAll(expression(1:10, log(-1),log(""),1:10)), sep="\n")
    #Error in calls[[n_frame_offset]]: subscript out of bounds
    #Warning message:
    #In log(-1) : NaNs produced

    put_mark(FALSE, 1)
    cat(fomat_message(e))
    if (get_warn_level() == 0L && length(last.warning) > 0L)
      cat(ngettext(1, "In addition: ", "In addition: ", domain = "R"))
  }

  res <- tryCatch(
    withRestarts(
      withCallingHandlers(
        {
          # TODO: allow for multiple expressions and calls (like in
          # 'capture.output'). The problem here is how to tell 'expression'
          # from 'call' without evaluating it?
          #list(eval_vis(expr))
          lapply(expr, eval_vis)
        },

        error = function(e) invokeRestart("grmbl", e, sys.calls()),

        warning = function(e) {
          # Remove call (eval(expr, envir, enclos)) from the message
          if (isTRUE(all.equal(sys.call(n_frame_offset), e$call,
            check.attributes = FALSE)))
            e$call <- NULL

          last.warning <<- c(last.warning, structure(list(e$call),
            names = e$message))

          if (get_warn_level() != 0L) {
            put_mark(FALSE, 2)
            .signalSimpleWarning(conditionMessage(e), conditionCall(e))
              put_mark(TRUE, 3)
          }
          invokeRestart("muffleWarning")
        }
      ),

      # Restarts:

      # Handling user interrupts. Currently it works only from within R.
      #TODO: how to trigger interrupt via socket connection?
      abort = function(...) {
        put_mark(FALSE, 4)
        cat("<aborted!>\n") #DEBUG
      },

      interrupt = function(...)
        cat("<interrupted!>\n"), #DEBUG: this does not seem to be ever called.

      muffleWarning = function() NULL,

      grmbl = restart_error
    ),

    error = function(e) { # This is called if warnLevel == 2
      put_mark(FALSE, 5)
      cat(fomat_message(e))
      e #identity
	  },

    finally = {}
  )

  if (get_warn_level() == 0L) {
    n_warn <- length(last.warning)
    # was: assign("last.warning", last.warning, envir = baseenv())
    assign_temp("last.warning", last.warning)

    if (n_warn > 0L) put_mark(FALSE, 6)
    if (n_warn <= 10L) {
      print.warnings(last.warning)
    } else if (n_warn < 50L) {
      # This is buggy and does not retrieve a translation of the message!
      #cat(gettextf("There were %d warnings (use warnings() to see them)\n",
      #  n_warn, domain = "R"))
      msg <- ngettext(1,
        "There were %d warnings (use warnings2() to see them)\n",
        "There were %d warnings (use warnings2() to see them)\n",
        domain = "R")
      cat(sprintf(msg, n_warn))
    } else {
      cat(ngettext(1,
        "There were 50 or more warnings (use warnings2() to see the first 50)\n",
        "There were 50 or more warnings (use warnings2() to see the first 50)\n",
        domain = "R"))
    }
  }

  put_mark(TRUE, 7)

  sink(type = "message")
  sink(type = "output")
  close(conn)
  on.exit()

  # Allow for tracebacks of this call stack:
  assign_temp(".Traceback_capture_all", lapply(Traceback, deparse))

  # Make sure last line ends up with \n
  l <- length(ret_val)
  if (l) ret_val[l] <- paste(ret_val[l], "\n", sep = "")
  ret_val
}

# Backward compatibility

#' @export
#' @rdname capture_all
captureAll <- capture_all

#' @export
#' @rdname capture_all
#' @param ... Items passed directly to `warnings2()`.
warnings2 <- function(...) {
  if (length(last.warning <- get_temp("last.warning")))
    structure(last.warning, dots = list(...), class = "warnings")
}