R/zzz.R

In reactorlabs/r-tests-old-version:

## general (temporary) storage for testr's stuff
cache <- new.env()
cache$capture_num <- 0
cache$trace_replaced <- FALSE
cache$output.dir <- NA

cache$arguments <- list()
.decorated <- new.env()

kSymbPrefix <- "symb: "
kValSPrefix <- "vsym: "
kFuncPrefix <- "func: "
kArgsPrefix <- "argv: "

blacklist <- c(".GlobalEnv", ".Internal", ".Primitive", "substitute",
               ".Machine", "on.exit",
               "withCallingHandlers", "quote",
               "c", "NextMethod", "UseMethod", "standardGeneric", "identity","missing",
               "sys.call", "withVisible", "findRestarts", "local", "withRestarts", "formals",
               ".C", ".Call", ".External", ".External.graphics", ".External2", ".Fortran", ".Call.graphics",
               "length", "as.environment",
               "length<-", "call", "switch", "nargs", "as.numeric", "library.dynam.unload",
               "suppressMessages",
               # errors with trace
               "match.call", ".doTrace", "tracingState", "traceback", "trace", "get0",
               "forceAndCall", # added in R.3.2.1
               "library"
)

sys <- c("system.time", "system.file", "sys.status",
         "sys.source", "sys.save.image", "sys.parents",
         "sys.parent", "sys.on.exit", "sys.nframe",
         "sys.load.image", "sys.function", "sys.frames",
         "sys.frame", "sys.calls", "sys.call", "R_system_version", ".First.sys")
env <- c("environment", "environment<-", "parent.frame", "parent.env", "parent.env<-")
keywords <- c("while", "return", "repeat", "next", "if", "function", "for", "break")
operators <- c("(", ":", "%sep%", "[", "[[", "$", "@", "=", "[<-",
               "[[<-", "$<-", "@<-", "+", "-", "*", "/",
               "^", "%%", "%*%", "%/%", "<", "<=", "==",
               "!=", ">=", ">", "|", "||", "&", "!", "~",
               "<-", "$", "<<-", "&&", "||" ,"{", "(")

primitive_generics_fails <- c(.S3PrimitiveGenerics, "round", "min", "max", "expression", "attr")

.onLoad <- function(libname, pkgname) {
    # make sure temp_dir is empty
    cache$temp_dir <- tempdir()
    clean_temp()
    ## testr settings
    options("testr" = list(
        "capture.folder" = "capture",
        "capture.file" = "capture",
        "verbose" = FALSE,
        "display_only_errors" = FALSE,
        "stop_on_error" = FALSE,
        "display_code_on_error" = FALSE,
        "file_summary" = FALSE,
        "capture_file_size" = 50 * 1000 * 1000,
        "capture.arguments" = TRUE,
        "IO"=TRUE,
        "parallel_tests"=TRUE,
        "rtests"=FALSE,
        "rprofile"='
.First <- function() {
        library(testr)
        library(utils)
        builtin_capture()
}'
    ))
}

#' Querying/setting testr option
#'
#' To list all \code{testr} options, just run this function without any parameters provided. To query only one value, pass the first parameter. To set that, use the \code{value} parameter too.
#'
#' The following \code{testr} options are available:
#'
#' \itemize{
#'      \item \code{digits}: numeric (default: \code{2}) passed to \code{format}
#' }
#' @param o option name (string). See below.
#' @param value value to assign (optional)
#' @export
#'
testr_options <- function(o, value) {
    res <- getOption("testr")
    if (missing(value)) {
        ## just querying
        if (missing(o))
            return(res)
        if (o %in% names(res))
            return(res[[o]])
        stop("Wrong option queried.")
    } else {
        if (!o %in% names(res))
            stop(paste("Invalid option name:", o))
        res[[o]] <- value
        # if we are beginning to capture arguments, make sure the selected capture directory exists
        if (o == "capture.arguments" && value) {
            if (!file.exists(res[["capture.folder"]])) {
                dir.create(res[["capture.folder"]])
            } else if (!file.info(res[["capture.folder"]])$isdir) {
                stop("Capture folder cannot be created")
            }
            cache$trace_path <- file.path(getwd(), res[["capture.folder"]])
        }
        options("testr" = res)
    }
}