rep-ex.R

#' @title
#' Evaluate R code and mask the output by a prefix
#' @description
#' Render reproducible example code to Markdown suitable for use in
#' code-oriented websites, such as StackOverflow or GitHub
#' @param expr Any R expression.
#' @param file A connection, or a character string naming the file to write to.
#' If "", print to the standard output connection. If it is "|cmd", the output
#' is piped to the command given by ‘cmd’.
#' @param prefix The prefix to be put before source code output.
#' @param variant Markdown variant.
#' @param envir The environment in which to evaluate the code.
#' @return
#' A character vector with evaluated R code with corresponding output.
#' @author Artem Klevtsov a.a.klevtsov@gmail.com
#' @seealso
#' \code{\link[knitr]{spin}}, \code{\link[formatR]{tidy_eval}},
#' \code{\link[reprex]{reprex}}
#' @examples
#' rep_ex(summary(iris))
#' rep_ex(log("a"))
#'
rep_ex <- function(expr, file = "", prefix = "#> ",
                   variant = c("so", "gh"), envir = parent.frame()) {
    variant <- match.arg(variant)
    locale <- Sys.getlocale("LC_MESSAGES")
    on.exit(Sys.setlocale("LC_MESSAGES", locale))
    Sys.setlocale("LC_MESSAGES", "C")
    try_expr <- function(e) {
        handler <- function(cond) {
            cl <- gsub("^simple", "", class(cond)[1L])
            msg <- paste(cond$message, collapse = "\n  ")
            if (!is.null(cond$call))
                res <- c(sprintf("%s in '%s':", cl, deparse(cond$call)[1L]), paste0("  ", msg))
            else
                res <- sprintf("%s: %s", cl, msg)
            if (inherits(cond, "warning"))
                res <- c(suppressWarnings(capture.output(eval(cond$call, envir))), res)
            res
        }
        tryCatch(capture.output(eval(e, envir)), error = handler, warning = handler)
    }
    qexpr <- substitute(expr)
    if (inherits(qexpr, "{")) {
        qexpr <- parse(text = as.character(qexpr)[-1])
        dexpr <- lapply(qexpr, deparse)
        out <- lapply(qexpr, try_expr)
        empty <- lengths(out) == 0L
        out[!empty] <- lapply(out[!empty], function(x) paste0(prefix, x))
        res <- unlist(c(rbind(dexpr, out)))
    } else {
        dexpr <- deparse(qexpr)
        out <- try_expr(qexpr)
        if (length(out))
            out <- paste0(prefix, out)
        res <- c(dexpr, out)
    }
    if (variant == "so")
        res <- c("<!-- language: lang-r -->", "", paste0("    ", res))
    else if (variant == "gh")
        res <- c("```r", res, "```")
    cat(res, file = file, sep = "\n")
}