From c1baf8fb0f7602a63043ba4b45377d522c1b8e6d Mon Sep 17 00:00:00 2001 From: vogr Date: Thu, 12 Aug 2021 15:32:28 +0000 Subject: [PATCH 1/3] Simplify generated files: only a function definition. + Remove testthat integration. --- R/generate.R | 25 +++++-------------------- R/run-generated-tests.R | 7 ++----- 2 files changed, 7 insertions(+), 25 deletions(-) diff --git a/R/generate.R b/R/generate.R index 0e5ab37e..a74ae11d 100644 --- a/R/generate.R +++ b/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_function <- 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 diff --git a/R/run-generated-tests.R b/R/run-generated-tests.R index 4a3947c3..3ebf10f0 100644 --- a/R/run-generated-tests.R +++ b/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_function() }) + 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) { From d8a5174a05a902c338638cab71235afe11f59123 Mon Sep 17 00:00:00 2001 From: vogr Date: Thu, 12 Aug 2021 15:57:48 +0000 Subject: [PATCH 2/3] Record retv and seed in a separate, isolated step. --- R/generate.R | 8 +------- R/genthat.R | 9 +++++++++ R/record-test-exts.R | 28 ++++++++++++++++++++++++++++ R/run-generated-tests.R | 2 +- 4 files changed, 39 insertions(+), 8 deletions(-) create mode 100644 R/record-test-exts.R diff --git a/R/generate.R b/R/generate.R index a74ae11d..cde05cc5 100644 --- a/R/generate.R +++ b/R/generate.R @@ -85,7 +85,7 @@ generate_test.genthat_trace <- function(trace, include_trace_dump=FALSE, format_ code <- paste0( - 'genthat_extracted_function <- function() {\n', + 'genthat_extracted_call <- function() {\n', globals, if (nchar(globals) > 0) '\n' else '', call,'\n', @@ -139,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 diff --git a/R/genthat.R b/R/genthat.R index 980d10f2..cfb2dd02 100644 --- a/R/genthat.R +++ b/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)) { diff --git a/R/record-test-exts.R b/R/record-test-exts.R new file mode 100644 index 00000000..7cf8142f --- /dev/null +++ b/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) +} \ No newline at end of file diff --git a/R/run-generated-tests.R b/R/run-generated-tests.R index 3ebf10f0..dabaa876 100644 --- a/R/run-generated-tests.R +++ b/R/run-generated-tests.R @@ -10,7 +10,7 @@ test_generated_file <- function(test) { testthat::test_env() } - capture.output(r <- { source(test, local=env); env$genthat_extracted_function() }) + capture.output(r <- { source(test, local=env); env$genthat_extracted_call() }) r } From e3c4dacc9afaa05836a015ae9249f5cbd1dfbbe2 Mon Sep 17 00:00:00 2001 From: vogr Date: Fri, 13 Aug 2021 11:05:32 +0000 Subject: [PATCH 3/3] Add two example harnesses: - test_files.R using testthat, restoring the unit test functionnality - harness.R for benchmarking --- tools/harnesses/benchmark.R | 75 ++++++++++++++++++++++++++++++++++++ tools/harnesses/test_files.R | 57 +++++++++++++++++++++++++++ 2 files changed, 132 insertions(+) create mode 100755 tools/harnesses/benchmark.R create mode 100755 tools/harnesses/test_files.R diff --git a/tools/harnesses/benchmark.R b/tools/harnesses/benchmark.R new file mode 100755 index 00000000..0939a28e --- /dev/null +++ b/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)) diff --git a/tools/harnesses/test_files.R b/tools/harnesses/test_files.R new file mode 100755 index 00000000..21cb3218 --- /dev/null +++ b/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))