Simplify the generated files, move testthat functionnality in external script

R/generate.R

@@ -79,38 +79,23 @@ generate_test <- function(trace, ...) {
 #' @export
 generate_test.genthat_trace <- function(trace, include_trace_dump=FALSE, format_code=TRUE) {
     tryCatch({
-        externals <- new.env(parent=emptyenv())
         serializer <- new(Serializer)
         call <- generate_call(trace, serializer)
         globals <- generate_globals(trace$globals, serializer)
-        retv <- serializer$serialize_value(trace$retv)
 
-        header <- "library(testthat)\n\n"
-        if (include_trace_dump) {
-            header <- paste(header, dump_raw_trace(trace), sep="\n")
-        }
-
-        if (!is.null(trace$seed)) {
-            # .Random.seed is only looked in user environment
-            header <- paste0(header, ".Random.seed <<- .ext.seed\n\n")
-            externals$.ext.seed <- trace$seed
-        }
 
         code <- paste0(
-            header,
-            'test_that("', trace$fun, '", {\n',
-            globals,
-            if (nchar(globals) > 0) '\n' else '',
-            '\nexpect_equal(', call, ', ', retv, ')\n})'
+            'genthat_extracted_call <- function() {\n',
+                globals,
+                if (nchar(globals) > 0) '\n' else '',
+                call,'\n',
+            '}\n'
         )
 
         if (format_code) {
             code <- reformat_code(code)
         }
 
-        serializer$externals(externals)
-        attr(code, "externals") <- externals
-
         code
     }, error=function(e) {
         # this so we can have a systematic prefix for the error message
@@ -154,12 +139,6 @@ save_test <- function(pkg, fun, code, output_dir) {
 
     fname <- next_file_in_row(file.path(dname, "test.R"))
 
-    externals <- attr(code, "externals")
-    if (length(externals) > 0) {
-        fname_ext <- paste0(tools::file_path_sans_ext(fname), ".ext")
-        saveRDS(externals, fname_ext)
-    }
-
     write(paste(code, collapse="\n\n"), file=fname)
 
     fname

R/genthat.R

@@ -217,6 +217,14 @@ gen_from_package <- function(pkgs_to_trace, pkgs_to_run=pkgs_to_trace,
             }
         }
 
+        # Record the return value of runnable tests
+        lapply(result$output,
+            function(Rfile) {
+                extfile <- gsub(".R$", ".ext", Rfile)
+                try(record_test_exts(Rfile, extfile))
+            }
+        )
+
         attr(result, "errors") <- errors
         attr(result, "stats") <- c(
             "all"=nrow(tracing),
@@ -371,6 +379,7 @@ generate_action <- function(trace, output_dir, keep_failed_trace=FALSE) {
     tryCatch({
         testfile <- generate_test_file(trace, output_dir)
         log_debug("Saving test into: ", testfile)
+
         error <- NA
 
         if (getOption("genthat.keep_all_traces", FALSE)) {

R/record-test-exts.R

@@ -0,0 +1,28 @@
+
+# Run the generated unit test in a new R process with a known seed
+# to record the return value of a reproducible run
+
+run_test_in_isolation <- function(test, seed) {
+    callr::r(
+        function(test, seed) {
+            .Random.seed <<- seed
+            source(test)
+            genthat_extracted_call()
+        },
+        args=list(test=test, seed=seed)
+    )
+}
+
+record_test_exts <- function(test, extfile, seed=NULL) {
+    if (is.null(seed)) {
+        set.seed(NULL)
+        seed <- .Random.seed
+    }
+
+    exts <- list(
+        .ext.retv = run_test_in_isolation(test, seed),
+        .ext.seed = seed
+    )
+
+    saveRDS(exts, file=extfile)
+}

R/run-generated-tests.R

@@ -10,7 +10,8 @@ test_generated_file <- function(test) {
         testthat::test_env()
     }
 
-    testthat::test_file(test, reporter="stop", wrap=FALSE, env=env)
+    capture.output(r <- { source(test, local=env); env$genthat_extracted_call() })
+    r
 }
 
 #' @export
@@ -30,10 +31,6 @@ run_generated_test <- function(tests, quiet=TRUE) {
 
             time <- stopwatch(res <- test_generated_file(test))
 
-            if (length(res) == 0) {
-                stop("testthat::test_file result was empty")
-            }
-
             time <- as.numeric(time, units="secs")
 
             if (!quiet) {

tools/harnesses/benchmark.R

@@ -0,0 +1,75 @@
+#!/usr/bin/env Rscript
+
+verifyResult <- function(res, expected_retv) {
+	isTRUE(all.equal(res, expected_retv))
+}
+
+doRuns <- function(name, iterations, innerIterations, params) {
+    total <- 0
+    for (i in 1:iterations) {
+
+        results <- vector(mode = "list", length = innerIterations)
+
+        startTime <- Sys.time()
+        for (k in 1:innerIterations) {
+          .Random.seed <<- params$.ext.seed
+          # wrap the result in a list to prevent NULL assignments
+          # from removing a cell from the vector
+          results[[k]] <- list(genthat_extracted_call())
+        }
+        endTime <- Sys.time()
+
+        for (k in 1:innerIterations) {
+          if (!verifyResult(results[[k]], list(params$.ext.retv))) {
+              message("Benchmark failed: incorrect result")
+              message("res=\n", results[[k]], "\n\nexpected=\n", list(params$retv))
+              stop("Benchmark failed")
+          }
+        }
+
+        runTime <- (as.numeric(endTime) - as.numeric(startTime)) * 1000000
+
+        cat(name, ": iterations=1 runtime: ", round(runTime), "us\n", sep = "")
+        total <- total + runTime
+    }
+    total
+}
+
+run <- function(args) {
+    if (length(args) < 2 || 3 < length(args))
+        stop(printUsage())
+
+    name <- args[[1]]
+    numIterations <- strtoi(args[[2]])
+
+
+    innerIterations <- 1
+    if (length(args) >= 3)
+      innerIterations <- strtoi(args[[3]])
+
+    Rfile <- normalizePath(paste0(name, ".R"))
+    extfile <- normalizePath(paste0(name, ".ext"))
+
+		params <- readRDS(extfile)
+    .Random.seed <<- params$.ext.seed
+    source(Rfile)
+
+    total <- as.numeric(doRuns(name, numIterations, innerIterations, params));
+    cat(name, ": ",
+        "iterations=", numIterations, "; ",
+        "average: ", round(total / numIterations), " us; ",
+        "total: ", round(total), "us\n\n", sep="")
+    #cat("Total runtime: ", total, "us\n\n", sep="")
+}
+
+printUsage <- function() {
+    cat("harness.r benchmark num-iterations [inner-iterations]\n")
+    cat("\n")
+    cat("  benchmark           - benchmark class name (filename without the extension)\n")
+    cat("  num-iterations      - number of times to execute benchmark\n")
+    cat("  inner-iterations    - number of times the benchmark is executed in an inner loop,\n")
+    cat("                        which is measured in total, default: 1\n")
+
+}
+
+run(commandArgs(trailingOnly=TRUE))

tools/harnesses/test_files.R

@@ -0,0 +1,57 @@
+#!/usr/bin/env Rscript
+
+# Run this file either as a script:
+#
+#    (bash)
+#    $ GENERATED_TESTS_DIR="./tests" ./test_files.R
+#    $ ./test_files.R ./tests/yaml/as.yaml/test-36.R ./tests/yaml/yaml.load/test-57.R
+#
+# or with testthat::test_file()
+#
+#    (R)
+#    > withr::with_envvar(
+#          list(GENERATED_TESTS_DIR="./tests"),
+#          testthat::test_file("./test_files.R")
+#      )
+
+GENERATED_TESTS_DIR=Sys.getenv("GENERATED_TESTS_DIR", unset=NA)
+
+run_file <- function(Rfile, seed) {
+    .Random.seed <<- seed
+    source(Rfile)
+
+    .Random.seed <<- seed
+    genthat_extracted_call()
+}
+
+
+test_file <- function(Rfile) {
+    extfile <- gsub(".R$", ".ext", Rfile)
+		params <- readRDS(extfile)
+    testthat::test_that(Rfile, testthat::expect_equal(run_file(Rfile, params$.ext.seed), params$.ext.retv))
+}
+
+
+run <- function(args) {
+    Rfiles <- list()
+
+    if (length(args) >= 1 ) {
+      Rfiles <- args
+    } else if (! is.na(GENERATED_TESTS_DIR)) {
+      Rfiles <- list.files(GENERATED_TESTS_DIR, recursive=TRUE, pattern="\\.R$", full.names=TRUE)
+    } else {
+      printUsage()
+      stop("No arguments and GENERATED_TESTS_DIR is unset.")
+    }
+
+    invisible(lapply(Rfiles, test_file))
+}
+
+printUsage <- function() {
+  message("test_files.R [test1.R test2.R test3.R ...]")
+  message(" testk.R     - the files to test. Should be accompanied by a corresponding testk.ext file.")
+  message("               If no files are specified, all the files in the GENERATED_TESTS_DIR directory are run")
+  message("")
+}
+
+run(commandArgs(trailingOnly=TRUE))