R/capture-fn-output.R

In autotest: Automatic Package Testing

# A `tryCatch` call modified to catch all messages, warnings, and errors.
# `tryCatch` can not normally do this because it only catches the first
# condition. This code is similar to the code of `demo(error.catching)`, but
# instead of assigning a global variable, it writes all messages to a local file
# and then parses the result with a separate function. See also the
# `tryCatchLog` package for further inspiration.

#' Evaluate `expr` with a discarding graphics device active, so that any plot
#' triggered by arbitrary package/example code under test is silently dropped
#' instead of leaking into whichever device (or file, e.g. `Rplots.pdf`) would
#' otherwise have received it. The device stack is LIFO, so this correctly
#' nests under and restores any device already active, including one recorded
#' by knitr.
#' @noRd
with_null_device <- function (expr) {
    grDevices::pdf (nullfile ())
    on.exit (grDevices::dev.off (), add = TRUE)
    expr
}

log_all_msgs <- function (con, this_fn, params = NULL) {

    o <- utils::capture.output ({
        en <- new.env ()
        if (grepl (":::", this_fn, fixed = TRUE)) {
            # internal fns can't be called via do.call:
            this_fn <- strsplit (this_fn, ":::", fixed = TRUE) [[1]]
            this_fn <- utils::getFromNamespace (this_fn [2], this_fn [1])
        }
        x <- tryCatch (
            withCallingHandlers (
                with_null_device (
                    if (is.null (params)) {
                        eval (call (this_fn), envir = en)
                    } else {
                        do.call (this_fn, params, quote = TRUE)
                    }
                ),
                error = function (e) {
                    write (toString (e),
                        con,
                        append = TRUE
                    )
                },
                warning = function (w) {
                    write (toString (w),
                        con,
                        append = TRUE
                    )
                    invokeRestart ("muffleWarning")
                },
                message = function (z) {
                    write (toString (z),
                        con,
                        append = TRUE
                    )
                }
            ),
            error = function (e) {
                return ("error detected")
            }
        )
    }) # end capture.output

    # Next 2 lines write messages to logfile, but not used here
    # if (length (o) > 1 | any (o != "NULL"))
    #    write (toString (o), con, append = TRUE)

    return (x)
}

parse_all_msgs <- function (f) {
    checkmate::assert_file_exists (f)

    x <- readLines (f)
    x <- x [which (!(x == "" | duplicated (x)))]

    # some errors and warnings have different whitespace so:
    x <- x [which (!duplicated (gsub ("\\s+", "", x)))]

    ret <- NULL

    index <- grep ("Warning\\:|^simple|^Error|^simpleMessage", x)
    if (length (index) > 0) {
        rm_lines <- NULL
        for (i in index) {
            rm_lines <- c (rm_lines, i)
            if (grepl ("\\:\\s?$", x [i])) {
                x [i] <- paste0 (x [i], x [i + 1], collapse = " ")
                rm_lines <- c (rm_lines, i + 1)
            }
            colon1 <- regexpr (":", x [i], fixed = TRUE)
            content <- gsub (
                "^\\s?", "",
                substring (x [i], colon1 + 1, nchar (x [i]))
            )
            loc <- substring (x [i], 1, colon1 - 1)
            if (grepl ("\\(.*\\)", loc)) {
                ws <- gregexpr ("\\s+", loc) [[1]]
                br <- gregexpr ("\\(.*\\)", loc) [[1]]
                loc <- substring (loc, max (ws [ws < br]) + 1, nchar (loc))
            } else {
                loc <- NA_character_
            }
            types <- c ("message", "error", "warning")
            type <- NA_character_
            for (ti in types) {
                if (grepl (ti, substring (x [i], 1, colon1),
                    ignore.case = TRUE
                )) {
                    type <- ti
                }
            }

            ret <- rbind (
                ret,
                report_object (
                    type = type,
                    fn_name = loc,
                    parameter = NA_character_,
                    content = content
                )
            )
        }
        x <- x [-rm_lines]
    }

    # anything left must be messages
    if (length (x) > 0) {
        nac <- rep (NA_character_, length (x))
        ret <- rbind (
            ret,
            report_object (
                type = rep ("message", length (x)),
                fn_name = nac,
                parameter = nac,
                content = x
            )
        )
    }

    return (ret)
}

catch_all_msgs <- function (f, this_fn, params = NULL) {

    con <- file (f, "wt")
    x <- suppressMessages (log_all_msgs (con, this_fn, params))
    close (con)
    out <- parse_all_msgs (f)
    if (!is.null (out)) {
        out$fn_name <- this_fn
    }
    # out$fn_name [which (is.na (out$fn_name))] <- this_fn
    return (out)
}

add_msg_output <- function (res, msgs, types = c ("warning", "error"),
                            operation = NULL, addcall = FALSE) {
    if (any (vapply (types, function (i) {
        not_null_and_is (msgs, i)
    }, logical (1)))) {

        if (is.null (operation)) {
            operation <- NA_character_
        }

        index <- which (msgs$type %in% types)
        for (i in index) {
            txt <- NULL
            if (addcall) {
                txt <- paste0 (
                    "Function [",
                    msgs$fn_name [i],
                    "] issued "
                )
                if (msgs$type [i] == "error") {
                    txt <- paste0 (txt, "an Error: ")
                } else {
                    txt <- paste0 (txt, "a Warning: ")
                }
            }
            res <- rbind (
                res,
                report_object (
                    type = msgs$type [i],
                    fn_name = msgs$fn_name [i],
                    parameter = msgs$parameter [i],
                    parameter_type = msgs$parameter_type,
                    operation = operation,
                    content = paste0 (
                        txt,
                        msgs$content [i]
                    )
                )
            )
        }
    }
    return (res)
}