From 3e9bb4e5a72d87f19ebdc14940dca1d9aac8171f Mon Sep 17 00:00:00 2001 From: Filip Krikava Date: Tue, 3 Jul 2018 07:23:06 +0200 Subject: [PATCH] Major refactoring - new API for genthat and decorator Closes #165, #149, #148, #140, #139, #121, #118, #112 --- NAMESPACE | 6 +- R/RcppExports.R | 4 + R/capture.R | 35 +- R/create-decorated-function.R | 181 ++++++++++ R/decorate.R | 215 +++++------- R/decorators.R | 233 ------------- R/extract-package-code.R | 39 +-- R/genthat.R | 191 +++-------- R/helpers.R | 149 ++++++--- R/trace-package.R | 112 +++++++ R/{traces.R => trace.R} | 0 R/tracer.R | 84 +++-- R/zzz.R | 42 +-- inst/genthat-tracing-site-file.R | 14 +- man/Store-tracer.Rd | 9 - man/{Copy-call-traces.Rd => copy_traces.Rd} | 8 +- man/create_tracer.Rd | 26 ++ man/decorate_environment.Rd | 4 +- man/decorate_function.Rd | 22 +- man/extract_package_code.Rd | 4 +- man/gen_from_package.Rd | 10 +- man/get_decorations.Rd | 15 + man/get_tracer.Rd | 19 ++ man/reset_function.Rd | 9 +- man/{Reset-traces.Rd => reset_traces.Rd} | 8 +- man/set_tracer.Rd | 18 + man/store_trace.Rd | 16 + man/trace_package.Rd | 9 +- run-parallel.sh | 2 +- src/RcppExports.cpp | 12 + src/Utils.cpp | 10 + .../samplepkg/tests/testthat/testMain.R | 1 - tests/testthat/test-capture-scenarios.R | 31 +- tests/testthat/test-capture.R | 31 +- .../testthat/test-create-decorated-function.R | 310 ++++++++++++++++++ tests/testthat/test-decorate-with-on.exit.R | 109 ------ tests/testthat/test-decorate-with-onboth.R | 108 ------ tests/testthat/test-decorate-with-onentry.R | 89 ----- tests/testthat/test-decorate-with-onexit.R | 90 ----- tests/testthat/test-decorate-with-trycatch.R | 102 ------ tests/testthat/test-decorate.R | 228 +++++++------ tests/testthat/test-extract-package-code.R | 10 +- tests/testthat/test-gen-from-package.R | 1 - tests/testthat/test-genthat-integration.R | 33 -- tests/testthat/test-genthat-samplepkg.R | 151 +++------ tests/testthat/test-genthat.R | 5 +- tests/testthat/test-helpers.R | 68 +++- tests/testthat/test-trace-package.R | 86 +++++ .../testthat/{test-traces.R => test-trace.R} | 9 +- tests/testthat/test-tracer.R | 57 ++++ vignettes/basic-usage.Rmd | 4 +- 51 files changed, 1574 insertions(+), 1455 deletions(-) create mode 100644 R/create-decorated-function.R delete mode 100644 R/decorators.R create mode 100644 R/trace-package.R rename R/{traces.R => trace.R} (100%) delete mode 100644 man/Store-tracer.Rd rename man/{Copy-call-traces.Rd => copy_traces.Rd} (51%) create mode 100644 man/create_tracer.Rd create mode 100644 man/get_decorations.Rd create mode 100644 man/get_tracer.Rd rename man/{Reset-traces.Rd => reset_traces.Rd} (62%) create mode 100644 man/set_tracer.Rd create mode 100644 man/store_trace.Rd create mode 100644 tests/testthat/test-create-decorated-function.R delete mode 100644 tests/testthat/test-decorate-with-on.exit.R delete mode 100644 tests/testthat/test-decorate-with-onboth.R delete mode 100644 tests/testthat/test-decorate-with-onentry.R delete mode 100644 tests/testthat/test-decorate-with-onexit.R delete mode 100644 tests/testthat/test-decorate-with-trycatch.R delete mode 100644 tests/testthat/test-genthat-integration.R create mode 100644 tests/testthat/test-trace-package.R rename tests/testthat/{test-traces.R => test-trace.R} (74%) create mode 100644 tests/testthat/test-tracer.R diff --git a/NAMESPACE b/NAMESPACE index 7c5d00ce..9e9b39b2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -22,7 +22,6 @@ export(capture) export(compute_coverage) export(compute_tests_coverage) export(copy_traces) -export(create_decorator) export(create_sequence_tracer) export(create_set_tracer) export(create_tracer) @@ -36,18 +35,19 @@ export(gen_from_package) export(gen_from_source) export(generate_test) export(generate_test_file) -export(get_decorator) +export(get_decorations) export(get_package_version) export(get_tracer) export(is_debug_enabled) export(is_decorated) export(is_tracing_enabled) export(process_traces) +export(record_trace) export(reset_function) +export(reset_functions) export(reset_traces) export(run_generated_test) export(save_test) -export(set_decorator) export(set_tracer) export(store_trace) export(test_generated_file) diff --git a/R/RcppExports.R b/R/RcppExports.R index a62045ca..b8adeaa3 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -53,3 +53,7 @@ environment_name_as_code <- function(env) { .Call('_genthat_environment_name_as_code', PACKAGE = 'genthat', env) } +sexp_address <- function(s) { + .Call('_genthat_sexp_address', PACKAGE = 'genthat', s) +} + diff --git a/R/capture.R b/R/capture.R index cff208bc..4e49abd5 100644 --- a/R/capture.R +++ b/R/capture.R @@ -1,7 +1,14 @@ -# Default function entry decorator. -# Creates the trace record and stores it into the trace vector. -record_trace <- function(name, pkg=NULL, args, retv, error, seed, - env=parent.frame(), tracer=get_tracer()) { +#' @export +record_trace <- function(info) { + + name <- info$name + package <- info$package + args <- info$args + retv <- info$retv + error <- info$error + seed <- info$seed + env <- if (is.null(info$env)) parent.frame() else info$env + tracer <- if (is.null(info$tracer)) get_tracer() else info$tracer # TODO: (performance) all this makes sense only if there are symbols anywhere in args # get callee globals (free variables) that we need to capture @@ -33,6 +40,7 @@ record_trace <- function(name, pkg=NULL, args, retv, error, seed, # in the parent frame tmp_name <- names(args)[[1]] value_name <- names(args)[[length(args)]] + # TODO: this should be just -1 call_env <- sys.frame(sys.nframe() - 1) # we are trying to get the *tmp* @@ -53,11 +61,11 @@ record_trace <- function(name, pkg=NULL, args, retv, error, seed, globals <- as.list(environment(extract_closure(callee)), all.names=TRUE) globals <- lapply(globals, duplicate_global_var) - create_trace(name, pkg, args=args, globals=globals, retv=retv, seed=seed, error=error) + create_trace(name, package, args=args, globals=globals, retv=retv, seed=seed, error=error) }, error=function(e) { - create_trace(name, pkg, args=args, failure=e) + create_trace(name, package, args=args, failure=e) }, warning=function(e) { - create_trace(name, pkg, args=args, failure=e) + create_trace(name, package, args=args, failure=e) }) store_trace(tracer, trace) @@ -182,17 +190,17 @@ get_symbol_values <- function(names, env=parent.frame(), include_base_symbols=FA } get_variable_value_or_reference <- function(name, env) { - pkg <- get_package_name(env) + package <- get_package_name(env) if (is_base_env(env)) { substitute(NAME, list(NAME=as.name(name))) } else if (is_package_environment(env)) { - substitute(PKG::NAME, list(PKG=as.name(pkg), NAME=as.name(name))) + substitute(PACKAGE::NAME, list(PACKAGE=as.name(package), NAME=as.name(name))) } else if (is_package_namespace(env)) { if (name %in% getNamespaceExports(env)) { - substitute(PKG::NAME, list(PKG=as.name(pkg), NAME=as.name(name))) + substitute(PACKAGE::NAME, list(PACKAGE=as.name(package), NAME=as.name(name))) } else { - substitute(PKG:::NAME, list(PKG=as.name(pkg), NAME=as.name(name))) + substitute(PACKAGE:::NAME, list(PACKAGE=as.name(package), NAME=as.name(name))) } } else { get(name, envir=env, inherits=FALSE) @@ -276,7 +284,10 @@ extract_closure <- function(fun, name=substitute(fun), .visited=list()) { # we should only link the environments in the case it is necessary # i.e. any of the global functions need access to this environment # the idea is demonstrated in the test-capture.R - link_environments(e, .fun_filter=function(x) is.local_closure(x) && isTRUE(attr(x, "genthat_needs_link"))) + link_environments(e, .fun_filter=function(x) { + is.local_closure(x) && isTRUE(attr(x, "genthat_needs_link")) + }) + e } diff --git a/R/create-decorated-function.R b/R/create-decorated-function.R new file mode 100644 index 00000000..79f5f5e0 --- /dev/null +++ b/R/create-decorated-function.R @@ -0,0 +1,181 @@ +create_decorated_function <- function(fun, name, package, + onentry=NULL, onexit=NULL, onerror=NULL) { + + stopifnot(is.function(fun)) + stopifnot(is_chr_scalar(name)) + stopifnot(is.null(package) || is_chr_scalar(package)) + stopifnot(is.null(onentry) || is.function(onentry)) + stopifnot(is.null(onexit) || is.function(onexit)) + stopifnot(is.null(onerror) || is.function(onerror)) + stopifnot(!all(is.null(onentry), is.null(onexit), is.null(onerror))) + + prologue <- if (!is.null(onentry)) { + substitute( + ONENTRY( + list( + name=NAME, + package=PACKAGE, + seed=`__genthat_captured_seed`, + env=parent.frame(), + decorator="onentry" + ) + ), + list(ONENTRY=onentry, NAME=name, PACKAGE=package) + ) + } else { + NULL + } + + onexit_call <- if (!is.null(onexit)) { + substitute( + ONEXIT( + list( + name=NAME, + package=PACKAGE, + seed=`__genthat_captured_seed`, + env=parent.frame(), + args=args, + retv=retv, + decorator="onexit" + ) + ), + list(ONEXIT=onexit, NAME=name, PACKAGE=package) + ) + } else { + NULL + } + + onerror_call <- if (!is.null(onerror)) { + substitute( + ONERROR( + list( + name=NAME, + package=PACKAGE, + seed=`__genthat_captured_seed`, + env=parent.frame(), + args=args, + message=geterrmessage(), + decorator="onerror" + ) + ), + list(ONERROR=onerror, NAME=name, PACKAGE=package) + ) + } else { + NULL + } + + epilogue <- if (!is.null(onexit_call) || !is.null(onerror_call)) { + + expr <- if (!is.null(onexit_call) && !is.null(onerror_call)) { + substitute( + if (!identical(retv, default)) { + onexit_call + } else { + onerror_call + } + ) + } else if (!is.null(onexit_call)) { + substitute( + if (!identical(retv, default)) { + onexit_call + } + ) + } else { + substitute( + if (identical(retv, default)) { + onerror_call + } + ) + } + + substitute( + on.exit({ + if (.Internal(getOption("genthat.tracing"))) { + .Internal(options(genthat.tracing=FALSE)) + + default <- genthat:::.genthat_default_retv + retv <- returnValue(default=default) + args <- as.list(match.call())[-1] + + expr + + .Internal(options(genthat.tracing=TRUE)) + } + }) + ) + } else { + NULL + } + + # this one will capture the first argument passed to `fun<-` + genthat_tmp <- if (endsWith(name, "<-")) { + substitute(`__genthat_tmp` <- ARG_NAME, list(ARG_NAME=as.name(names(formals(fun))[1]))) + } else { + NULL + } + + obody <- body(fun) + + # the epilogue is above the body since it will be run in the on.exit handler + nbody <- if (!is.null(prologue) && !is.null(epilogue)) { + if (is.null(genthat_tmp)) { + substitute({ + `__genthat_captured_seed` <- get(".Random.seed", envir=globalenv()) + + prologue + epilogue + obody + }) + } else { + substitute({ + `__genthat_captured_seed` <- get(".Random.seed", envir=globalenv()) + genthat_tmp + + prologue + epilogue + obody + }) + } + } else if (!is.null(prologue)) { + if (is.null(genthat_tmp)) { + substitute({ + `__genthat_captured_seed` <- get(".Random.seed", envir=globalenv()) + + prologue + obody + }) + } else { + substitute({ + `__genthat_captured_seed` <- get(".Random.seed", envir=globalenv()) + genthat_tmp + + prologue + obody + }) + } + } else if (!is.null(epilogue)) { + if (is.null(genthat_tmp)) { + substitute({ + `__genthat_captured_seed` <- get(".Random.seed", envir=globalenv()) + genthat_tmp + + epilogue + obody + }) + } else { + substitute({ + `__genthat_captured_seed` <- get(".Random.seed", envir=globalenv()) + genthat_tmp + + epilogue + obody + }) + } + } else { + stop("Not possible") + } + + # we do not copy attributes since we are only interested in + # the body of the function + create_function(params=formals(fun), body=nbody, env=environment(fun)) +} diff --git a/R/decorate.R b/R/decorate.R index 0ba0c179..3a99afa9 100644 --- a/R/decorate.R +++ b/R/decorate.R @@ -1,31 +1,3 @@ -#' @export -#' -create_decorator <- function(method="on.exit") { - fun <- if (is.character(method)) { - method <- match.arg(arg=method, choices=c("onentry", "onexit", "on.exit", "onboth", "trycatch", "count-entry", "count-exit", "noop"), several.ok=FALSE) - - switch(method, - onentry=decorate_with_onentry, - onexit=decorate_with_onexit, - on.exit=decorate_with_on.exit, - onboth=decorate_with_onboth, - trycatch=decorate_with_trycatch, - `count-entry`=decorate_with_count_entry, - `count-exit`=decorate_with_count_exit, - noop=decorate_with_noop - ) - } else if (is.function(method)) { - method - } else { - stop("Unknown type of method: ", typeof(method)) - } - - structure(list( - method=fun, - decorations=new.env(parent=emptyenv(), hash=TRUE) - ), class="decorator") -} - #' @title Decorates functions in an environment #' #' @param envir an environment that shall be decorated or a character scalar @@ -37,34 +9,17 @@ create_decorator <- function(method="on.exit") { #' `is.function` is `TRUE`. #' @export #' -decorate_environment <- function(env, - decorator=get_decorator(), - record_fun=substitute(genthat:::record_trace), - exclude=character()) { - stopifnot(is_decorator(decorator)) - - if (is.character(env)) { - stopifnot(length(env) == 1) - - log_debug("Loading namespace: ", env) - library(env, character.only=TRUE) - - env <- getNamespace(env) - } - +decorate_environment <- function(env, type=c("exported", "private", "all"), exclude=character(), ...) { + env <- resolve_env(env) stopifnot(is.environment(env)) - names <- ls(env, all.names=TRUE) - vals <- lapply(names, get, env=env) - names(vals) <- names - - funs <- filter(vals, is.function) + funs <- get_functions_from_env(env, type=type) funs <- funs[!(names(funs) %in% exclude)] res <- lapply(names(funs), function(name) { tryCatch({ fun <- funs[[name]] - decorate_function(fun, name=name, record_fun=record_fun, decorator=decorator, env=env) + decorate_function(name, ..., env=env) fun }, error=function(e) { e$message @@ -76,40 +31,40 @@ decorate_environment <- function(env, invisible(res) } -#' @title Decorates given functions +#' Decorates given functions +#' +#' Given function will be decorated in their defining environment. +#' +#' Primitive and S3 generic functions (the ones calling \code{UseMethod}) cannot +#' be traced. If a function has been already decorated, it will be reset and +#' decorated again. +#' +#' @param fun the function to decorate as a function reference or as function +#' name as string, in which case it will be looked up in the given \code{env} +#' @param onentry the function to be called on the \code{fun} entry +#' @param onexit the function to be called on the \code{fun} exit +#' @param onerror the function to be called on the \code{fun} error +#' @param env if \code{fun} is not given, resolve \code{name} in the given +#' \code{env} and up +#' #' -#' @param fun the function that shall be decorated #' -#' @description Given function will be decorated in their defining environment. #' @export #' -decorate_function <- function(fun, name=substitute(fun), - record_fun=substitute(genthat:::record_trace), - decorator=get_decorator(), env=parent.frame()) { - stopifnot(is_decorator(decorator)) - stopifnot(!missing(fun) || is_chr_scalar(name)) - - if (missing(fun)) { - fun <- NULL - } - - # TODO: check args +decorate_function <- function(fun, onentry=NULL, onexit=NULL, onerror=NULL, + env=parent.frame()) { if (is_tracing_enabled()) { disable_tracing() on.exit(enable_tracing()) } - resolved_fun <- resolve_function(name, fun, env) + resolved_fun <- resolve_function(fun, substitute(fun), env) fun <- resolved_fun$fun fqn <- resolved_fun$fqn name <- resolved_fun$name package <- resolved_fun$package - - # TODO: test - if (!is.function(fun)) { - stop(fqn, ": is not a function") - } + idx <- get_decoration_idx(fun, name, env) if (is.primitive(fun)) { stop(fqn, ": is a primitive function") @@ -119,100 +74,98 @@ decorate_function <- function(fun, name=substitute(fun), stop(fqn, ": is a S3 generic function") } - if (is_decorated(fun, fqn, decorator=decorator, env=env)) { - reset_function(fun, fqn, decorator=decorator, env=env) + if (exists(idx, envir=.decorations)) { + reset_function(fqn, env=env) } log_debug("Decorating function: ", name) - orig_fun <- create_duplicate(fun) - new_fun <- decorator$method(fun, name, package, record_fun) + ofun <- create_duplicate(fun) + nfun <- create_decorated_function( + fun=fun, + name=name, + package=package, + onentry=onentry, + onexit=onexit, + onerror=onerror + ) - reassign_function(fun, new_fun) + reassign_function(fun, nfun) - assign(fqn, list(fun=fun, orig=orig_fun), envir=decorator$decorations) + assign(idx, list(fqn=fqn, fun=fun, ofun=ofun), envir=.decorations) - invisible(NULL) + invisible(fqn) } -#' @title Resets decorated function back to its original + +#' Resets decorated function back to its original +#' +#' Reverts decorated function back to their state they were before calling +#' \code{decorate_function}. +#' +#' @param fun function or function name #' -#' @description Reverts decorated function back to their state they were before calling `decorate_function`. #' @export #' -reset_function <- function(fun, name=substitute(fun), decorator=get_decorator(), env=parent.frame()) { - stopifnot(is_decorator(decorator)) - stopifnot(!missing(fun) || is_chr_scalar(name)) - - if (missing(fun)) { - fun <- NULL - } - - resolved_fun <- resolve_function(name, fun, env) - - fun <- resolved_fun$fun - fqn <- resolved_fun$fqn - - if (!is_decorated(fun, fqn, decorator=decorator, env=env)) { - warning("Function ", fqn, " is not decorated") - return(NULL) +reset_function <- function(fun, env=parent.frame()) { + if (!is_decorated(fun, env)) { + warning(substitute(fun), ": is not decorated") + invisible(return(NULL)) + } else { + idx <- get_decoration_idx(fun, substitute(fun), env) + do_reset_function(idx) } +} - log_debug("Resetting decorated function: ", fqn) - - rec <- get(fqn, envir=decorator$decorations) +do_reset_function <- function(idx) { + decoration <- get(idx, envir=.decorations) + stopifnot(!is.null(decoration)) - reassign_function(fun, rec$orig) + log_debug("Resetting decorated function: ", decoration$fqn) - rm(list=fqn, envir=decorator$decorations) + reassign_function(decoration$fun, decoration$ofun) + rm(list=idx, envir=.decorations) - invisible(NULL) + invisible(decoration$fqn) } #' @export #' -is_decorated <- function(fun, name=substitute(fun), decorator=get_decorator(), env=parent.frame()) { - stopifnot(is_decorator(decorator)) - stopifnot(!missing(fun) || is_chr_scalar(name)) - - if (missing(fun)) { - fun <- NULL +reset_functions <- function() { + for (x in ls(envir=.decorations)) { + do_reset_function(x) } - - resolved_fun <- resolve_function(name, fun, env) - exists(resolved_fun$fqn, envir=decorator$decorations) } #' @export #' -set_decorator <- function(decorator) { - stopifnot(is_decorator(decorator)) - - options(genthat.decorator=decorator) - - invisible(decorator) +is_decorated <- function(fun, env=parent.frame()) { + exists(get_decoration_idx(fun, substitute(fun), env), envir=.decorations) } +#' Returns decorated functions +#' +#' Return a list of the decorated functions. +#' +#' @return a list where names are fully-qualified function names and values are +#' the decorated functions +#' #' @export #' -get_decorator <- function() { - decorator <- getOption("genthat.decorator") +get_decorations <- function() { + vals <- as.list(.decorations) - if (is.null(decorator)) { - decorator <- create_decorator() - set_decorator(decorator) - } - - decorator -} - -is_decorator <- function(x) { - inherits(x, "decorator") + names <- lapply(vals, `[[`, "fqn") + funs <- lapply(vals, `[[`, "fun") + names(funs) <- names + funs } -is_s3_generic <- function(fun) { - stopifnot(is.function(fun)) +get_decoration_idx <- function(fun, name, env=parent.frame()) { + if (!is.function(fun)) { + resolved_fun <- resolve_function(fun, name, env) + fun <- resolved_fun$fun + } - globals <- codetools::findGlobals(fun, merge = FALSE)$functions - any(globals == "UseMethod") + sexp_address(fun) } diff --git a/R/decorators.R b/R/decorators.R deleted file mode 100644 index 9f6e2bbf..00000000 --- a/R/decorators.R +++ /dev/null @@ -1,233 +0,0 @@ -check_decorate_args <- function(fun, name, pkg, record_fun) { - stopifnot(is.function(fun)) - stopifnot(is.character(name) && length(name) == 1) - stopifnot(is.null(pkg) || (is.character(pkg) && length(pkg) == 1)) -} - -decorate_with_onboth <- function(fun, name, pkg, record_fun) { - check_decorate_args(fun, name, pkg, record_fun) - - # The `retv <- BODY` is OK because in the case of multiple expressions, it - # will be surrounded with `{}`. - - # The reason why we use .Internal(...) is that in the case base library is - # decorated the `genthat::is_tracing_enabled` will invoke `::` and - # consecutively other functions making it an infinite loop - create_function( - params=formals(fun), - body=substitute({ - if (.Internal(getOption("genthat.tracing"))) { - .Internal(options(genthat.tracing=FALSE)) - RECORD_FUN(name=NAME, pkg=PKG, args=as.list(match.call())[-1], env=parent.frame()) - .Internal(options(genthat.tracing=TRUE)) - } - - `__retv` <- BODY - - if (.Internal(getOption("genthat.tracing"))) { - .Internal(options(genthat.tracing=FALSE)) - RECORD_FUN(name=NAME, pkg=PKG, args=as.list(match.call())[-1], retv=`__retv`, env=parent.frame()) - .Internal(options(genthat.tracing=TRUE)) - } - - `__retv` - }, list(NAME=name, PKG=pkg, RECORD_FUN=record_fun, BODY=body(fun))), - env=environment(fun), - attributes=list( - `__genthat_original_fun`=create_duplicate(fun) - ) - ) -} - -decorate_with_onentry <- function(fun, name, pkg, record_fun) { - check_decorate_args(fun, name, pkg, record_fun) - - create_function( - params=formals(fun), - body=substitute({ - if (.Internal(getOption("genthat.tracing"))) { - .Internal(options(genthat.tracing=FALSE)) - RECORD_FUN(name=NAME, pkg=PKG, args=as.list(match.call())[-1], env=parent.frame()) - .Internal(options(genthat.tracing=TRUE)) - } - - BODY - }, list(NAME=name, PKG=pkg, RECORD_FUN=record_fun, BODY=body(fun))), - env=environment(fun), - attributes=list( - `__genthat_original_fun`=create_duplicate(fun) - ) - ) -} - -decorate_with_onexit <- function(fun, name, pkg, record_fun) { - check_decorate_args(fun, name, pkg, record_fun) - - # The `retv <- BODY` is OK because in the case of multiple expressions, it will be surrounded with `{}`. - create_function( - params=formals(fun), - body=substitute({ - `__retv` <- BODY - - if (.Internal(getOption("genthat.tracing"))) { - .Internal(options(genthat.tracing=FALSE)) - - RECORD_FUN(name=NAME, pkg=PKG, args=as.list(match.call())[-1], retv=`__retv`, env=parent.frame()) - - .Internal(options(genthat.tracing=TRUE)) - } - - `__retv` - }, list(NAME=name, PKG=pkg, RECORD_FUN=record_fun, BODY=body(fun))), - env=environment(fun), - attributes=list( - `__genthat_original_fun`=create_duplicate(fun) - ) - ) -} - -decorate_with_count_entry <- function(fun, name, pkg, record_fun) { - check_decorate_args(fun, name, pkg, record_fun) - - create_function( - params=formals(fun), - body=substitute({ - genthat:::store_trace(genthat:::get_tracer(), genthat:::create_trace(NAME, PKG)) - BODY - }, list(NAME=name, PKG=pkg, BODY=body(fun))), - env=environment(fun), - attributes=list( - `__genthat_original_fun`=create_duplicate(fun) - ) - ) -} - -decorate_with_count_exit <- function(fun, name, pkg, record_fun) { - check_decorate_args(fun, name, pkg, record_fun) - - create_function( - params=formals(fun), - body=substitute({ - `__retv` <- BODY - genthat:::store_trace(genthat:::get_tracer(), genthat:::create_trace(NAME, PKG)) - `__retv` - }, list(NAME=name, PKG=pkg, BODY=body(fun))), - env=environment(fun), - attributes=list( - `__genthat_original_fun`=create_duplicate(fun) - ) - ) -} - -decorate_with_trycatch <- function(fun, name, pkg, record_fun) { - check_decorate_args(fun, name, pkg, record_fun) - - create_function( - params=formals(fun), - body=substitute({ - if (.Internal(getOption("genthat.tracing"))) { - .Internal(options(genthat.tracing=FALSE)) - - frame <- new.env(parent=parent.frame()) - assign(NAME, attr(sys.function(), "__genthat_original_fun"), envir=frame) - call <- sys.call() - call[[1]] <- as.name(NAME) - - tryCatch({ - .Internal(options(genthat.tracing=TRUE)) - retv <- eval(call, envir=frame) - - .Internal(options(genthat.tracing=FALSE)) - RECORD_FUN(name=NAME, pkg=PKG, args=as.list(match.call())[-1], retv=retv, env=parent.frame()) - .Internal(options(genthat.tracing=TRUE)) - - return(retv) - }, error=function(e) { - .Internal(options(genthat.tracing=FALSE)) - - depth <- getOption("genthat.tryCatchDepth") - env <- parent.frame(depth + 2) - match_call <- match.call( - definition=sys.function(-depth - 1), - call=sys.call(-depth - 1), - envir=env - ) - - RECORD_FUN(name=NAME, pkg=PKG, args=as.list(match_call)[-1], error=e, env=env) - .Internal(options(genthat.tracing=TRUE)) - - stop(e) - }) - } - - frame <- new.env(parent=parent.frame()) - assign(NAME, attr(sys.function(), "__genthat_original_fun"), envir=frame) - - call <- sys.call() - call[[1]] <- as.name(NAME) - - eval(call, envir=frame) - }, list( - NAME=name, - PKG=pkg, - RECORD_FUN=record_fun - )), - env=environment(fun), - attributes=list( - `__genthat_original_fun`=create_duplicate(fun) - ) - ) -} - -decorate_with_noop <- function(fun, name, pkg, record_fun) { - fun -} - -decorate_with_on.exit <- function(fun, name, pkg, record_fun) { - check_decorate_args(fun, name, pkg, record_fun) - - create_function( - params=formals(fun), - body=substitute({ - `__genthat_captured_seed` <- get(".Random.seed", envir=globalenv()) - TMP - on.exit({ - if (.Internal(getOption("genthat.tracing"))) { - .Internal(options(genthat.tracing=FALSE)) - default <- genthat:::`__genthat_default_retv` - retv <- returnValue(default=default) - if (!identical(retv, default) && !genthat:::is_exception_returnValue(retv)) { - RECORD_FUN( - name=NAME, - pkg=PKG, - args=as.list(match.call())[-1], - retv=retv, - seed=`__genthat_captured_seed`, - env=parent.frame() - ) - } - - .Internal(options(genthat.tracing=TRUE)) - } - }) - - BODY - }, list( - NAME=name, - PKG=pkg, - RECORD_FUN=record_fun, - BODY=body(fun), - TMP={ - if (endsWith(name, "<-")) { - substitute(`__genthat_tmp` <- ARG_NAME, list(ARG_NAME=as.name(names(formals(fun))[1]))) - } else { - "" - } - }) - ), - env=environment(fun), - attributes=list( - `__genthat_original_fun`=create_duplicate(fun) - ) - ) -} diff --git a/R/extract-package-code.R b/R/extract-package-code.R index 42e6a3f9..b5e6fecc 100644 --- a/R/extract-package-code.R +++ b/R/extract-package-code.R @@ -8,7 +8,7 @@ #' install the package. #' #' @param package the name of the package. -#' @param dir the path to the directory containing the source of the package +#' @param path the path to the directory containing the source of the package #' @param lib_paths a character vector describing the location of R library #' trees to search through when locating `package`, or `NULL`. The default #' value of `NULL`` corresponds to checking the loaded namespace, then all @@ -24,14 +24,14 @@ #' where the code has been extracted. The element names correspond to the #' elements in the types parameter. #' -#' @importFrom devtools as.package install_local +#' @importFrom devtools as.package #' @importFrom tools file_path_sans_ext #' @importFrom withr with_temp_libpaths #' #' @export #' # TODO: support commentDontrun, commentDonttest -extract_package_code <- function(package, dir, lib_paths=NULL, +extract_package_code <- function(package, path, lib_paths=NULL, types=c("examples", "tests", "vignettes", "all"), output_dir=".", filter=NULL) { @@ -40,49 +40,36 @@ extract_package_code <- function(package, dir, lib_paths=NULL, stopifnot(is_chr_scalar(output_dir)) stopifnot(is.null(filter) || is_chr_scalar(filter)) - if ((missing(package) && missing(dir)) - || (!missing(package) && !missing(dir))) { - stop("Either package or dir must be provided") + if ((missing(package) && missing(path)) + || (!missing(package) && !missing(path))) { + stop("Either package or path must be provided") } - if ("all" %in% types) { - types <- c("examples", "tests", "vignettes") - } - types <- match.arg(types, c("examples", "tests", "vignettes"), several.ok=TRUE) + types <- match_types(types) # so the return list is named names(types) <- types files <- if (!missing(package)) { # extracting from package / lib_paths - if (!missing(dir)) stop("you must specify either 'package' or 'dir'") + if (!missing(path)) stop("you must specify either 'package' or 'path'") extract_code(package, lib_paths=lib_paths, types=types, output_dir=output_dir) - } else if (!missing(dir)) { + } else if (!missing(path)) { # extracting from source if (!missing(lib_paths)) stop("'lib_paths' are only used with 'package' option") - pkg <- devtools::as.package(dir) + pkg <- devtools::as.package(path) withr::with_temp_libpaths({ - # install package to the temp lib with all code - devtools::install_local( - dir, - build_vignettes=("vignettes" %in% types), - keep_source=TRUE, - INSTALL_opts=c( - if ("examples" %in% types) "--example" else character(), - if ("tests" %in% types) "--install-tests" else character() - ), - quiet=TRUE - ) + install_package(path, types) # by passing NULL we rely on the .libPaths() which should be set to - # a temp dir + # a temp path extract_code(pkg$package, lib_paths=NULL, types=types, output_dir=output_dir) }) } else { - stop("you must specify 'package' or 'dir'") + stop("you must specify 'package' or 'path'") } if (!is.null(filter)) { diff --git a/R/genthat.R b/R/genthat.R index d650400f..d9f50c3c 100644 --- a/R/genthat.R +++ b/R/genthat.R @@ -12,9 +12,13 @@ NULL #' default it runs package examples, tests and vignettes. #' #' @param path file path to the package. -#' @param from a character vector indicating which package(s) code shall be used -#' to extract the code from. Default `NULL` stands for the package in -#' `path`. +#' @param from a character vector of package names, from which code shall be +#' used to extract the code from. Default \code{NULL} stands for the package +#' in `path`. For non-\code{NULL} values, the packages shall be installed +#' with the appropriate options, i.e. \code{INSTALL_opts('--example', +#' '--install-tests)} in order to contain the required code. For +#' \code{NULL}, the package will be installed with the appropriate options +#' based on the \code{types}. #' @param types which code artifacts to run from the `from` packages, #' 'examples', 'tests', 'vignettes' or 'all' #' @@ -33,31 +37,50 @@ NULL gen_from_package <- function(path, from=NULL, types=c("examples", "tests", "vignettes", "all"), filter=NULL, ...) { stopifnot(is_chr_scalar(path) && dir.exists(path)) + path <- normalizePath(path, mustWork=TRUE) + package <- as.package(path)$package + install_path <- tryCatch(find.package(package), error=function(e) NULL) + temp_dir <- tempfile(pattern="genthat-gen_from_package") on.exit(unlink(temp_dir, recursive=TRUE)) - files <- if (is.null(from)) { - # the extract_package_code only work on packages that are installed - # we need to install the package if it has not yet been installed - extract_package_code(dir=path, types=types, output_dir=temp_dir, filter=filter) - } else { - lapply(from, extract_package_code, types=types, output_dir=temp_dir, filter=filter) - } + phase2 <- function() { + files <- if (is.null(from)) { + # the extract_package_code only work on packages that are installed + # we need to install the package if it has not yet been installed + extract_package_code(package=package, types=types, output_dir=temp_dir, filter=filter) + } else { + lapply(from, extract_package_code, types=types, output_dir=temp_dir, filter=filter) + } - files <- unlist(files, use.names=FALSE) + files <- unlist(files, use.names=FALSE) - if (length(files) == 0) { - if (is.null(from)) { - warning("The package does not contain any runnable code in ", paste(types, sep=",")) - } else { - warning("No runnable code was found, make sure that the `from` packages were installed with ", + if (length(files) == 0) { + if (is.null(from)) { + warning("The package does not contain any runnable code in ", paste(types, sep=",")) + } else { + warning("No runnable code was found, make sure that the `from` packages were installed with ", "`INSTALL_opts=c('--example', '--install-tests')") + } + + # TODO: is this correct? + data.frame(file=character(), output=character(), error=character()) + } else { + gen_from_source(path, files=files, ...) } + } - # TODO: is this correct? - data.frame(file=character(), output=character(), error=character()) + if (!is.null(install_path)) { + # package has been already installed + phase2() } else { - gen_from_source(path, files=files, ...) + # we first need to install the package + withr::with_temp_libpaths({ + log_debug("Installing package from path ", path, " into temporary location ", .libPaths[1]) + install_package(path, types) + + phase2() + }) } } @@ -67,8 +90,10 @@ gen_from_source <- function(path, files, action, output_dir, prune_tests=TRUE, q stopifnot(action != "generate" || prune_tests) package <- devtools::as.package(path) + + # TODO: add a flag to trace only exported functions tracing <- trace_package( - packages=package$package, + package=package$package, files=files, action=action, output_dir=output_dir, @@ -226,132 +251,6 @@ gen_from_source <- function(path, files, action, output_dir, prune_tests=TRUE, q } -#' Decorate all functions from given package and runs package code -#' -#' Decorates all functions in a package and then generates test cases based on -#' the code contained in the package examples, vignettes and tests. -#' -#' @param packages chr vector of package names whose functions should be traced. -#' All the packages need to be installed in the `lib_paths`. -#' @param files chr vector of paths to R files that shall be run -#' @param output_dir the name of the directory where to output traces or NULL if -#' traces should not be saved -#' -#' @importFrom utils read.csv -#' -#' @export -#' -# TODO: this shall call trace_functions -trace_package <- function(packages, files, - output_dir=".", - decorator="on.exit", tracer="set", - action=c("stats", "export", "generate"), - working_dir=tempfile(pattern="genthat-trace-"), - quiet=TRUE, lib_paths=NULL) { - - stopifnot(is.character(files)) - if (length(files) == 0) { - return(character()) - } - - if (is.null(names(files))) { - names(files) <- files - } - - stopifnot(is.character(packages), length(packages) > 0) - # check if packages exists in the provided libraries - find.package(packages, lib_paths) - - # both output_dir and working_dir must be absolute because the future R - # instances will be run from the dirs where the files are - stopifnot(is_chr_scalar(output_dir)) - stopifnot(dir.exists(output_dir) || dir.create(output_dir, recursive=TRUE)) - output_dir <- normalizePath(output_dir, mustWork=TRUE) - - stopifnot(is_chr_scalar(working_dir)) - stopifnot(dir.exists(working_dir) || dir.create(working_dir)) - working_dir <- normalizePath(working_dir, mustWork=TRUE) - - action <- match.arg(action, c("stats", "export", "generate"), several.ok=FALSE) - - # TODO: check tracer - # TODO: check decorator - - # used for export traces during run - stats_file <- tempfile("genthat-tracing", tmpdir=working_dir, fileext=".csv") - set_tracer_session_file <- tempfile("set-tracer-session", tmpdir=working_dir, fileext=".RDS") - on.exit({ - if (file.exists(stats_file)) file.remove(stats_file) - if (file.exists(set_tracer_session_file)) file.remove(set_tracer_session_file) - }) - - run_file <- function(fname) { - log_debug("Running ", fname, " ...") - - env <- c() - site_file <- NULL - - if (length(decorator) == 0 || decorator == "none") { - decorator <- NULL - } - - # this is to support a simple run of the files without any genthat involved - if (!is.null(decorator)) { - vars <- list() - - vars$debug <- is_debug_enabled() - vars$keep_all_traces <- getOption("genthat.keep_all_traces", FALSE) - vars$keep_failed_traces <- getOption("genthat.keep_failed_traces", FALSE) - - vars$decorator <- decorator - vars$tracer <- tracer - vars$session_file <- set_tracer_session_file - vars$action <- action - vars$current_file <- fname - vars$output_dir <- output_dir - vars$stats_file <- stats_file - vars$max_trace_size <- getOption("genthat.max_trace_size", .Machine$integer.max) - vars$packages <- paste(packages, sep=",") - - # convert the variables to the expected format GENTHAT_= - env <- sapply(names(vars), function(x) { - paste(toupper(paste0("genthat_", x)), as.character(vars[[x]]), sep="=") - }, USE.NAMES=FALSE) - - site_file <- system.file("genthat-tracing-site-file.R", package="genthat") - } - - if (!file.exists(fname)) { - paste(fname, "does not exist") - } else { - tryCatch({ - run <- run_r_script(fname, site_file=site_file, env=env, quiet=quiet, lib_paths=lib_paths) - - if (file.exists(stats_file)) { - # running of the file might have failed, but still some traces - # might have been generated - - # TODO: do we want to indicate somewhere that the running has failed? - st <- read.csv(stats_file, stringsAsFactors=FALSE) - file.remove(stats_file) - st - } else { - # Running either failed or there were no calls to the traced - # functions (e.g. a data file) so the finalizer exporting the - # traces did not kicked in. based on the status we can figure - # out what has happened. - run - } - }, error=function(e) { - e$message - }) - } - } - - log_debug("Running ", length(files), " files") - lapply(files, run_file) -} - save_trace_file <- function(trace, output_dir, name) { pkg <- if (is.null(trace$pkg)) "_NULL_" else trace$pkg fun <- if (is.null(trace$fun)) "_NULL_" else trace$fun diff --git a/R/helpers.R b/R/helpers.R index 0a649f00..8046789a 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -103,11 +103,15 @@ is_empty_str <- function(s) { split_function_name <- function(name) { stopifnot(!is_empty_str(name)) - x <- strsplit(name, ":")[[1]] - if (length(x) == 1) { - list(package=NULL, name=x[1]) + if (name == "::" || name == ":::") { + list(package="base", name=name) } else { - list(package=x[1], name=x[length(x)]) + x <- strsplit(name, ":")[[1]] + if (length(x) == 1) { + list(package=NULL, name=x[1]) + } else { + list(package=x[1], name=x[length(x)]) + } } } @@ -257,13 +261,30 @@ capture <- function(expr, split=FALSE) { ) } -# resolve_function(f, name="f") -# resolve_function(name="f") -# -resolve_function <- function(name, fun=NULL, env=parent.frame()) { +resolve_function <- function(fun, name, env=parent.frame()) { + stopifnot(!is.null(fun)) + stopifnot(!is.null(name)) stopifnot(is.environment(env)) - if (is_chr_scalar(name)) { + if (!is.function(fun)) { + name <- fun + } + + if (is.name(name)) { + name <- as.character(name) + } + + if (is.call(name)) { + # function call in the language + lang <- name + f_name <- as.character(lang[[1]]) + if (f_name == "::" || f_name == ":::") { + name <- as.character(lang[[3]]) + package <- as.character(lang[[2]]) + } else { + stop("resolve_function: cannot parse function name from: ", name) + } + } else if (is_chr_scalar(name)) { names <- split_function_name(name) name <- names$name package <- names$package @@ -271,37 +292,20 @@ resolve_function <- function(name, fun=NULL, env=parent.frame()) { if (!is.null(package)) { env <- getNamespace(package) } + } else { + stop(typeof(fun), ": unsupported type") + } - if (is.null(fun)) { - if (!exists(name, envir=env)) { - stop("Function: ", name, " does not exist in environment: ", env); - } else { - fun <- get(name, envir=env) - } - } - - if (is.null(package)) { - package <- resolve_package_name(fun, name) - } - } else if (is.name(name) || is.language(name)) { - if (is.null(fun)) { - stop("resolve_function: symbol/language name object needs additionally fun parameter") - } - - if (is.name(name)) { - name <- as.character(name) - package <- resolve_package_name(fun, name) + if (!is.function(fun)) { + if (!exists(name, envir=env)) { + stop("Function: ", name, " does not exist in environment: ", env); } else { - f_name <- as.character(name[[1]]) - if (f_name == "::" || f_name == ":::") { - package <- as.character(name[[2]]) - name <- as.character(name[[3]]) - } else { - stop("resolve_function: cannot parse function name from: ", name) - } + fun <- get(name, envir=env) } - } else { - stop("resolve_function: unsupported parameter combination") + } + + if (is.null(package)) { + package <- resolve_package_name(fun, name) } if (!is.null(package)) { @@ -313,6 +317,7 @@ resolve_function <- function(name, fun=NULL, env=parent.frame()) { } fqn <- get_function_fqn(package, name) + return(list(fqn=fqn, name=name, package=package, fun=fun)) } @@ -355,6 +360,8 @@ get_function_fqn <- function(package, name) { stopifnot(is.null(package) || is_chr_scalar(package)) stopifnot(is_chr_scalar(name)) + name <- escape_name(name) + if (is.null(package)) { name } else { @@ -465,3 +472,71 @@ compute_coverage <- function(...) { # compute the percentage (sum(coverage_df$value > 0) / length(coverage_df$value)) * 100 } + +is_s3_generic <- function(fun) { + stopifnot(is.function(fun)) + + globals <- codetools::findGlobals(fun, merge = FALSE)$functions + any(globals == "UseMethod") +} + +resolve_env <- function(env) { + if (is.character(env)) { + stopifnot(length(env) == 1) + + log_debug("Loading namespace: ", env) + library(env, character.only=TRUE) + + env <- getNamespace(env) + } + + env +} + +get_functions_from_env <- function(env, type=c("exported", "private", "all")) { + env <- resolve_env(env) + stopifnot(is.environment(env)) + + type <- match.arg(type, c("exported", "private", "all"), several.ok=FALSE) + + names <- switch( + type, + exported=getNamespaceExports(env), + private=ls(env, all.names=FALSE), + all=ls(env, all.names=TRUE) + ) + + vals <- lapply(names, get, env=env) + names(vals) <- names + + funs <- filter(vals, is.function) +} + +match_types <- function(types) { + if ("all" %in% types) { + types <- c("examples", "tests", "vignettes") + } + + match.arg(types, c("examples", "tests", "vignettes"), several.ok=TRUE) +} + +#' @return the name of the installed package +#' +#' @importFrom devtools install_local +#' +install_package <- function(path, types=c("examples", "tests", "vignettes", "all")) { + types <- match_types(types) + + devtools::install_local( + path, + build_vignettes=("vignettes" %in% types), + keep_source=TRUE, + INSTALL_opts=c( + if ("examples" %in% types) "--example" else character(), + if ("tests" %in% types) "--install-tests" else character() + ), + quiet=TRUE + ) + + as.package(path)$package +} diff --git a/R/trace-package.R b/R/trace-package.R new file mode 100644 index 00000000..2edb1904 --- /dev/null +++ b/R/trace-package.R @@ -0,0 +1,112 @@ +#' Decorate all functions from given package and runs package code +#' +#' Decorates all functions in a package and then generates test cases based on +#' the code contained in the package examples, vignettes and tests. +#' +#' @param packages chr vector of package names whose functions should be traced. +#' All the packages need to be installed in the `lib_paths`. +#' @param files chr vector of paths to R files that shall be run +#' @param output_dir the name of the directory where to output traces or NULL if +#' traces should not be saved +#' +#' @importFrom utils read.csv +#' +#' @export +#' +# TODO: this shall call trace_functions +trace_package <- function(packages, files, + output_dir=".", + action=c("stats", "export", "generate"), + working_dir=tempfile(pattern="genthat-trace-"), + quiet=TRUE, lib_paths=NULL) { + + stopifnot(is.character(files)) + if (length(files) == 0) { + return(character()) + } + + if (is.null(names(files))) { + names(files) <- files + } + + stopifnot(is.character(packages), length(packages) > 0) + # check if packages exists in the provided libraries + find.package(packages, lib_paths) + + # both output_dir and working_dir must be absolute because the future R + # instances will be run from the dirs where the files are + stopifnot(is_chr_scalar(output_dir)) + stopifnot(dir.exists(output_dir) || dir.create(output_dir, recursive=TRUE)) + output_dir <- normalizePath(output_dir, mustWork=TRUE) + + stopifnot(is_chr_scalar(working_dir)) + stopifnot(dir.exists(working_dir) || dir.create(working_dir)) + working_dir <- normalizePath(working_dir, mustWork=TRUE) + + action <- match.arg(action, c("stats", "export", "generate"), several.ok=FALSE) + + # TODO: check tracer + # TODO: check decorator + + # used for export traces during run + stats_file <- tempfile("genthat-tracing", tmpdir=working_dir, fileext=".csv") + set_tracer_session_file <- tempfile("set-tracer-session", tmpdir=working_dir, fileext=".RDS") + on.exit({ + if (file.exists(stats_file)) file.remove(stats_file) + if (file.exists(set_tracer_session_file)) file.remove(set_tracer_session_file) + }) + + run_file <- function(fname) { + log_debug("Running ", fname, " ...") + + # TODO: all this should go into an RDS file + vars <- list() + vars$debug <- is_debug_enabled() + vars$keep_all_traces <- getOption("genthat.keep_all_traces", FALSE) + vars$keep_failed_traces <- getOption("genthat.keep_failed_traces", FALSE) + vars$tracer_type <- getOption("genthat.tracer_type") + vars$session_file <- set_tracer_session_file + vars$action <- action + vars$current_file <- fname + vars$output_dir <- output_dir + vars$stats_file <- stats_file + vars$max_trace_size <- getOption("genthat.max_trace_size", .Machine$integer.max) + vars$packages <- paste(packages, sep=",") + + # convert the variables to the expected format GENTHAT_= + env <- sapply(names(vars), function(x) { + paste(toupper(paste0("genthat_", x)), as.character(vars[[x]]), sep="=") + }, USE.NAMES=FALSE) + + site_file <- system.file("genthat-tracing-site-file.R", package="genthat") + + if (!file.exists(fname)) { + paste(fname, "does not exist") + } else { + tryCatch({ + run <- run_r_script(fname, site_file=site_file, env=env, quiet=quiet, lib_paths=lib_paths) + + if (file.exists(stats_file)) { + # running of the file might have failed, but still some traces + # might have been generated + + # TODO: do we want to indicate somewhere that the running has failed? + st <- read.csv(stats_file, stringsAsFactors=FALSE) + file.remove(stats_file) + st + } else { + # Running either failed or there were no calls to the traced + # functions (e.g. a data file) so the finalizer exporting the + # traces did not kicked in. based on the status we can figure + # out what has happened. + run + } + }, error=function(e) { + e$message + }) + } + } + + log_debug("Running ", length(files), " files") + lapply(files, run_file) +} diff --git a/R/traces.R b/R/trace.R similarity index 100% rename from R/traces.R rename to R/trace.R diff --git a/R/tracer.R b/R/tracer.R index cbad2e2a..61f8faab 100644 --- a/R/tracer.R +++ b/R/tracer.R @@ -1,17 +1,9 @@ -#' @export +#' Stores trace #' -create_tracer <- function(type="set", ...) { - type <- match.arg(arg=type, choices=c("sequence", "set"), several.ok=FALSE) - fun <- switch(type, - sequence=create_sequence_tracer, - set=create_set_tracer - ) - - fun(...) -} - -#' @name Store tracer -#' @title Stores given trace to the tracer +#' Stores the given \code{trace} to the given \code{tracer}. +#' +#' @param tracer the tracer to store the \code{trace} into +#' @param trace the trace to be store #' #' @export #' @@ -19,8 +11,9 @@ store_trace <- function(tracer, trace) { UseMethod("store_trace") } -#' @name Reset traces -#' @title Clears the captured traces +#' Reset traces +#' +#' Clears the captured traces #' #' @export #' @@ -28,8 +21,9 @@ reset_traces <- function(tracer) { UseMethod("reset_traces") } -#' @name Copy call traces -#' @title Creates a copy of traces captured so far and returns them as R list. +#' Copy call traces +#' +#' Creates a copy of traces captured so far and returns them as R list. #' #' @export #' @@ -42,6 +36,7 @@ copy_traces <- function(tracer) { copy_traces.default <- function(tracer) { tracer <- get_tracer() stopifnot(!is.null(tracer)) + copy_traces(tracer) } @@ -50,23 +45,72 @@ copy_traces.default <- function(tracer) { reset_traces.default <- function(tracer) { tracer <- get_tracer() stopifnot(!is.null(tracer)) + reset_traces(tracer) } +#' Creates a new tracer of the given type. +#' +#' Creates either a set tracer that only stores unique traces (unique +#' combination of function/package name, argument values and return value) or +#' sequence tracer that stores all traces. +#' +#' @param type the type of the tracer, can e either \code{set} of +#' \code{sequence}. The default is what is set in +#' \code{genthat.tracer_type} option. +#' +#' @param ... additional parameters to be passed to the function creating the +#' #actual tracer +#' +#' @seealso \code{\link{create_set_tracer}} +#' @seealso \code{\link{create_sequence_tracer}} +#' +#' @export +#' +create_tracer <- function(type=getOption("genthat.tracer_type"), ...) { + type <- match.arg(arg=type, choices=c("sequence", "set"), several.ok=FALSE) + fun <- switch(type, + sequence=create_sequence_tracer, + set=create_set_tracer + ) + + fun(...) +} + +#' Makes the given \code{tracer} default +#' +#' Sets the given tracer to be the one used for tracing from now on. +#' +#' @param tracer the tracer that shall become the default one +#' +#' @return the previous tracer or \code{NULL} if no tracer has been set +#' yet. +#' #' @export #' set_tracer <- function(tracer) { stopifnot(!is.null(tracer)) - options(genthat.tracer=tracer) + prev <- .genthat$tracer + .genthat$tracer <- tracer - invisible(tracer) + invisible(prev) } +#' Gets the currently used tracer +#' +#' Returns the current tracer. If no such tracer exists, it will create one by +#' calling \code{create_tracer()} with no arguments, i.e. using the default +#' settings. +#' +#' @return the current tracer +#' +#' @seealso \code{\link{create_tracer()}} +#' #' @export #' get_tracer <- function() { - tracer <- getOption("genthat.tracer") + tracer <- .genthat$tracer if (is.null(tracer)) { tracer <- create_tracer() diff --git a/R/zzz.R b/R/zzz.R index 8f59a912..c38a5c60 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,32 +1,32 @@ Rcpp::loadModule("SerializerModule", TRUE) -# private genthat space -`__genthat_default_retv` <- new.env(parent=emptyenv()) +# used to compare return value from returnValue() +.genthat_default_retv <- new.env(parent=emptyenv()) + +# store all functions decorations +.decorations <- new.env(parent=emptyenv()) + +# used for some private values +# - tracer: current tracer used to store traces +.genthat <- new.env(parent=emptyenv()) .onLoad <- function(libname, pkgname) { # this is just initialize the random generator so the .Random.seed is available set.seed(42) - options(genthat.debug=getOption("genthat.debug", default=FALSE)) - options(genthat.tryCatchDepth=try_catch_stack_depth()) - options(genthat.keep_failed_tests=getOption("genthat.keep_failed_tests", FALSE)) - options(genthat.keep_failed_traces=getOption("genthat.keep_failed_traces", FALSE)) - options(genthat.keep_all_traces=getOption("genthat.keep_all_traces", FALSE)) - options(genthat.max_trace_size=getOption("genthat.max_trace_size", 512*1024)) - options(genthat.source_paths=getOption("genthat.source_paths", Sys.getenv("GENTHAT_SOURCE_PATHS"))) + + # it will be create by need when tracing + .genthat$tracer <- NULL + + options( + genthat.debug=getOption("genthat.debug", default=FALSE), + genthat.tracer_type=getOption("genthat.tracer_type", default="set"), + genthat.keep_failed_tests=getOption("genthat.keep_failed_tests", FALSE), + genthat.keep_failed_traces=getOption("genthat.keep_failed_traces", FALSE), + genthat.keep_all_traces=getOption("genthat.keep_all_traces", FALSE), + genthat.max_trace_size=getOption("genthat.max_trace_size", 512*1024) + ) enable_tracing() invisible() } - -# finds how depth is try catch call -try_catch_stack_depth <- function() { - tryCatch({ - stop() - }, error=function(e) { - call_stack <- sapply(sys.calls(), '[[', 1) - idx <- max(which(call_stack == as.name("tryCatch"))) - stopifnot(length(idx) == 1) - abs(idx - sys.nframe()) - }) -} diff --git a/inst/genthat-tracing-site-file.R b/inst/genthat-tracing-site-file.R index caac3997..30870418 100644 --- a/inst/genthat-tracing-site-file.R +++ b/inst/genthat-tracing-site-file.R @@ -8,9 +8,7 @@ options(genthat.keep_failed_traces=as.logical(Sys.getenv("GENTHAT_KEEP_FAILED_TR options(genthat.keep_all_traces=as.logical(Sys.getenv("GENTHAT_KEEP_ALL_TRACES", "FALSE"))) options(genthat.max_trace_size=as.integer(Sys.getenv("GENTHAT_MAX_TRACE_SIZE"))) -genthat::set_decorator(genthat::create_decorator(Sys.getenv("GENTHAT_DECORATOR"))) - -if (Sys.getenv("GENTHAT_TRACER") == "set") { +if (Sys.getenv("GENTHAT_TRACER_TYPE") == "set") { local({ session_file <- Sys.getenv("GENTHAT_SESSION_FILE") if (nchar(session_file) == 0) { @@ -18,20 +16,18 @@ if (Sys.getenv("GENTHAT_TRACER") == "set") { } genthat::set_tracer( - genthat::create_tracer( - "set", - session_file=session_file - ) + genthat::create_tracer("set", session_file=session_file) ) }) } else { - genthat::set_tracer(genthat::create_tracer(Sys.getenv("GENTHAT_TRACER"))) + genthat::set_tracer(genthat::create_tracer(Sys.getenv("GENTHAT_TRACER_TYPE"))) } library(methods) +# TODO: a temp file with all the functions to be decorated for (package in strsplit(Sys.getenv("GENTHAT_PACKAGES"), ",", fixed=TRUE)[[1]]) { - genthat::decorate_environment(package) + genthat::decorate_environment(package, type="all", onexit=genthat::record_trace) } reg.finalizer( diff --git a/man/Store-tracer.Rd b/man/Store-tracer.Rd deleted file mode 100644 index 40dd5d63..00000000 --- a/man/Store-tracer.Rd +++ /dev/null @@ -1,9 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tracer.R -\name{Store tracer} -\alias{Store tracer} -\alias{store_trace} -\title{Stores given trace to the tracer} -\usage{ -store_trace(tracer, trace) -} diff --git a/man/Copy-call-traces.Rd b/man/copy_traces.Rd similarity index 51% rename from man/Copy-call-traces.Rd rename to man/copy_traces.Rd index 23416970..891dfe59 100644 --- a/man/Copy-call-traces.Rd +++ b/man/copy_traces.Rd @@ -1,9 +1,11 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/tracer.R -\name{Copy call traces} -\alias{Copy call traces} +\name{copy_traces} \alias{copy_traces} -\title{Creates a copy of traces captured so far and returns them as R list.} +\title{Copy call traces} \usage{ copy_traces(tracer) } +\description{ +Creates a copy of traces captured so far and returns them as R list. +} diff --git a/man/create_tracer.Rd b/man/create_tracer.Rd new file mode 100644 index 00000000..9fcdb426 --- /dev/null +++ b/man/create_tracer.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tracer.R +\name{create_tracer} +\alias{create_tracer} +\title{Creates a new tracer of the given type.} +\usage{ +create_tracer(type = getOption("genthat.tracer_type"), ...) +} +\arguments{ +\item{type}{the type of the tracer, can e either \code{set} of +\code{sequence}. The default is what is set in +\code{genthat.tracer_type} option.} + +\item{...}{additional parameters to be passed to the function creating the +#actual tracer} +} +\description{ +Creates either a set tracer that only stores unique traces (unique +combination of function/package name, argument values and return value) or +sequence tracer that stores all traces. +} +\seealso{ +\code{\link{create_set_tracer}} + +\code{\link{create_sequence_tracer}} +} diff --git a/man/decorate_environment.Rd b/man/decorate_environment.Rd index 0005e6c0..0ba0191c 100644 --- a/man/decorate_environment.Rd +++ b/man/decorate_environment.Rd @@ -4,8 +4,8 @@ \alias{decorate_environment} \title{Decorates functions in an environment} \usage{ -decorate_environment(env, decorator = get_decorator(), - record_fun = substitute(genthat:::record_trace), exclude = character()) +decorate_environment(env, type = c("exported", "private", "all"), + exclude = character(), ...) } \arguments{ \item{envir}{an environment that shall be decorated or a character scalar diff --git a/man/decorate_function.Rd b/man/decorate_function.Rd index c07d7dc4..9a6d94b9 100644 --- a/man/decorate_function.Rd +++ b/man/decorate_function.Rd @@ -4,13 +4,27 @@ \alias{decorate_function} \title{Decorates given functions} \usage{ -decorate_function(fun, name = substitute(fun), - record_fun = substitute(genthat:::record_trace), - decorator = get_decorator(), env = parent.frame()) +decorate_function(fun, onentry = NULL, onexit = NULL, onerror = NULL, + env = parent.frame()) } \arguments{ -\item{fun}{the function that shall be decorated} +\item{fun}{the function to decorate as a function reference or as function +name as string, in which case it will be looked up in the given \code{env}} + +\item{onentry}{the function to be called on the \code{fun} entry} + +\item{onexit}{the function to be called on the \code{fun} exit} + +\item{onerror}{the function to be called on the \code{fun} error} + +\item{env}{if \code{fun} is not given, resolve \code{name} in the given +\code{env} and up} } \description{ Given function will be decorated in their defining environment. } +\details{ +Primitive and S3 generic functions (the ones calling \code{UseMethod}) cannot +be traced. If a function has been already decorated, it will be reset and +decorated again. +} diff --git a/man/extract_package_code.Rd b/man/extract_package_code.Rd index 1770b763..3b274e58 100644 --- a/man/extract_package_code.Rd +++ b/man/extract_package_code.Rd @@ -4,13 +4,13 @@ \alias{extract_package_code} \title{Extracts code from examples, tests and/or vignettes for a given package.} \usage{ -extract_package_code(package, dir, lib_paths = NULL, types = c("examples", +extract_package_code(package, path, lib_paths = NULL, types = c("examples", "tests", "vignettes", "all"), output_dir = ".", filter = NULL) } \arguments{ \item{package}{the name of the package.} -\item{dir}{the path to the directory containing the source of the package} +\item{path}{the path to the directory containing the source of the package} \item{lib_paths}{a character vector describing the location of R library trees to search through when locating `package`, or `NULL`. The default diff --git a/man/gen_from_package.Rd b/man/gen_from_package.Rd index 7bd5f333..955db9b2 100644 --- a/man/gen_from_package.Rd +++ b/man/gen_from_package.Rd @@ -10,9 +10,13 @@ gen_from_package(path, from = NULL, types = c("examples", "tests", \arguments{ \item{path}{file path to the package.} -\item{from}{a character vector indicating which package(s) code shall be used -to extract the code from. Default `NULL` stands for the package in -`path`.} +\item{from}{a character vector of package names, from which code shall be +used to extract the code from. Default \code{NULL} stands for the package +in `path`. For non-\code{NULL} values, the packages shall be installed +with the appropriate options, i.e. \code{INSTALL_opts('--example', +'--install-tests)} in order to contain the required code. For +\code{NULL}, the package will be installed with the appropriate options +based on the \code{types}.} \item{types}{which code artifacts to run from the `from` packages, 'examples', 'tests', 'vignettes' or 'all'} diff --git a/man/get_decorations.Rd b/man/get_decorations.Rd new file mode 100644 index 00000000..2fc4938a --- /dev/null +++ b/man/get_decorations.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/decorate.R +\name{get_decorations} +\alias{get_decorations} +\title{Returns decorated functions} +\usage{ +get_decorations() +} +\value{ +a list where names are fully-qualified function names and values are + the decorated functions +} +\description{ +Return a list of the decorated functions. +} diff --git a/man/get_tracer.Rd b/man/get_tracer.Rd new file mode 100644 index 00000000..5df00da5 --- /dev/null +++ b/man/get_tracer.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tracer.R +\name{get_tracer} +\alias{get_tracer} +\title{Gets the currently used tracer} +\usage{ +get_tracer() +} +\value{ +the current tracer +} +\description{ +Returns the current tracer. If no such tracer exists, it will create one by +calling \code{create_tracer()} with no arguments, i.e. using the default +settings. +} +\seealso{ +\code{\link{create_tracer()}} +} diff --git a/man/reset_function.Rd b/man/reset_function.Rd index e74780ea..68859989 100644 --- a/man/reset_function.Rd +++ b/man/reset_function.Rd @@ -4,9 +4,12 @@ \alias{reset_function} \title{Resets decorated function back to its original} \usage{ -reset_function(fun, name = substitute(fun), decorator = get_decorator(), - env = parent.frame()) +reset_function(fun, env = parent.frame()) +} +\arguments{ +\item{fun}{function or function name} } \description{ -Reverts decorated function back to their state they were before calling `decorate_function`. +Reverts decorated function back to their state they were before calling +\code{decorate_function}. } diff --git a/man/Reset-traces.Rd b/man/reset_traces.Rd similarity index 62% rename from man/Reset-traces.Rd rename to man/reset_traces.Rd index 2226f997..a85de212 100644 --- a/man/Reset-traces.Rd +++ b/man/reset_traces.Rd @@ -1,9 +1,11 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/tracer.R -\name{Reset traces} -\alias{Reset traces} +\name{reset_traces} \alias{reset_traces} -\title{Clears the captured traces} +\title{Reset traces} \usage{ reset_traces(tracer) } +\description{ +Clears the captured traces +} diff --git a/man/set_tracer.Rd b/man/set_tracer.Rd new file mode 100644 index 00000000..0a3d54a7 --- /dev/null +++ b/man/set_tracer.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tracer.R +\name{set_tracer} +\alias{set_tracer} +\title{Makes the given \code{tracer} default} +\usage{ +set_tracer(tracer) +} +\arguments{ +\item{tracer}{the tracer that shall become the default one} +} +\value{ +the previous tracer or \code{NULL} if no tracer has been set + yet. +} +\description{ +Sets the given tracer to be the one used for tracing from now on. +} diff --git a/man/store_trace.Rd b/man/store_trace.Rd new file mode 100644 index 00000000..06340b88 --- /dev/null +++ b/man/store_trace.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tracer.R +\name{store_trace} +\alias{store_trace} +\title{Stores trace} +\usage{ +store_trace(tracer, trace) +} +\arguments{ +\item{tracer}{the tracer to store the \code{trace} into} + +\item{trace}{the trace to be store} +} +\description{ +Stores the given \code{trace} to the given \code{tracer}. +} diff --git a/man/trace_package.Rd b/man/trace_package.Rd index c6c944fd..c1b29d8c 100644 --- a/man/trace_package.Rd +++ b/man/trace_package.Rd @@ -1,13 +1,12 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/genthat.R +% Please edit documentation in R/trace-package.R \name{trace_package} \alias{trace_package} \title{Decorate all functions from given package and runs package code} \usage{ -trace_package(packages, files, output_dir = ".", decorator = "on.exit", - tracer = "set", action = c("stats", "export", "generate"), - working_dir = tempfile(pattern = "genthat-trace-"), quiet = TRUE, - lib_paths = NULL) +trace_package(packages, files, output_dir = ".", action = c("stats", + "export", "generate"), working_dir = tempfile(pattern = "genthat-trace-"), + quiet = TRUE, lib_paths = NULL) } \arguments{ \item{packages}{chr vector of package names whose functions should be traced. diff --git a/run-parallel.sh b/run-parallel.sh index 33135fd6..c3340f4c 100644 --- a/run-parallel.sh +++ b/run-parallel.sh @@ -2,7 +2,7 @@ set -e if [ $# -ne 1 ]; then - echo "Usage: $0 " + echo "Usage: $0 " exit 1 fi diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 1b5b13c8..655928ea 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -152,6 +152,17 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// sexp_address +std::string sexp_address(SEXP s); +RcppExport SEXP _genthat_sexp_address(SEXP sSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< SEXP >::type s(sSEXP); + rcpp_result_gen = Rcpp::wrap(sexp_address(s)); + return rcpp_result_gen; +END_RCPP +} RcppExport SEXP _rcpp_module_boot_SerializerModule(); @@ -169,6 +180,7 @@ static const R_CallMethodDef CallEntries[] = { {"_genthat_create_duplicate", (DL_FUNC) &_genthat_create_duplicate, 1}, {"_genthat_environment_name", (DL_FUNC) &_genthat_environment_name, 1}, {"_genthat_environment_name_as_code", (DL_FUNC) &_genthat_environment_name_as_code, 1}, + {"_genthat_sexp_address", (DL_FUNC) &_genthat_sexp_address, 1}, {"_rcpp_module_boot_SerializerModule", (DL_FUNC) &_rcpp_module_boot_SerializerModule, 0}, {NULL, NULL, 0} }; diff --git a/src/Utils.cpp b/src/Utils.cpp index 09e4dcc8..58d4592d 100644 --- a/src/Utils.cpp +++ b/src/Utils.cpp @@ -1,4 +1,5 @@ #include +#include #include "Utils.h" @@ -85,3 +86,12 @@ std::string environment_name_as_code(SEXP env) { } } } + +// [[Rcpp::export]] +std::string sexp_address(SEXP s) { + char *address; + if (asprintf(&address, "%p", s) == -1) { + Rf_error("Getting address of SEXP failed"); + } + return std::string(address); +} diff --git a/tests/test-pkgs-src/samplepkg/tests/testthat/testMain.R b/tests/test-pkgs-src/samplepkg/tests/testthat/testMain.R index 2e4e1b08..1ddeb25f 100644 --- a/tests/test-pkgs-src/samplepkg/tests/testthat/testMain.R +++ b/tests/test-pkgs-src/samplepkg/tests/testthat/testMain.R @@ -46,7 +46,6 @@ test_that("indirect call with two closures", { test_that("warnings", { expect_warning(my_warning()) - ## expect_equal(my_warning(), "my warning") }) test_that("errors", { diff --git a/tests/testthat/test-capture-scenarios.R b/tests/testthat/test-capture-scenarios.R index 83b97867..2752ae20 100644 --- a/tests/testthat/test-capture-scenarios.R +++ b/tests/testthat/test-capture-scenarios.R @@ -15,6 +15,11 @@ na_last <- function(x) { } test_that("dplyr arrange.data.frame (from dplyr/tests/testthat/test-arrange.r)", { + on.exit({ + reset_functions() + reset_traces() + }) + # if this does not fail it means that in globalenv there is a variable `a` # in this case this test will fail expect_error(get("a", envir=globalenv())) @@ -22,7 +27,12 @@ test_that("dplyr arrange.data.frame (from dplyr/tests/testthat/test-arrange.r)", tracer <- create_set_tracer() set_tracer(tracer) - d <- decorate_with_on.exit(dplyr:::arrange.data.frame, "arrange.data.frame", "dplyr", record_fun=quote(genthat:::record_trace)) + d <- create_decorated_function( + fun=dplyr:::arrange.data.frame, + name="arrange.data.frame", + package="dplyr", + onexit=record_trace + ) expect_true(na_last(d(df2, a)$a)) @@ -37,25 +47,28 @@ test_that("dplyr arrange.data.frame (from dplyr/tests/testthat/test-arrange.r)", }) test_that("replacement function", { + on.exit({ + reset_functions() + reset_traces() + }) + with_test_pkgs({ x <- 1:5 samplepkg::gg(x, 4) <- 0 expect_equal(x, c(0, 0, 0, 4, 5)) - d <- create_decorator() tracer <- create_set_tracer() set_tracer(tracer) - on.exit(reset_traces()) y <- 1:5 - decorate_function(samplepkg::`gg<-`, decorator=d) + decorate_function(samplepkg::`gg<-`, onexit=record_trace) samplepkg::gg(y, 4) <- 0 expect_equal(y, c(0, 0, 0, 4, 5)) t <- copy_traces(tracer)[[1]] tmp <- tempfile() - on.exit(unlink(tmp, recursive=TRUE)) + on.exit(unlink(tmp, recursive=TRUE), add=TRUE) test <- generate_test_file(t, tmp) res <- run_generated_test(test) @@ -64,18 +77,22 @@ test_that("replacement function", { }) test_that("full tracing scenario with a seed", { + on.exit({ + reset_functions() + reset_traces() + }) + set.seed(42) with_test_pkgs({ tmp <- tempfile() on.exit(unlink(tmp, recursive=TRUE)) - d <- create_decorator() tracer <- create_set_tracer() set_tracer(tracer) on.exit(reset_traces()) - decorate_function(samplepkg::my_add, decorator=d) + decorate_function(samplepkg::my_add, onexit=record_trace) samplepkg::my_add(runif(10), 1) diff --git a/tests/testthat/test-capture.R b/tests/testthat/test-capture.R index 6eb2e2c0..9f815579 100644 --- a/tests/testthat/test-capture.R +++ b/tests/testthat/test-capture.R @@ -13,7 +13,7 @@ test_that("record_trace correctly evaluates and stores arguments", { g <- function(y) a + y f <- function(x, y) x + y - record_trace("f", args=list(x=quote(b + 2), y=quote(g(1))), tracer=tracer) + record_trace(list(name="f", args=list(x=quote(b + 2), y=quote(g(1))), tracer=tracer)) t <- get_trace(tracer, 1L) @@ -40,7 +40,7 @@ test_that("record_trace correctly evaluates and stores arguments with ...", { f <- function(x, ...) x # f(b+1, 2, 3, g(c)) - record_trace("f", args=list(quote(b + 1), 2, 3, quote(g(c))), tracer=tracer) + record_trace(list(name="f", args=list(quote(b + 1), 2, 3, quote(g(c))), tracer=tracer)) t <- get_trace(tracer, 1L) @@ -58,7 +58,7 @@ test_that("record_trace called from a function body with argument matching", { # kind of a simulation of the injected code f <- function(x) { - record_trace("f", pkg=NULL, as.list(match.call())[-1], tracer=tracer) + record_trace(list(name="f", pkg=NULL, as.list(match.call())[-1], tracer=tracer)) } f() @@ -77,7 +77,7 @@ test_that("record_trace correctly resolves the names in lexical scopes", { x <- 1 # and x is here f <- function(x, y) { - record_trace("f", pkg=NULL, as.list(match.call())[-1], tracer=tracer) + record_trace(list(name="f", pkg=NULL, args=as.list(match.call())[-1], tracer=tracer)) } f(x, 2) @@ -323,7 +323,7 @@ test_that("record_trace resolves caller and callee environments", { } # env$f(y=2*x, a+x+y) - record_trace("f", pkg=NULL, list(x=quote(b(d)), quote(a)), tracer=tracer) + record_trace(list(name="f", pkg=NULL, args=list(x=quote(b(d)), quote(a)), tracer=tracer)) t <- get_trace(tracer, 1L) @@ -342,7 +342,14 @@ test_that("capture works with lapply", { f <- function(x) { y <- x+1 - record_trace("f", pkg=NULL, args=as.list(match.call())[-1], retv=y, env=parent.frame(), tracer=tracer) + record_trace(list( + name="f", + pkg=NULL, + args=as.list(match.call())[-1], + retv=y, + env=parent.frame(), + tracer=tracer + )) y } @@ -362,7 +369,7 @@ test_that("get_symbol_value can handle ...", { f <- function(...) g(...) g <- function(...) h(...) h <- function(...) { - record_trace("h", args=as.list(match.call())[-1], tracer=tracer) + record_trace(list(name="h", args=as.list(match.call())[-1], tracer=tracer)) } f(10L, 20L) @@ -378,7 +385,7 @@ test_that("get_symbol_value can handle non-evaluated ..N", { f <- function(...) g(...) g <- function(...) h(..1) h <- function(...) { - record_trace("h", args=as.list(match.call())[-1], tracer=tracer) + record_trace(list(name="h", args=as.list(match.call())[-1], tracer=tracer)) } f(10L, 20L) @@ -397,7 +404,7 @@ test_that("get_symbol_value can handle evaluated ..N", { g <- function(...) h(..1) h <- function(...) { ..1 + 1L - record_trace("h", args=as.list(match.call())[-1], tracer=tracer) + record_trace(list(name="h", args=as.list(match.call())[-1], tracer=tracer)) } f(10L*10L, 20L) @@ -416,7 +423,7 @@ test_that("captures nested language objects' global variable", { f <- function(x, y) list(x, y) - record_trace("f", args=list(x=quote(arg1), y=quote(b + 1)), tracer=tracer) + record_trace(list(name="f", args=list(x=quote(arg1), y=quote(b + 1)), tracer=tracer)) t <- get_trace(tracer, 1L) expect_equal(t$fun, "f") @@ -438,7 +445,7 @@ test_that("captures nested language objects' global variables", { f <- function(x, y, z) list(x, y, z) - record_trace("f", args=list(x=quote(arg1), y=quote(arg2), z=quote(a)), tracer=tracer) + record_trace(list(name="f", args=list(x=quote(arg1), y=quote(arg2), z=quote(a)), tracer=tracer)) t <- get_trace(tracer, 1L) @@ -459,7 +466,7 @@ test_that("capture works with replacement functions", { x <- 1 `__genthat_tmp` <- x value <- 5 - record_trace("gg<-", args=list(v=as.name("*tmp*"), a=4, value=value), retv=1, tracer=tracer) + record_trace(list(name="gg<-", args=list(v=as.name("*tmp*"), a=4, value=value), retv=1, tracer=tracer)) t <- get_trace(tracer, 1L) expect_equal(t$fun, "gg<-") diff --git a/tests/testthat/test-create-decorated-function.R b/tests/testthat/test-create-decorated-function.R new file mode 100644 index 00000000..1246beb3 --- /dev/null +++ b/tests/testthat/test-create-decorated-function.R @@ -0,0 +1,310 @@ +context("create-decorated-function") + +test_that("create_decorated_function creates function with onentry decoration", { + f <- function(x) 42 + + capture <- list() + fd <- create_decorated_function(fun=f, name='f', package=NULL, onentry=function(info) { + capture <<- info + }) + + expect_equal(fd(1), 42) + + expect_length(capture, 5) + with(capture, { + expect_equal(name, "f") + expect_equal(package, NULL) + expect_is(env, "environment") + expect_is(seed, "integer") + expect_equal(decorator, "onentry") + }) +}) + +test_that("create_decorated_function creates function with onexit decoration", { + f <- function(x) 42 + + capture <- list() + fd <- create_decorated_function(fun=f, name='f', package=NULL, onexit=function(info) { + capture <<- info + }) + + expect_equal(fd(1), 42) + + expect_length(capture, 7) + with(capture, { + expect_equal(name, "f") + expect_equal(package, NULL) + expect_is(env, "environment") + expect_is(seed, "integer") + expect_equal(retv, 42) + expect_equal(args, list(x=1)) + expect_equal(decorator, "onexit") + }) +}) + +test_that("create_decorated_function creates function with onerror decoration", { + f <- function(x) if (x) 42 else stop("error in f") + + capture <- list() + fd <- create_decorated_function(fun=f, name='f', package=NULL, onerror=function(info) { + capture <<- info + }) + + expect_equal(fd(TRUE), 42) + expect_length(capture, 0) + + capture <- list() + expect_error(fd(FALSE), "error in f") + + expect_length(capture, 7) + with(capture, { + expect_equal(name, "f") + expect_equal(package, NULL) + expect_is(env, "environment") + expect_is(seed, "integer") + expect_equal(args, list(x=FALSE)) + expect_equal(message, "error in f") + expect_equal(decorator, "onerror") + }) +}) + +test_that("create_decorated_function creates function with onentry and onerror decoration", { + f <- function(x) if (x) 42 else stop("error in f") + + capture <- list() + fd <- create_decorated_function(fun=f, name='f', package=NULL, + onentry=function(info) { + capture$onentry <<- info + }, + onerror=function(info) { + capture$onerror <<- info + } + ) + + expect_equal(fd(TRUE), 42) + expect_length(capture, 1) + with(capture$onentry, { + expect_equal(name, "f") + expect_equal(package, NULL) + expect_is(env, "environment") + expect_is(seed, "integer") + expect_equal(decorator, "onentry") + }) + + capture <- list() + expect_error(fd(FALSE), "error in f") + expect_length(capture, 2) + + expect_length(capture$onentry, 5) + with(capture$onentry, { + expect_equal(name, "f") + expect_equal(package, NULL) + expect_is(env, "environment") + expect_is(seed, "integer") + expect_equal(decorator, "onentry") + }) + + expect_length(capture$onerror, 7) + with(capture$onerror, { + expect_equal(name, "f") + expect_equal(package, NULL) + expect_is(env, "environment") + expect_is(seed, "integer") + expect_equal(args, list(x=FALSE)) + expect_equal(message, "error in f") + expect_equal(decorator, "onerror") + }) +}) + +test_that("create_decorated_function creates function with onentry, onexit and onerror decoration", { + f <- function(x) if (x) 42 else stop("error in f") + + capture <- list() + fd <- create_decorated_function(fun=f, name='f', package=NULL, + onentry=function(info) { + capture$onentry <<- info + }, + onexit=function(info) { + capture$onexit <<- info + }, + onerror=function(info) { + capture$onerror <<- info + } + ) + + expect_equal(fd(TRUE), 42) + expect_length(capture, 2) + with(capture$onentry, { + expect_equal(name, "f") + expect_equal(package, NULL) + expect_is(env, "environment") + expect_is(seed, "integer") + expect_equal(decorator, "onentry") + }) + expect_length(capture$onexit, 7) + with(capture$onexit, { + expect_equal(name, "f") + expect_equal(package, NULL) + expect_is(env, "environment") + expect_is(seed, "integer") + expect_equal(args, list(x=TRUE)) + expect_equal(retv, 42) + expect_equal(decorator, "onexit") + }) + + capture <- list() + expect_error(fd(FALSE), "error in f") + expect_length(capture, 2) + + expect_length(capture$onentry, 5) + with(capture$onentry, { + expect_equal(name, "f") + expect_equal(package, NULL) + expect_is(env, "environment") + expect_is(seed, "integer") + expect_equal(decorator, "onentry") + }) + expect_length(capture$onerror, 7) + with(capture$onerror, { + expect_equal(name, "f") + expect_equal(package, NULL) + expect_is(env, "environment") + expect_is(seed, "integer") + expect_equal(args, list(x=FALSE)) + expect_equal(message, "error in f") + expect_equal(decorator, "onerror") + }) +}) + +test_that("create_decorated_function creates function with onentry and onexit decoration", { + f <- function(x) 42 + + capture <- list() + fd <- create_decorated_function(fun=f, name='f', package=NULL, + onentry=function(info) { + capture$onentry <<- info + }, + onexit=function(info) { + capture$onexit <<- info + } + ) + + expect_equal(fd(1), 42) + expect_length(capture, 2) + with(capture$onentry, { + expect_equal(name, "f") + expect_equal(package, NULL) + expect_is(env, "environment") + expect_is(seed, "integer") + expect_equal(decorator, "onentry") + }) + expect_length(capture$onexit, 7) + with(capture$onexit, { + expect_equal(name, "f") + expect_equal(package, NULL) + expect_is(env, "environment") + expect_is(seed, "integer") + expect_equal(args, list(x=1)) + expect_equal(retv, 42) + expect_equal(decorator, "onexit") + }) +}) + +test_that("decorated functions can be multiline function", { + capture <- list() + + f <- function(x, y) { + x1 <- x + 1L + y1 <- y + 1L + x1 + y1 + } + + d <- create_decorated_function( + fun=f, + name="f", + package=NULL, + onexit=function(info) capture <<- info + ) + + expect_equal(d(1L, 2L), 5L) + + expect_equal(capture$args, list(x=1L, y=2L)) + expect_equal(capture$retv, 5L) +}) + +test_that("decorated functions can use return", { + capture <- list() + + f <- function(x, y) { + return(x+y) + } + + d <- create_decorated_function( + fun=f, + name="f", + package=NULL, + onexit=function(info) capture <<- info + ) + + expect_equal(d(1L, 2L), 3L) + + expect_equal(capture$args, list(x=1L, y=2L)) + expect_equal(capture$retv, 3L) +}) + +test_that("decorated function supports ...", { + capture <- list() + + f <- function(...) sum(...) + d <- create_decorated_function( + fun=f, + name="f", + package=NULL, + onexit=function(info) capture <<- info + ) + + expect_equal(d(a=1L, b=2L, 3L, 4L), 10L) + expect_equal(capture$args, list(a=1L, b=2L, 3L, 4L)) + expect_equal(capture$retv, 10L) +}) + +test_that("decorate_with_on.exit decorates a package function", { + capture <- list() + + d <- create_decorated_function( + fun=tools::file_path_sans_ext, + name="file_path_sans_ext", + package="tools", + onexit=function(info) capture <<- info + ) + + expect_equal(formals(d), formals(tools::file_path_sans_ext)) + expect_equal(environment(d), environment(tools::file_path_sans_ext)) + + d("a.b") + + expect_equal(capture$name, "file_path_sans_ext") + expect_equal(capture$package, "tools") + expect_equal(capture$args, list(x="a.b")) + expect_equal(capture$retv, "a") +}) + +test_that("test __genthat_tmp", { + `f<-` <- function(x, y, value) { + x[y] <- value + x + } + + `g<-` <- create_decorated_function( + fun=`f<-`, + name="f<-", + package=NULL, + onexit=function(info) { + expect_equal(get("__genthat_tmp", envir=sys.frame(-1)), list(a=1)) + } + ) + + x <- list(a=1) + g(x, 1) <- 2 + expect_equal(x$a, 2) +}) diff --git a/tests/testthat/test-decorate-with-on.exit.R b/tests/testthat/test-decorate-with-on.exit.R deleted file mode 100644 index fb05794e..00000000 --- a/tests/testthat/test-decorate-with-on.exit.R +++ /dev/null @@ -1,109 +0,0 @@ -context("decorate-with-on.exit") - -test_that("decorated function calls records retv on success", { - capture <- list() - - f <- function(a,b,c) { if (a) b + c else stop("an error") } - - d <- decorate_with_on.exit( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(formals(d), formals(d)) - expect_equal(environment(d), environment(f)) - expect_equal(attributes(d), list(`__genthat_original_fun`=f)) - - expect_equal(d(TRUE, 1L, 2L), 3L) - - expect_equal(capture$name, "f") - expect_equal(capture$pkg, NULL) - expect_equal(capture$args, list(a=TRUE, b=1L, c=2L)) - expect_equal(capture$retv, 3L) - - # TEST error - capture <- list() - expect_error(d(FALSE, 1L, 2L)) - expect_equal(capture, list()) -}) - -test_that("decorated functions can be multiline function", { - capture <- list() - - f <- function(x, y) { - x1 <- x + 1L - y1 <- y + 1L - x1 + y1 - } - - d <- decorate_with_on.exit( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(d(1L, 2L), 5L) - - expect_equal(capture$args, list(x=1L, y=2L)) - expect_equal(capture$retv, 5L) -}) - -test_that("decorated functions can use return", { - capture <- list() - - f <- function(x, y) { - return(x+y) - } - - d <- decorate_with_on.exit( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(d(1L, 2L), 3L) - - expect_equal(capture$args, list(x=1L, y=2L)) - expect_equal(capture$retv, 3L) -}) - -test_that("decorated function supports ...", { - capture <- list() - - f <- function(...) sum(...) - d <- decorate_with_on.exit( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(d(a=1L, b=2L, 3L, 4L), 10L) - expect_equal(capture$args, list(a=1L, b=2L, 3L, 4L)) - expect_equal(capture$retv, 10L) -}) - -test_that("decorate_with_on.exit decorates a package function", { - capture <- list() - - d <- decorate_with_on.exit( - tools::file_path_sans_ext, - "file_path_sans_ext", - "tools", - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(formals(d), formals(tools::file_path_sans_ext)) - expect_equal(environment(d), environment(tools::file_path_sans_ext)) - - d("a.b") - - expect_equal(capture$name, "file_path_sans_ext") - expect_equal(capture$pkg, "tools") - expect_equal(capture$args, list(x="a.b")) - expect_equal(capture$retv, "a") -}) diff --git a/tests/testthat/test-decorate-with-onboth.R b/tests/testthat/test-decorate-with-onboth.R deleted file mode 100644 index 604e288a..00000000 --- a/tests/testthat/test-decorate-with-onboth.R +++ /dev/null @@ -1,108 +0,0 @@ -context("decorate-with-onboth") - -test_that("decorated function calls records retv on success", { - capture <- list() - - f <- function(a,b,c) { if (a) b + c else stop("an error") } - - d <- decorate_with_onboth( - f, - "f", - NULL, - record_fun=function(...) capture <<- append(capture, list(list(...))) - ) - - expect_equal(formals(d), formals(d)) - expect_equal(environment(d), environment(f)) - expect_equal(attributes(d), list(`__genthat_original_fun`=f)) - - expect_equal(d(TRUE, 1L, 2L), 3L) - - expect_length(capture, 2L) - - entry <- capture[[1]] - expect_equal(entry$name, "f") - expect_equal(entry$pkg, NULL) - expect_equal(entry$args, list(a=TRUE, b=1L, c=2L)) - - exit <- capture[[2]] - expect_equal(exit$name, "f") - expect_equal(exit$pkg, NULL) - expect_equal(exit$args, list(a=TRUE, b=1L, c=2L)) - expect_equal(exit$retv, 3L) - - # TEST error - capture <- list() - expect_error(d(FALSE, 1L, 2L)) - - expect_length(capture, 1L) - - entry <- capture[[1]] - expect_equal(entry$name, "f") - expect_equal(entry$pkg, NULL) - expect_equal(entry$args, list(a=FALSE, b=1L, c=2L)) -}) - -test_that("decorated functions can be multiline function", { - capture <- list() - - f <- function(x, y) { - x1 <- x + 1L - y1 <- y + 1L - x1 + y1 - } - - d <- decorate_with_onboth( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(d(1L, 2L), 5L) - - expect_equal(capture$name, "f") - expect_equal(capture$pkg, NULL) - expect_equal(capture$args, list(x=1L, y=2L)) - expect_equal(capture$retv, 5L) - -}) - -test_that("decorated function supports ...", { - capture <- list() - - f <- function(...) sum(...) - d <- decorate_with_onboth( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(d(a=1L, b=2L, 3L, 4L), 10L) - - expect_equal(capture$name, "f") - expect_equal(capture$args, list(a=1L, b=2L, 3L, 4L)) - expect_equal(capture$retv, 10L) -}) - -test_that("decorate_with_onboth decorates a package function", { - capture <- list() - - d <- decorate_with_onboth( - tools::file_path_sans_ext, - "file_path_sans_ext", - "tools", - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(formals(d), formals(tools::file_path_sans_ext)) - expect_equal(environment(d), environment(tools::file_path_sans_ext)) - - d("a.b") - - expect_equal(capture$name, "file_path_sans_ext") - expect_equal(capture$pkg, "tools") - expect_equal(capture$args, list(x="a.b")) - expect_equal(capture$retv, "a") -}) diff --git a/tests/testthat/test-decorate-with-onentry.R b/tests/testthat/test-decorate-with-onentry.R deleted file mode 100644 index 8faabd82..00000000 --- a/tests/testthat/test-decorate-with-onentry.R +++ /dev/null @@ -1,89 +0,0 @@ -context("decorate-with-onentry") - -test_that("decorated function calls records retv on success", { - capture <- list() - - f <- function(a,b,c) { if (a) b + c else stop("an error") } - - d <- decorate_with_onentry( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(formals(d), formals(d)) - expect_equal(environment(d), environment(f)) - expect_equal(attributes(d), list(`__genthat_original_fun`=f)) - - expect_equal(d(TRUE, 1L, 2L), 3L) - - - expect_equal(capture$name, "f") - expect_equal(capture$pkg, NULL) - expect_equal(capture$args, list(a=TRUE, b=1L, c=2L)) - - # TEST error - capture <- list() - expect_error(d(FALSE, 1L, 2L)) - - expect_equal(capture$name, "f") - expect_equal(capture$pkg, NULL) - expect_equal(capture$args, list(a=FALSE, b=1L, c=2L)) -}) - -test_that("decorated functions can be multiline function", { - capture <- list() - - f <- function(x, y) { - x1 <- x + 1L - y1 <- y + 1L - x1 + y1 - } - - d <- decorate_with_onentry( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(d(1L, 2L), 5L) - - expect_equal(capture$args, list(x=1L, y=2L)) -}) - -test_that("decorated function supports ...", { - capture <- list() - - f <- function(...) sum(...) - d <- decorate_with_onentry( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(d(a=1L, b=2L, 3L, 4L), 10L) - expect_equal(capture$args, list(a=1L, b=2L, 3L, 4L)) -}) - -test_that("decorate_with_onentry decorates a package function", { - capture <- list() - - d <- decorate_with_onentry( - tools::file_path_sans_ext, - "file_path_sans_ext", - "tools", - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(formals(d), formals(tools::file_path_sans_ext)) - expect_equal(environment(d), environment(tools::file_path_sans_ext)) - - d("a.b") - - expect_equal(capture$name, "file_path_sans_ext") - expect_equal(capture$pkg, "tools") - expect_equal(capture$args, list(x="a.b")) -}) diff --git a/tests/testthat/test-decorate-with-onexit.R b/tests/testthat/test-decorate-with-onexit.R deleted file mode 100644 index 64c4ae66..00000000 --- a/tests/testthat/test-decorate-with-onexit.R +++ /dev/null @@ -1,90 +0,0 @@ -context("decorate-with-onexit") - -test_that("decorated function calls records retv on success", { - capture <- list() - - f <- function(a,b,c) { if (a) b + c else stop("an error") } - - d <- decorate_with_onexit( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(formals(d), formals(d)) - expect_equal(environment(d), environment(f)) - expect_equal(attributes(d), list(`__genthat_original_fun`=f)) - - expect_equal(d(TRUE, 1L, 2L), 3L) - - expect_equal(capture$name, "f") - expect_equal(capture$pkg, NULL) - expect_equal(capture$args, list(a=TRUE, b=1L, c=2L)) - expect_equal(capture$retv, 3L) - - # TEST error - capture <- list() - expect_error(d(FALSE, 1L, 2L)) - - expect_length(capture, 0) -}) - -test_that("decorated functions can be multiline function", { - capture <- list() - - f <- function(x, y) { - x1 <- x + 1L - y1 <- y + 1L - x1 + y1 - } - - d <- decorate_with_onexit( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(d(1L, 2L), 5L) - - expect_equal(capture$args, list(x=1L, y=2L)) - expect_equal(capture$retv, 5L) -}) - -test_that("decorated function supports ...", { - capture <- list() - - f <- function(...) sum(...) - d <- decorate_with_onexit( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(d(a=1L, b=2L, 3L, 4L), 10L) - expect_equal(capture$args, list(a=1L, b=2L, 3L, 4L)) - expect_equal(capture$retv, 10L) -}) - -test_that("decorate_with_onexit decorates a package function", { - capture <- list() - - d <- decorate_with_onexit( - tools::file_path_sans_ext, - "file_path_sans_ext", - "tools", - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(formals(d), formals(tools::file_path_sans_ext)) - expect_equal(environment(d), environment(tools::file_path_sans_ext)) - - d("a.b") - - expect_equal(capture$name, "file_path_sans_ext") - expect_equal(capture$pkg, "tools") - expect_equal(capture$args, list(x="a.b")) - expect_equal(capture$retv, "a") -}) diff --git a/tests/testthat/test-decorate-with-trycatch.R b/tests/testthat/test-decorate-with-trycatch.R deleted file mode 100644 index cacb9784..00000000 --- a/tests/testthat/test-decorate-with-trycatch.R +++ /dev/null @@ -1,102 +0,0 @@ -context("decorate-with-trycatch") - -test_that("decorated function calls recorded with retv on success", { - capture <- list() - - f <- function(a,b,c) { if (a) b + c else stop("an error") } - - d <- decorate_with_trycatch( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(formals(d), formals(d)) - expect_equal(environment(d), environment(f)) - expect_equal(attributes(d), list(`__genthat_original_fun`=f)) - - # TEST retv - expect_equal(d(TRUE, 1L, 2L), 3L) - - expect_equal(length(capture), 5L) - expect_equal(capture$name, "f") - expect_equal(capture$pkg, NULL) - expect_equal(capture$args, list(a=TRUE, b=1L, c=2L)) - expect_false(is.null(capture$env)) - expect_equal(capture$retv, 3L) - - # TEST error - expect_error(d(FALSE, 1L, 2L)) - - expect_equal(length(capture), 5L) - expect_equal(capture$name, "f") - expect_equal(capture$pkg, NULL) - expect_equal(capture$args, list(a=FALSE, b=1L, c=2L)) - expect_false(is.null(capture$env)) - expect_equal(capture$error$message, "an error") - expect_false(is.null(capture$error$call)) -}) - -test_that("decorated functions can be multiline function", { - capture <- list() - - f <- function(x, y) { - x1 <- x + 1L - y1 <- y + 1L - x1 + y1 - } - - d <- decorate_with_trycatch( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(d(1L, 2L), 5L) - - expect_equal(capture$args, list(x=1L, y=2L)) - expect_equal(capture$retv, 5L) -}) - -test_that("decorated function supports ...", { - capture <- list() - - f <- function(...) sum(...) - d <- decorate_with_trycatch( - f, - "f", - NULL, - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(d(a=1L, b=2L, 3L, 4L), 10L) - - expect_equal(length(capture), 5L) - expect_equal(capture$name, "f") - expect_equal(capture$args, list(a=1L, b=2L, 3L, 4L)) - expect_equal(capture$retv, 10L) -}) - -test_that("decorate_with_trycatch decorates a package function", { - capture <- list() - - d <- decorate_with_trycatch( - tools::file_path_sans_ext, - "file_path_sans_ext", - "tools", - record_fun=function(...) capture <<- list(...) - ) - - expect_equal(formals(d), formals(tools::file_path_sans_ext)) - expect_equal(environment(d), environment(tools::file_path_sans_ext)) - - d("a.b") - - expect_equal(capture$name, "file_path_sans_ext") - expect_equal(capture$pkg, "tools") - expect_equal(capture$args, list(x="a.b")) - expect_equal(capture$retv, "a") -}) - diff --git a/tests/testthat/test-decorate.R b/tests/testthat/test-decorate.R index d3e90acb..c4c6eb7a 100644 --- a/tests/testthat/test-decorate.R +++ b/tests/testthat/test-decorate.R @@ -4,6 +4,100 @@ if (!requireNamespace("devtools", quietly=TRUE)) { stop("devtools needed for this function to work. Please install it.", call. = FALSE) } +test_that("reset_functions resets all decorated function", { + f <- function(x) x + f1 <- function(x) x*2 + + g <- function(y) y + g1 <- function(y) y*2 + + .decorations[["x"]] <- list(fqn="x", fun=f, ofun=f1) + .decorations[["y"]] <- list(fqn="y", fun=g, ofun=g1) + + reset_functions() + + expect_length(.decorations, 0) + expect_equal(f, f1) + expect_equal(g, g1) +}) + +test_that("decorate_function decorates a function", { + on.exit(reset_functions()) + + f <- function(x) 42 + + capture <- list() + expect_equal(decorate_function(f, onentry=function(info) { capture <<- info }), "f") + + expect_length(.decorations, 1) + with(.decorations[[sexp_address(f)]], { + expect_equal(fqn, "f") + expect_equal(fun, f) + expect_equal(body(ofun), 42) + }) + + f(1) + + with(capture, { + expect_equal(name, "f") + expect_equal(decorator, "onentry") + }) +}) + +test_that("decorate_function decorates only functions", { + expect_error(decorate_function(1+1), "double: unsupported type") +}) + +test_that("decorate_function fails to decorate primitive functions", { + expect_error(decorate_function(sin), "sin: is a primitive function") +}) + +test_that("decorate_function fails to decorate s3 generic functions", { + expect_error(decorate_function(print), "print: is a S3 generic function") +}) + +test_that("get_decorations returns a list of decorated functions", { + on.exit(reset_functions()) + + f <- function(x) 42 + g <- function(y) 84 + + decorate_function(f, onentry=identity) + decorate_function(g, onentry=identity) + + ff <- f + gg <- g + + with(get_decorations(), { + expect_equal(body(f), body(ff)) + expect_equal(body(g), body(gg)) + }) +}) + +test_that("is_decorated", { + on.exit(reset_functions()) + + f <- function(x) 42 + g <- function(y) 84 + + decorate_function(f, onentry=identity) + + expect_true(is_decorated(f)) + expect_false(is_decorated(g)) +}) + +test_that("reset_function", { + on.exit(reset_functions()) + + f <- function(x) 42 + g <- function(y) 84 + + decorate_function(f, onentry=identity) + + expect_equal(reset_function(f), "f") + expect_warning(reset_function(g), "g: is not decorated") +}) + test_that("create_function creates functions", { f <- create_function(pairlist(a=1, b=2), substitute(a+b)) expect_equal(f(), 3) @@ -26,34 +120,8 @@ test_that("create_function assigns attributes", { expect_equal(attributes(f), attrs) }) -test_that("is_decorated knows when a functions is decorated", { - d1 <- create_decorator() - d2 <- create_decorator() - - f <- function() {} - expect_false(is_decorated(f, decorator=d1)) - - decorate_function(f, decorator=d1) - expect_true(is_decorated(f, decorator=d1)) - expect_false(is_decorated(f, decorator=d2)) -}) - -test_that("decorate functions redecorates already decorated function", { - d1 <- create_decorator() - - f <- function() {} - expect_false(is_decorated(f, decorator=d1)) - - decorate_function(f, decorator=d1) - b1 <- body(f) - decorate_function(f, decorator=d1) - b2 <- body(f) - - expect_equal(b1, b2) -}) - test_that("decorate_environment decorates all functions in the environment", { - d <- create_decorator() + on.exit(reset_functions()) env <- new.env(parent=emptyenv()) @@ -72,18 +140,25 @@ test_that("decorate_environment decorates all functions in the environment", { expect_equal(length(env), 5) - decorate_environment(env, decorator=d, exclude="j") + res <- decorate_environment(env, type="all", onentry=identity, exclude="j") - expect_equal(length(env), 5) + expect_length(res, 4) + + with(res, { + expect_type(f, "closure") + expect_type(g, "closure") + expect_equal(h, "h: is a primitive function") + expect_equal(i, "i: is a S3 generic function") + }) - expect_true(is_decorated(name="f", decorator=d, env=env)) - expect_true(is_decorated(name="g", decorator=d, env=env)) + expect_length(env, 5) - expect_false(is_decorated(name="h", decorator=d, env=env)) # it is a primitive function - expect_false(is_decorated(name="i", decorator=d, env=env)) # it is S3 generic - expect_false(is_decorated(name="j", decorator=d, env=env)) # it excluded + expect_true(is_decorated("f", env)) + expect_true(is_decorated("g", env)) - # TODO: check decorations + expect_false(is_decorated("h", env)) # it is a primitive function + expect_false(is_decorated("i", env)) # it is S3 generic + expect_false(is_decorated("j", env)) # it excluded }) test_that("reassign_function only replaces function body", { @@ -108,48 +183,14 @@ test_that("create_duplicate duplicates a function", { expect_error(create_duplicate(NULL)) }) -test_that("decorate_function returns decorated function", { - d <- create_decorator() - - f <- function(x) x - - decorate_function(f, decorator=d) - - expect_equal(length(d$decorations), 1) - - expect_true(is.function(f)) - expect_true(is_decorated(f, decorator=d)) - expect_true(is.list(d$decorations$f)) -}) - -test_that("reset_function", { - d <- create_decorator() - - f <- function(x) x - - decorate_function(f, decorator=d) - expect_true(is_decorated(f, decorator=d)) - expect_equal(length(d$decorations), 1) - - reset_function(f, decorator=d) - expect_false(is_decorated(f, decorator=d)) - expect_equal(length(d$decorations), 0) -}) - -test_that("decorator does not work with S3 generics", { - f <- function(x) UseMethod("n") - g <- function(x) { - 1+1 - UseMethod("n") - } +test_that("decorator_function works with S4 methods", { + on.exit(reset_functions()) - d <- create_decorator() - - expect_error(decorate_function(f, decorator=d), regexp="f: is a S3 generic function") - expect_error(decorate_function(g, decorator=d), regexp="g: is a S3 generic function") -}) - -test_that("decorator works with S4 methods", { + # the reason why the where environment is needed is that + # test_check (which is called from R CMD check) calls test_pkg_env + # which creates a local copy of the whole package environment + # with attributes so there will be two namespaces called genthat + # and that confuses resolve_function setGeneric("sides", where=environment(), function(object) { standardGeneric("sides") @@ -162,30 +203,27 @@ test_that("decorator works with S4 methods", { setMethod("sides", where=environment(), signature(object="Polygon"), function(object) object@sides) setMethod("sides", where=environment(), signature("Triangle"), function(object) 3) - tracer <- create_sequence_tracer() - set_tracer(tracer) - on.exit(reset_traces()) - - d <- create_decorator() - decorate_function(name="sides", decorator=d) + capture <- list() + decorate_function("sides", onexit=function(info) { + capture <<- info + }) p <- new("Polygon", sides=4L) t <- new("Triangle") sides(p) - sides(t) + with(capture, { + expect_equal(name, "sides") + expect_equal(args$object, quote(p)) + expect_equal(decorator, "onexit") + }) - traces <- copy_traces() - expect_equal(length(traces), 2) - expect_equal(traces[[1]]$globals$p, p) - expect_equal(traces[[1]]$retv, 4) - expect_equal(traces[[2]]$globals$t, t) - expect_equal(traces[[2]]$retv, 3) + capture <- list() + sides(t) + with(capture, { + expect_equal(name, "sides") + expect_equal(args$object, quote(t)) + expect_equal(decorator, "onexit") + }) }) -1 -## ## # TODO: test that we cannot decorate builtins - -## ## # TODO: test imported namespaces - -## ## # TODO: test decorations diff --git a/tests/testthat/test-extract-package-code.R b/tests/testthat/test-extract-package-code.R index 8ed56baa..1c67a75f 100644 --- a/tests/testthat/test-extract-package-code.R +++ b/tests/testthat/test-extract-package-code.R @@ -29,31 +29,31 @@ test_that("extract_package_code", { # examples ret <- extract_package_code("samplepkg", lib_paths=lib_path, types="examples", output_dir=tmp) check_files(ret, list(examples=examples)) - ret <- extract_package_code(dir=package_path, types="examples", output_dir=tmp) + ret <- extract_package_code(path=package_path, types="examples", output_dir=tmp) check_files(ret, list(examples=examples)) # tests ret <- extract_package_code("samplepkg", lib_paths=lib_path, types="tests", output_dir=tmp) check_files(ret, list(tests=tests)) - ret <- extract_package_code(dir=package_path, types="tests", output_dir=tmp) + ret <- extract_package_code(path=package_path, types="tests", output_dir=tmp) check_files(ret, list(tests=tests)) # vignettes ret <- extract_package_code("samplepkg", lib_paths=lib_path, types="vignettes", output_dir=tmp) check_files(ret, list(vignettes=vignettes)) - ret <- extract_package_code(dir=package_path, types="vignettes", output_dir=tmp) + ret <- extract_package_code(path=package_path, types="vignettes", output_dir=tmp) check_files(ret, list(vignettes=vignettes)) # test filter ret <- extract_package_code("samplepkg", lib_paths=lib_path, types="all", filter="add", output_dir=tmp) check_files(ret, list(examples=examples[1], tests=character(), vignettes=character())) - ret <- extract_package_code(dir=package_path, filter="add", output_dir=tmp) + ret <- extract_package_code(path=package_path, filter="add", output_dir=tmp) check_files(ret, list(examples=examples[1], tests=character(), vignettes=character())) # test empty package ret <- extract_package_code("emptypkg", lib_paths=.TEST_PKG_LIB, types="all", output_dir=tmp) expect_equivalent(unlist(ret), character()) - ret <- extract_package_code(dir=file.path(.TEST_PKG_SRC, "emptypkg"), types="all", output_dir=tmp) + ret <- extract_package_code(path=file.path(.TEST_PKG_SRC, "emptypkg"), types="all", output_dir=tmp) expect_equivalent(unlist(ret), character()) }) diff --git a/tests/testthat/test-gen-from-package.R b/tests/testthat/test-gen-from-package.R index f764adb6..e679eae8 100644 --- a/tests/testthat/test-gen-from-package.R +++ b/tests/testthat/test-gen-from-package.R @@ -50,4 +50,3 @@ test_that("gen_from_package works on empty pkg", { # TODO assert column names and attributes }) }) - diff --git a/tests/testthat/test-genthat-integration.R b/tests/testthat/test-genthat-integration.R deleted file mode 100644 index ce9a8bb5..00000000 --- a/tests/testthat/test-genthat-integration.R +++ /dev/null @@ -1,33 +0,0 @@ -context("integration tests") - -skip_if_not_integration_test <- function() { - skip_if_not(getOption("genthat.run_itests") == TRUE) -} - -test_that("trace_package works on stringr", { - skip_if_not_integration_test() - - withr::with_temp_libpaths({ - install.packages( - "stringr", - type="source", - repos="https://cloud.r-project.org", - quiet=TRUE, - INSTALL_opts=c('--example', '--install-tests', '--with-keep.source', '--no-multiarch') - ) - - output_dir <- tempfile() - on.exit(unlink(output_dir, recursive=TRUE)) - ret <- trace_package("stringr", output_dir=output_dir, quiet=TRUE) - - n_traces <- sum(ret$n_traces) - - # a bit of guess :-) - expect_true(n_traces > 500) - - rdss <- na.omit(ret$filename) - traces <- lapply(rdss, readRDS) - traces <- unlist(traces, recursive=FALSE) - expect_equal(length(traces), n_traces) - }) -}) diff --git a/tests/testthat/test-genthat-samplepkg.R b/tests/testthat/test-genthat-samplepkg.R index 76ddde47..544e7fb7 100644 --- a/tests/testthat/test-genthat-samplepkg.R +++ b/tests/testthat/test-genthat-samplepkg.R @@ -13,7 +13,7 @@ library(stringr) # - My-call.Rd [4] # - two calls to my_call # - two calls to my_add -# - tests [6] +# - tests [8] # - testthat/testMain.R [8] # - one call to my_public # - one call to my_private @@ -29,127 +29,62 @@ library(stringr) # - my-vignette.Rmd [1] # - one call to my_add -test_that("trace_package works on a single file from sample package", { - skip_on_cran() - skip_on_travis() - - ret <- with_test_pkgs({ - output_dir <- tempfile() - f1 <- tempfile() - - on.exit({ - file.remove(c(f1)) - unlink(output_dir, recursive=TRUE) - }) - - # a trace - cat("samplepkg::my_add(1,1)", file=f1) - - trace_package("samplepkg", f1, output_dir=output_dir, action="export", quiet=!is_debug_enabled()) - }) - - expect_equal(length(ret), 1) - expect_equal(names(ret), f1) - - expect_equal(ret[[f1]]$output, file.path(output_dir, "samplepkg", "my_add", "trace-1.RDS")) - expect_equal(ret[[f1]]$error, NA) -}) - -test_that("trace_package works on a sample package", { +test_that("gen_from_package works on a sample package", { skip_on_cran() skip_on_travis() - with_test_pkgs({ - output_dir <- tempfile() - f1 <- tempfile() - f2 <- tempfile() - f3 <- tempfile() - f4 <- tempfile() - - on.exit({ - file.remove(c(f1, f2, f3)) - unlink(output_dir, recursive=TRUE) - }) - - # a trace - cat("samplepkg::my_add(1,1)", file=f1) - # no trace - cat("1+1", file=f2) - # error - cat("errorrrr!", file=f3) - # f4 is deliberately missing - - # test export - ret <- trace_package( - "samplepkg", - c(f1, f2, f3, f4), - output_dir=output_dir, - action="export", - quiet=!is_debug_enabled() - ) - - expect_equal(length(ret), 4) - - expect_equal(ret[[f1]]$output, file.path(output_dir, "samplepkg", "my_add", "trace-1.RDS")) - expect_equal(ret[[f1]]$error, NA) - expect_equal(nrow(ret[[f2]]), 0) - expect_equal(nrow(ret[[f3]]), 0) - expect_equal(ret[[f4]], paste(f4, "does not exist")) - - # test generate - ret <- trace_package( - "samplepkg", - c(f1, f2, f3, f4), - output_dir=output_dir, - action="generate", - quiet=!is_debug_enabled() - ) - - expect_equal(length(ret), 4) - - expect_equal(ret[[f1]]$output, file.path(output_dir, "samplepkg", "my_add", "test-1.R")) - expect_equal(ret[[f1]]$error, NA) - expect_equal(nrow(ret[[f2]]), 0) - expect_equal(nrow(ret[[f3]]), 0) - expect_equal(ret[[f4]], paste(f4, "does not exist")) + # so it can be reused in the two datasets - one from installed package and + # one from source package + check_ret <- function(ret) { + # check by sources + expect_nrow(dplyr::filter(ret, str_detect(file, "My-add.Rd.R$")), 2) + expect_nrow(dplyr::filter(ret, str_detect(file, "My-call.Rd.R$")), 4) + expect_nrow(dplyr::filter(ret, str_detect(file, "testthat.R$")), 8) + expect_nrow(dplyr::filter(ret, str_detect(file, "my-ext-vignette-trace.R$")), 1) + expect_nrow(dplyr::filter(ret, str_detect(file, "my-vignette.R$")), 1) + + # check by functions + expect_nrow(dplyr::filter(ret, str_detect(output, "/my_add/")), 7) + expect_nrow(dplyr::filter(ret, str_detect(output, "/my_call/")), 6) + expect_nrow(dplyr::filter(ret, str_detect(output, "/my_public/")), 1) + expect_nrow(dplyr::filter(ret, str_detect(output, "/my_warning/")), 1) + expect_nrow(dplyr::filter(ret, str_detect(output, "/my_private/")), 1) + + # check that =there is no error + expect_equal(sum(is.na(ret$error)), 16) + } + + options(genthat.tracer_type="sequence") + output_dir <- tempfile() + + on.exit({ + unlink(output_dir, recursive=TRUE) + options(genthat.tracer_type="set") }) -}) - -test_that("gen_from_package works on a sample package", { - skip_on_cran() - skip_on_travis() ret <- with_test_pkgs({ - output_dir <- tempfile() - - on.exit({ - unlink(output_dir, recursive=TRUE) - }) - gen_from_package( - find.package("samplepkg"), + path="../test-pkgs-src/samplepkg", types="all", - tracer="sequence", output_dir=output_dir, action="export", quiet=!is_debug_enabled() ) }) - # check by sources - expect_nrow(dplyr::filter(ret, str_detect(file, "My-add.Rd.R$")), 2) - expect_nrow(dplyr::filter(ret, str_detect(file, "My-call.Rd.R$")), 4) - expect_nrow(dplyr::filter(ret, str_detect(file, "testthat.R$")), 8) - expect_nrow(dplyr::filter(ret, str_detect(file, "my-ext-vignette-trace.R$")), 1) - expect_nrow(dplyr::filter(ret, str_detect(file, "my-vignette.R$")), 1) + check_ret(ret) + + # we need to force unloading samplepkg since otherwise the find.package will + # find it and the following will nto force package installation + unloadNamespace("samplepkg") - # check by functions - expect_nrow(dplyr::filter(ret, str_detect(output, "/my_add/")), 7) - expect_nrow(dplyr::filter(ret, str_detect(output, "/my_call/")), 6) - expect_nrow(dplyr::filter(ret, str_detect(output, "/my_public/")), 1) - expect_nrow(dplyr::filter(ret, str_detect(output, "/my_warning/")), 1) - expect_nrow(dplyr::filter(ret, str_detect(output, "/my_private/")), 1) + ret <- gen_from_package( + path="../test-pkgs-src/samplepkg", + types="all", + output_dir=output_dir, + action="export", + quiet=!is_debug_enabled() + ) - # check that =there is no error - expect_equal(sum(is.na(ret$error)), 16) + check_ret(ret) }) diff --git a/tests/testthat/test-genthat.R b/tests/testthat/test-genthat.R index b223cc71..17b6c947 100644 --- a/tests/testthat/test-genthat.R +++ b/tests/testthat/test-genthat.R @@ -4,19 +4,18 @@ test_that("tracing control work", { capture <- list() f <- function(x,y) x + y - decorate_function(f, record_fun=function(...) capture <<- list(...)) + decorate_function(f, onexit=function(info) capture <<- info) disable_tracing() f(1L, 2L) expect_equal(is_tracing_enabled(), FALSE) - expect_equal(length(capture), 0L) + expect_length(capture, 0L) enable_tracing() f(1L, 2L) expect_equal(is_tracing_enabled(), TRUE) - expect_equal(length(capture), 6L) expect_equal(capture$retv, 3L) }) diff --git a/tests/testthat/test-helpers.R b/tests/testthat/test-helpers.R index 3502adf0..016ddfab 100644 --- a/tests/testthat/test-helpers.R +++ b/tests/testthat/test-helpers.R @@ -139,30 +139,70 @@ test_that("resolve_package_name returns the package name", { expect_equal(resolve_package_name(my_f, "my_f"), NULL) }) +# this is the way we are actually using the resolve_function +# so we need to test resolve_function2 +resolve_function2 <- function(fun, env=parent.frame()) { + resolve_function(fun, substitute(fun), env) +} -test_that("resolve_function", { - expect_equal(resolve_function("ls"), list(fqn="base:::ls", name="ls", package="base", fun=ls)) - expect_equal(resolve_function("base::ls"), list(fqn="base:::ls", name="ls", package="base", fun=ls)) - expect_equal(resolve_function("base:::ls"), list(fqn="base:::ls", name="ls", package="base", fun=ls)) +test_that("resolve_function using string", { + expect_equal(resolve_function2("ls"), list(fqn="base:::ls", name="ls", package="base", fun=ls)) + expect_equal(resolve_function2("base::ls"), list(fqn="base:::ls", name="ls", package="base", fun=ls)) + expect_equal(resolve_function2("base:::ls"), list(fqn="base:::ls", name="ls", package="base", fun=ls)) +}) + +test_that("resolve_function using function refs", { + expect_equal(resolve_function2(ls), list(fqn="base:::ls", name="ls", package="base", fun=ls)) + expect_equal(resolve_function2(base::ls), list(fqn="base:::ls", name="ls", package="base", fun=ls)) + expect_equal(resolve_function2(base::ls), list(fqn="base:::ls", name="ls", package="base", fun=ls)) +}) - expect_equal(resolve_function("ls", ls), list(fqn="base:::ls", name="ls", package="base", fun=ls)) - expect_equal(resolve_function(quote(ls), ls), list(fqn="base:::ls", name="ls", package="base", fun=ls)) - expect_equal(resolve_function(quote(base::ls), ls), list(fqn="base:::ls", name="ls", package="base", fun=ls)) - expect_equal(resolve_function(quote(base:::ls), ls), list(fqn="base:::ls", name="ls", package="base", fun=ls)) +test_that("resolve_function using quotes", { + expect_equal(resolve_function2(quote(ls)), list(fqn="base:::ls", name="ls", package="base", fun=ls)) + expect_equal(resolve_function2(quote(base::ls)), list(fqn="base:::ls", name="ls", package="base", fun=ls)) + expect_equal(resolve_function2(quote(base:::ls)), list(fqn="base:::ls", name="ls", package="base", fun=ls)) +}) - expect_error(resolve_function("utils::this_one_does_not_exist_here_123"), "") - expect_error(resolve_function("this_one_does_not_exist_here_123", ls), "") - expect_error(resolve_function(quote(this_one_does_not_exists), ls), "") +test_that("resolve_function non-existing functions", { + expect_error(resolve_function2("utils::this_one_does_not_exist_here_123")) + expect_error(resolve_function2("this_one_does_not_exist_here_123")) + expect_error(resolve_function2(quote(this_one_does_not_exists))) +}) +test_that("resolve_function local function", { my_fun <- function() {} - expect_equal(resolve_function("my_fun"), list(fqn="my_fun", name="my_fun", package=NULL, fun=my_fun)) - expect_equal(resolve_function(quote(my_fun), my_fun), list(fqn="my_fun", name="my_fun", package=NULL, fun=my_fun)) + expect_equal(resolve_function2("my_fun"), list(fqn="my_fun", name="my_fun", package=NULL, fun=my_fun)) + expect_equal(resolve_function2(quote(my_fun)), list(fqn="my_fun", name="my_fun", package=NULL, fun=my_fun)) +}) +test_that("resolve_function on special symbols", { + expect_equal( + resolve_function2(`substr<-`), + list(fqn="base:::`substr<-`", name="substr<-", package="base", fun=`substr<-`) + ) + expect_equal( + resolve_function2(base::`substr<-`), + list(fqn="base:::`substr<-`", name="substr<-", package="base", fun=`substr<-`) + ) + expect_equal(resolve_function2(`::`), list(fqn="base:::`::`", name="::", package="base", fun=`::`)) + expect_equal(resolve_function2(`:::`), list(fqn="base:::`:::`", name=":::", package="base", fun=`:::`)) + + expect_equal(resolve_function2("::"), list(fqn="base:::`::`", name="::", package="base", fun=`::`)) + expect_equal(resolve_function2(":::"), list(fqn="base:::`:::`", name=":::", package="base", fun=`:::`)) +}) + +test_that("resolve_function in specified env", { env <- new.env(parent=emptyenv()) env$f <- function() {} - expect_equal(resolve_function("f", env=env), list(fqn="f", name="f", package=NULL, fun=env$f)) + expect_equal(resolve_function2("f", env=env), list(fqn="f", name="f", package=NULL, fun=env$f)) }) +test_that("is_s3_generic works", { + f <- function(x) 42 + + expect_true(is_s3_generic(print)) + expect_false(is_s3_generic(f)) +}) # TODO: update for link_environments() ## test_that("linked_environment links environments", { diff --git a/tests/testthat/test-trace-package.R b/tests/testthat/test-trace-package.R new file mode 100644 index 00000000..bef5fdb7 --- /dev/null +++ b/tests/testthat/test-trace-package.R @@ -0,0 +1,86 @@ +context("trace_functions") + +test_that("trace_package works on a single file from sample package", { + skip_on_cran() + skip_on_travis() + + ret <- with_test_pkgs({ + output_dir <- tempfile() + f1 <- tempfile() + + on.exit({ + file.remove(c(f1)) + unlink(output_dir, recursive=TRUE) + }) + + cat("samplepkg::my_add(1,1)", file=f1) + + trace_package("samplepkg", f1, output_dir=output_dir, action="export", quiet=!is_debug_enabled()) + }) + + expect_equal(length(ret), 1) + expect_equal(names(ret), f1) + + expect_equal(ret[[f1]]$output, file.path(output_dir, "samplepkg", "my_add", "trace-1.RDS")) + expect_equal(ret[[f1]]$error, NA) +}) + +test_that("trace_package works on a sample package", { + skip_on_cran() + skip_on_travis() + + with_test_pkgs({ + output_dir <- tempfile() + f1 <- tempfile() + f2 <- tempfile() + f3 <- tempfile() + f4 <- tempfile() + + on.exit({ + file.remove(c(f1, f2, f3)) + unlink(output_dir, recursive=TRUE) + }) + + # a trace + cat("samplepkg::my_add(1,1)", file=f1) + # no trace + cat("1+1", file=f2) + # error + cat("errorrrr!", file=f3) + # f4 is deliberately missing + + # test export + ret <- trace_package( + "samplepkg", + c(f1, f2, f3, f4), + output_dir=output_dir, + action="export", + quiet=!is_debug_enabled() + ) + + expect_equal(length(ret), 4) + + expect_equal(ret[[f1]]$output, file.path(output_dir, "samplepkg", "my_add", "trace-1.RDS")) + expect_equal(ret[[f1]]$error, NA) + expect_equal(nrow(ret[[f2]]), 0) + expect_equal(nrow(ret[[f3]]), 0) + expect_equal(ret[[f4]], paste(f4, "does not exist")) + + # test generate + ret <- trace_package( + "samplepkg", + c(f1, f2, f3, f4), + output_dir=output_dir, + action="generate", + quiet=!is_debug_enabled() + ) + + expect_equal(length(ret), 4) + + expect_equal(ret[[f1]]$output, file.path(output_dir, "samplepkg", "my_add", "test-1.R")) + expect_equal(ret[[f1]]$error, NA) + expect_equal(nrow(ret[[f2]]), 0) + expect_equal(nrow(ret[[f3]]), 0) + expect_equal(ret[[f4]], paste(f4, "does not exist")) + }) +}) diff --git a/tests/testthat/test-traces.R b/tests/testthat/test-trace.R similarity index 74% rename from tests/testthat/test-traces.R rename to tests/testthat/test-trace.R index fedd43e9..09097256 100644 --- a/tests/testthat/test-traces.R +++ b/tests/testthat/test-trace.R @@ -2,21 +2,24 @@ context("traces") test_that("create entry trace", { trace <- create_trace("fun") - expect_equal(class(trace), "genthat_trace_entry") + + expect_is(trace, "genthat_trace_entry") expect_null(trace$retv) expect_null(trace$error) }) test_that("create trace", { trace <- create_trace("fun", retv=1L) - expect_equal(class(trace), "genthat_trace") + + expect_is(trace, "genthat_trace") expect_equal(trace$retv, 1L) expect_null(trace$error) }) test_that("create error trace", { trace <- create_trace("fun", error=simpleError("an error")) - expect_equal(class(trace), "genthat_trace_error") + + expect_is(trace, "genthat_trace_error") expect_null(trace$retv) expect_equal(trace$error$message, "an error") }) diff --git a/tests/testthat/test-tracer.R b/tests/testthat/test-tracer.R new file mode 100644 index 00000000..ccef4b7b --- /dev/null +++ b/tests/testthat/test-tracer.R @@ -0,0 +1,57 @@ +context("tracer") + +test_that("create tracer creates trace based on the option", { + on.exit(options(genthat.tracer_type="set")) + + t <- create_tracer() + expect_is(t, "set_tracer") + + options(genthat.tracer_type="sequence") + + t <- create_tracer() + expect_is(t, "sequence_tracer") +}) + +test_that("set_tracer sets a tracer", { + on.exit(.genthat$tracer <- NULL) + + .genthat$tracer <- NULL + + tracer <- create_set_tracer() + set_tracer(tracer) + + expect_equal(.genthat$tracer, tracer) +}) + +test_that("get_tracer get the current tracer", { + on.exit(.genthat$tracer <- NULL) + + tracer <- create_set_tracer() + .genthat$tracer <- tracer + + expect_equal(get_tracer(), tracer) +}) + +test_that("get_tracer creates a tracer if non exists", { + on.exit(.genthat$tracer <- NULL) + + .genthat$tracer <- NULL + + expect_is(get_tracer(), "set_tracer") +}) + +test_that("copy_traces returns stored traces, reset_traces removes all traces", { + on.exit(.genthat$tracer <- NULL) + + tracer <- create_set_tracer() + set_tracer(tracer) + + t1 <- create_trace(fun="f") + store_trace(tracer, t1) + + expect_equal(copy_traces(), list(t1)) + + reset_traces() + + expect_equal(copy_traces(), list()) +}) diff --git a/vignettes/basic-usage.Rmd b/vignettes/basic-usage.Rmd index cb60eb32..43372b1e 100644 --- a/vignettes/basic-usage.Rmd +++ b/vignettes/basic-usage.Rmd @@ -1,6 +1,6 @@ --- -title: "testr - Basic Usage" -author: "Roman Tsegelskyi & Petr Maj" +title: "genthat - Getting Started Guide" +author: "Filip Krikava" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: >