From 6bf4c5c98c7dfe96c4c65ae71514b0851dcfb187 Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Fri, 24 Jun 2016 11:53:26 +0200 Subject: [PATCH 01/66] fix parseFunctionNames() parsing only the first function name. --- R/helpers.R | 50 +++++++++++++++++++++++--------------------------- 1 file changed, 23 insertions(+), 27 deletions(-) diff --git a/R/helpers.R b/R/helpers.R index 3188544..8628392 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -146,38 +146,34 @@ extract_func_name <- function(filename, modify.characters = TRUE){ #' @param ... Functions either as character vectors, or package:::function expressions. #' @return List of parsed package and function names as characters. parseFunctionNames <- function(...) { - args <- as.list(substitute(list(...)))[-1] - i <- 1 + args <- unlist( list(...) ) result <- list() - result[length(args)] <- NULL - while (i <= length(args)) { - tryCatch({ - x <- eval(as.name(paste("..",i,sep=""))) - if (is.character(x)) { - # it is a character vector, use its value - x <- strsplit(x, ":::")[[1]] + result[ length(args) ] <- NULL + i <- 1 + for (arg in args) { + if (is.character(arg)) { + # it is a character vector, use its value + x <- strsplit(arg, ":::")[[1]] + if (length(x) == 1 & nchar(x[1]) > 0) { + x <- strsplit(arg, "::")[[1]] if (length(x) == 1) { - x <- strsplit(x, "::")[[1]] - if (length(x) == 1) - x <- list(NA, x) + x <- c(NA, x) + } else if (length(x) > 2) { + warning( paste0("badly formatted package name: ", arg ) ) } - if (x[[2]] == "") - x[[2]] <- ":::" - result[[i]] <- c(name = x[[2]], package = x[[1]]) - } else { - stop("Use substitured value") - } - }, error = function(e) { - a <- args[[i]] - if (is.name(a)) { - result[[i]] <<- c(name = as.character(a), package = NA) - } else if (is.language(a) && length(a) == 3 && a[[1]] %in% c(as.name(":::"), as.name("::"))) { - result[[i]] <<- c(name = as.character(a[[3]]), package = as.character(a[[2]])) + } else if (length(x) == 1 & nchar(x[1]) == 0) { + x <- c(NA, ":::") + } else if (length(x) == 2 & nchar(x[1]) == 0) { + x <- c(NA, x[2]) + } else if (length(x) == 2 & nchar(x[1]) > 0) { + x <- c(x[1], x[2]) } else { - print("error") - stop(paste("Invalid argument index", i)); + warning( paste0("badly formatted package name: ", arg ) ) } - }) + result[[i]] <- c(name = x[2], package = x[1]) + } else { + stop("Function names should be provided as character string!") + } i <- i + 1 } result From 5a99c80e556e3eb98e21476d2afcc757744cfa34 Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Thu, 7 Jul 2016 13:51:54 +0200 Subject: [PATCH 02/66] improve parseFunctionNames logic flow --- R/helpers.R | 40 +++++++++++++++++++--------------------- 1 file changed, 19 insertions(+), 21 deletions(-) diff --git a/R/helpers.R b/R/helpers.R index 8628392..2ae7b55 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -146,37 +146,35 @@ extract_func_name <- function(filename, modify.characters = TRUE){ #' @param ... Functions either as character vectors, or package:::function expressions. #' @return List of parsed package and function names as characters. parseFunctionNames <- function(...) { - args <- unlist( list(...) ) - result <- list() - result[ length(args) ] <- NULL - i <- 1 + args <- unlist(list(...)) + res <- list() + getInfo <- function(vector, arg, special) { + info <- c() + if (length(vector) > 2) { + warning( sprintf("Invalid function name: %s\n", arg ) ) + info <- c(NA, NA) + } else if (length(vector) == 2) { + info <- unlist( ifelse(nchar(vector[1]) == 0, list(c(NA, vector[2])), list(vector)) ) + } else { + info <- unlist( ifelse(nchar(vector) == 0, list(c(NA, special)), list(c(NA, vector[1]))) ) + } + names(info) <- c("package","name") + list(info) + } for (arg in args) { if (is.character(arg)) { - # it is a character vector, use its value x <- strsplit(arg, ":::")[[1]] + y <- strsplit(arg, "::")[[1]] if (length(x) == 1 & nchar(x[1]) > 0) { - x <- strsplit(arg, "::")[[1]] - if (length(x) == 1) { - x <- c(NA, x) - } else if (length(x) > 2) { - warning( paste0("badly formatted package name: ", arg ) ) - } - } else if (length(x) == 1 & nchar(x[1]) == 0) { - x <- c(NA, ":::") - } else if (length(x) == 2 & nchar(x[1]) == 0) { - x <- c(NA, x[2]) - } else if (length(x) == 2 & nchar(x[1]) > 0) { - x <- c(x[1], x[2]) + res <- c(res, getInfo(y, arg, "::")) } else { - warning( paste0("badly formatted package name: ", arg ) ) + res <- c(res, getInfo(x, arg, ":::")) } - result[[i]] <- c(name = x[2], package = x[1]) } else { stop("Function names should be provided as character string!") } - i <- i + 1 } - result + res } #' @title Returns names of functions defined in given file(s) From 43b6ea989437f933c43ca1dc32a76089c3744c9e Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Tue, 12 Jul 2016 15:30:46 +0200 Subject: [PATCH 03/66] style fix --- R/capture.R | 20 ++++++----- R/generate.R | 99 ++++++++++++++++++++++++++++------------------------ R/testr.R | 78 +++++++++++++++++++---------------------- 3 files changed, 100 insertions(+), 97 deletions(-) diff --git a/R/capture.R b/R/capture.R index 8be9ddb..c018c69 100644 --- a/R/capture.R +++ b/R/capture.R @@ -11,7 +11,7 @@ decorate <- function(func, package, verbose) { if (identical(class(library), "function") && getRversion() < '3.3.0') { suppressMessages(trace(library, - exit=quote(if (!missing(package)) testr:::refresh_decoration(package)), + exit = quote(if (!missing(package)) testr:::refresh_decoration(package)), print = FALSE)) } if (!cache$trace_replaced && getRversion() < '3.3.0') { @@ -32,26 +32,28 @@ decorate <- function(func, package, verbose) { return(invisible()) } } - if (package != ".GlobalEnv") + if (package != ".GlobalEnv") { package <- substr(package, 9, nchar(package)) - else + } else { package <- NA + } } - if (is.na(package)) + if (is.na(package)) { isS3 <- is_s3_generic(func) - else + } else { isS3 <- is_s3_generic(func, getNamespace(package)) + } if (isS3) { warning("Not decorating S3 generic") return(invisible()) } - write.call <- call("write_capture", if (is.na(package)) func else paste(package, func, sep=":::"), quote(sys.frame(-4))) #nolint + write.call <- call("write_capture", if (is.na(package)) func else paste(package, func, sep = ":::"), quote(sys.frame(-4))) #nolint tc <- call("trace", func, quote(write.call), print = testr_options("verbose")) hidden <- FALSE - if (!func %in% ls(as.environment(if (is.na(package)) .GlobalEnv else paste("package", package, sep=":")))) { + if (!func %in% ls(as.environment(if (is.na(package)) .GlobalEnv else paste("package", package, sep = ":")))) { tc[["where"]] <- call("getNamespace", package) hidden <- TRUE } @@ -60,7 +62,7 @@ decorate <- function(func, package, verbose) { } else { suppressMessages(eval(tc)) } - .decorated[[func]] <- list(func=func, package=package, hidden=hidden) + .decorated[[func]] <- list(func = func, package = package, hidden = hidden) } #' @title undecorate function @@ -91,7 +93,7 @@ undecorate <- function(func, verbose) { } else { suppressMessages(do.call(untrace, params)) } - rm(list=c(func), envir=.decorated) + rm(list = c(func), envir = .decorated) } #' @title Write down capture information diff --git a/R/generate.R b/R/generate.R index 0067927..e2de0c6 100644 --- a/R/generate.R +++ b/R/generate.R @@ -8,7 +8,7 @@ #' @param output_dir directory where generated test cases will be saved #' @param verbose wheater display debug output #' @param timed whether result is dependent on time of generation -test_gen <- function(root, output_dir, timed = F, verbose=testr_options("verbose")) { +test_gen <- function(root, output_dir, timed = FALSE, verbose=testr_options("verbose")) { if (verbose) { cat("Output:", output_dir, "\n") cat("Root:", root, "\n") @@ -18,7 +18,7 @@ test_gen <- function(root, output_dir, timed = F, verbose=testr_options("verbose warning("Input dir/file doesn't exist!") return(invisible()) } - if (file.info(root)$isdir){ + if (file.info(root)$isdir) { all.capture <- lapply(list.files(root, recursive=TRUE, all.files = TRUE), function(x) file.path(root,x)) } else { all.capture <- root @@ -26,14 +26,11 @@ test_gen <- function(root, output_dir, timed = F, verbose=testr_options("verbose # output dir checks if (missing(output_dir)) stop("A output directory must be provided!"); if (!file.exists(output_dir) || !file.info(output_dir)$isdir) dir.create(output_dir) - if (timed) - output_dir <- file.path(output_dir, format(Sys.time(), "%Y-%m-%d %H:%M:%S")) + if (timed) output_dir <- file.path(output_dir, format(Sys.time(), "%Y-%m-%d %H:%M:%S")) cache$output_dir <- output_dir # bad.arguments file to store incorrect arguments cache$bad_argv <- file.path(cache$output_dir, "bad_arguments"); - if (!file.exists(cache$bad_argv) - && !file.create(cache$bad_argv)) - stop("Unable to create file: ", cache$bad_argv) + if (!file.exists(cache$bad_argv) && !file.create(cache$bad_argv)) stop("Unable to create file: ", cache$bad_argv) cache$tid <- list() Map(function(x) { process_capture(x) }, all.capture) cache$tid <- NULL @@ -51,19 +48,23 @@ ensure_file <- function(name) { fname <- gsub(.Platform$file.sep, "sep", name) # replace ::: with ___ so that we work on Windows too fname <- gsub(":::", "___", fname) + # check if the folder for the function exists and create it if not tc.folder = file.path(cache$output_dir, fname, fsep = .Platform$file.sep) dir.create(tc.folder, showWarnings = FALSE) + # get the index of the file, based on number of files in the folder (but use the cache information for it) cache$tid[[name]] <- ifelse(is.null(cache$tid[[name]]), 0, cache$tid[[name]] + 1) - tc.file = file.path(tc.folder, paste("test-", cache$tid[[name]], ".R", sep=""), fsep = .Platform$file.sep) - # the file should not exist - if (!file.create(tc.file)) - stop("Unable to create file: ", tc.file) + tc.file = file.path(tc.folder, paste("test.", gsub("___", ".", fname), ".R", sep = ""), fsep = .Platform$file.sep) + # TODO perhaps this is not needed for testthat - write("library(testthat)\n", file = tc.file, append = TRUE) - # write context information (the function name) - write(paste("context(\"",name,"\")\n", sep=""), file = tc.file, append = TRUE) + if (!file.exists(tc.file)) { + file.create(tc.file) + write("library(hamcrest)\n", file = tc.file, append = TRUE) + } else { + write("\n", file = tc.file, append = TRUE) + } + return(tc.file) } @@ -71,10 +72,10 @@ ensure_file <- function(name) { #' #' @description This function parses file with closure capture information and generates test cases #' @param cap_file path to closure capture file -process_capture <- function(cap_file){ +process_capture <- function(cap_file) { lines <- readLines(cap_file) cache$i <- 1 - while (cache$i < length(lines)){ + while (cache$i < length(lines)) { # read test case information symbol.values <- read_symbol_values(lines) symb <- symbol.values[[1]] @@ -88,10 +89,10 @@ process_capture <- function(cap_file){ #### see what we get if (feedback$type == "err") { #### the captured information is not usable - write(feedback$msg, file=cache$bad_argv, append=TRUE); + write(feedback$msg, file = cache$bad_argv, append = TRUE); } else if (feedback$type == "src") { #### good, we get the source code - write(feedback$msg, file=tc.file, append=TRUE); + write(feedback$msg, file = tc.file, append = TRUE); } else { stop("Not reached!"); } @@ -100,14 +101,14 @@ process_capture <- function(cap_file){ } -read_symbol_values <- function(lines){ +read_symbol_values <- function(lines) { k_sym <- 1 k_value <- 1 symb <- vector() vsym <- vector() symb[k_sym] <- "" vsym[k_value] <- "" - while (starts_with(kSymbPrefix, lines[cache$i])){ + while (starts_with(kSymbPrefix, lines[cache$i])) { symb[k_sym] <- paste(symb[k_sym], substr_line(lines[cache$i]), sep = "") cache$i <- cache$i + 1 k_sym <- k_sym + 1 @@ -129,7 +130,7 @@ read_value <- function(lines, prefix){ j <- j + 1 } cache$i <- j - return(paste(value, collapse="\n", sep="")) + return(paste(value, collapse = "\n", sep = "")) } #' @title Generates a testcase for closure function @@ -162,8 +163,9 @@ generate_tc <- function(symb, vsym, func, argv) { valid.argv <- parse_eval(argv) # proper argument should always be packed in a list - if (!valid.argv) - return(list(type="err", msg=paste("func:", func, "\nargv:", argv, "\n"))) + if (!valid.argv) { + return(list(type = "err", msg = paste("func:", func, "\nargv:", argv, "\n"))) + } # TODO: potentially good arguments, alter it # argv.obj.lst <- alter.arguments(argv.obj); @@ -177,42 +179,47 @@ generate_tc <- function(symb, vsym, func, argv) { call.args <- "" arg_names <- names(args) for (i in 1:length(args)) { - if (arg_names[i] != "") - call.args <- paste(call.args, arg_names[i], "=", sep = "") - call.args <- paste(call.args, args[[i]], ",", sep="") + if (arg_names[i] != "") { + call.args <- paste(call.args, arg_names[i], "=", sep = "") + } + call.args <- paste(call.args, args[[i]], ",", sep = "") } call.args <- substr(call.args, 1, nchar(call.args) - 1) - call <- paste(call, sprintf("%s(%s)", func, call.args), "\n", sep="") - } else - call <- paste(call, sprintf("%s(%s)", func, paste(args, collapse=",")), "\n", sep="") + call <- paste(call, sprintf("%s(%s)", func, call.args), "\n", sep = "") + } else { + call <- paste(call, sprintf("%s(%s)", func, paste(args, collapse=",")), "\n", sep = "") + } } else { - call <- paste(call, func, "()", "\n", sep="") + call <- paste(call, func, "()", "\n", sep = "") } - if (length(symb) > 0 && symb[1] != "") - call <- paste(variables, call, sep="") + if (length(symb) > 0 && symb[1] != "") { + call <- paste(variables, call, sep = "") + } cache$warns <- NULL cache$errs <- NULL - retv <- withCallingHandlers(tryCatch(eval(parse(text=call), envir = new.env()), - error=function(e) cache$errs <- e$message, silent = TRUE), - warning=function(w) { - cache$warns <- ifelse(is.null(cache$warns), w$message, paste(cache$warns, w$message, sep="; ")) + retv <- withCallingHandlers(tryCatch( eval(parse(text = call), envir = new.env()), + error = function(e) cache$errs <- e$message, silent = TRUE), + warning = function(w) { + cache$warns <- ifelse(is.null(cache$warns), w$message, paste(cache$warns, w$message, sep = "; ")) invokeRestart("muffleWarning") }) retv <- quoter(retv) # testhat formatter - src <- paste("test_that(", shQuote(cache$tid[[func]]), ", {\n") + src <- paste("test.", gsub(":::", ".", func), ".", cache$tid[[func]], " <- function() {\n\n", sep = "") if (! is.null(cache$errs)) { - call <- paste("expect_error({\n", call, "}\n,", shQuote(cache$errs), ")") + src <- paste(src, "\n expected <- try(", paste(deparse(call), " )", collapse = "\n"), "") + src <- paste(src, "\n assertThat( class(tryResult), equalTo(\"try-error\"))", sep = "") + call <- paste("\n}") } else { - src <- paste(src, "\nexpected <-", paste(deparse(retv), collapse = "\n"), "\n") - call <- paste("expect_equal({", call, "}, expected)") - } - if (! is.null(cache$warns)) { - call <- paste("expect_warning(", call, ", ", shQuote(cache$warns), ")") + src <- paste(src, "\n expected <-", paste(deparse(retv), collapse = "\n"), "") + src <- paste(src, "\n assertThat( ", call, " , ", "equalTo( expected ) )", sep = "") + call <- paste("\n}") } - src <- paste(src, call, "\n})") - src = deparse(parse(text = src)[[1]]) - list(type="src", msg=src); + + src <- paste(src, call) + print(func) + src <- deparse(parse(text = src)[[1]]) + list(type = "src", msg = src); } diff --git a/R/testr.R b/R/testr.R index 532bceb..db6df4f 100644 --- a/R/testr.R +++ b/R/testr.R @@ -14,7 +14,7 @@ #' @export gen_from_function <- function(package.dir = ".", code, functions, filter = TRUE, exclude_existing_tests = FALSE, build = TRUE, timed = FALSE, output, verbose = testr_options("verbose")) { - cleanup = F + cleanup = FALSE # stop all ongoing captures stop_capture_all() if (build) { @@ -27,26 +27,21 @@ gen_from_function <- function(package.dir = ".", code, functions, filter = TRUE, package.path = package.dir } # install the package - if (verbose) - cat(paste("Installing package", package.path, "\n")) - #devtools:::install(package.name, quiet = T) - install.packages(package.path, repos = NULL, quiet = T, type = "source") + if (verbose) cat(paste("Installing package", package.path, "\n")) + install.packages(package.path, repos = NULL, quiet = TRUE, type = "source") # get list of all functions package = devtools::as.package(package.dir) # TODO I don't thing this line is needed anymore l <- library - l(package = package$package, character.only = T) - if (verbose) - cat(paste("Package", package$package, "installed\n")) + l(package = package$package, character.only = TRUE) + if (verbose) cat(paste("Package", package$package, "installed\n")) # if function names were not specified, if (missing(functions)) { # get list of all functions defined in the package' R code functions <- list_functions(file.path(package$path, "R")) - if (verbose) - cat("All functions from package will be decorated\n") + if (verbose) cat("All functions from package will be decorated\n") } - if (verbose) - cat(paste("Decorating",length(functions), "functions\n")) + if (verbose) cat(paste("Decorating",length(functions), "functions\n")) # capture all functions in the package for (f in functions) { decorate(f, package$package, verbose = verbose) @@ -62,7 +57,7 @@ gen_from_function <- function(package.dir = ".", code, functions, filter = TRUE, if (missing(output)) { if (filter) { output = "temp" - cleanup = T + cleanup = TRUE } else { output = file.path(package$path, "tests") } @@ -74,12 +69,11 @@ gen_from_function <- function(package.dir = ".", code, functions, filter = TRUE, if (filter) { if (verbose) cat("Pruning tests - this may take some time...\n") - filter_tests(output, file.path(package$path, "tests/testthat"), functions, package.dir, compact = T, verbose = verbose) + filter_tests(output, file.path(package$path, "tests/testthat"), functions, package.dir, compact = TRUE, verbose = verbose) } # clear the temp folder, if we used a temp folder implicitly - if (cleanup) - unlink(output, recursive = T) - detach(paste("package", package$package, sep=":"), unload = T, character.only = T) + if (cleanup) unlink(output, recursive = T) + detach(paste("package", package$package, sep=":"), unload = TRUE, character.only = TRUE) } @@ -100,32 +94,29 @@ gen_from_function <- function(package.dir = ".", code, functions, filter = TRUE, gen_from_package <- function(package.dir = ".", include.tests = FALSE, timed = FALSE, filter = TRUE, build = TRUE, output, verbose = testr_options("verbose")) { package = devtools::as.package(package.dir) devtools::document(package.dir) - detach(paste("package", package$package, sep=":"), unload = T, character.only = T) + detach(paste("package", package$package, sep=":"), unload = TRUE, character.only = TRUE) f <- function() { # run package vignettes info <- tools::getVignetteInfo(package = package$package) - vdir <- info[,2] - vfiles <- info[,6] + vdir <- info[ ,2] + vfiles <- info[ ,6] p <- file.path(vdir, "doc", vfiles) - if (verbose) - cat(paste("Running vignettes (", length(vfiles), "files)\n")) + if (verbose) cat(paste("Running vignettes (", length(vfiles), "files)\n")) # vignettes are not expected to be runnable, silence errors - invisible(tryCatch(sapply(p, source), error=function(x) invisible())) + invisible( tryCatch( sapply(p, source), error = function(x) invisible() ) ) # run package examples manPath <- file.path(package.dir, "man") - examples <- list.files(manPath, pattern = "\\.[Rr]d$", no.. = T) + examples <- list.files(manPath, pattern = "\\.[Rr]d$", no.. = TRUE) if (length(examples) != 0) { - if (verbose) - cat(paste("Running examples (", length(examples), "man files)\n")) + if (verbose) cat(paste("Running examples (", length(examples), "man files)\n")) for (f in examples) { code <- example_code(file.path(manPath, f)) - tryCatch(eval(parse(text = code)), error=function(x) print(x)) + tryCatch(eval(parse(text = code)), error = function(x) print(x)) } } # run tests if (include.tests) { - if (verbose) - cat("Running package tests\n") + if (verbose) cat("Running package tests\n") testthat::test_dir(file.path(package.dir, "tests", "testthat"), filter = NULL) } } @@ -145,12 +136,11 @@ gen_from_package <- function(package.dir = ".", include.tests = FALSE, timed = F #' @export start_capture <- function(..., verbose = testr_options("verbose")) { old <- testr_options("capture.arguments") - if (old) - testr_options("capture.arguments", FALSE) - for (f in parseFunctionNames(...)) + if (old) testr_options("capture.arguments", FALSE) + for (f in parseFunctionNames(...)) { decorate(f[["name"]], f[["package"]], verbose = verbose) - if (old) - testr_options("capture.arguments", TRUE) + } + if (old) testr_options("capture.arguments", TRUE) invisible(NULL) } @@ -172,8 +162,9 @@ start_capture_builtins <- function(internal.only = FALSE, verbose = testr_option #' @param verbose TRUE to display additional information #' @export stop_capture <- function(..., verbose = testr_options("verbose")) { - for (f in parseFunctionNames(...)) + for (f in parseFunctionNames(...)) { undecorate(f$name, f$package, verbose = verbose) + } invisible(NULL) } @@ -198,11 +189,11 @@ stop_capture_all <- function(verbose = testr_options("verbose")) { #' @param clear_capture if FALSE captured traces will not be deleted after the generation so that subsequent calls to generate() can use them too #' @export generate <- function(output_dir, root = testr_options("capture.folder"), - timed = F, clear_capture = T, verbose = testr_options("verbose")) { + timed = FALSE, clear_capture = TRUE, verbose = testr_options("verbose")) { cache$output.dir <- output_dir test_gen(root, output_dir, timed, verbose = verbose); if (clear_capture) { - unlink(file.path(root, list.files(path = root, no.. = T))) + unlink(file.path(root, list.files(path = root, no.. = TRUE))) } } @@ -273,13 +264,16 @@ gen_from_code <- function(code, output_dir, ...) { #' @param ... Functions to be tested. #' @export gen_from_source <- function(src.root, output_dir, ...) { - if (!file.exists(src.root)) + if (!file.exists(src.root)) { stop("Supplied source does not exist") - if (file.info(src.root)$isdir) - src.root <- list.files(src.root, pattern = "\\[rR]", recursive = T, full.names = T) + } + if (file.info(src.root)$isdir) { + src.root <- list.files(src.root, pattern = "\\[rR]", recursive = TRUE, full.names = TRUE) + } start_capture(...) - for (src.file in src.root) - source(src.file, local = T) + for (src.file in src.root) { + source(src.file, local = TRUE) + } stop_capture_all() generate(output_dir) invisible() From e6e68ec52ba8bcf2acbb595a5834af9d7860db96 Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Mon, 18 Jul 2016 13:09:40 +0200 Subject: [PATCH 04/66] remove duplicated test cases --- NAMESPACE | 1 + R/generate.R | 14 ++++++++++---- man/ensure_file.Rd | 4 +++- 3 files changed, 14 insertions(+), 5 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index b9cd03e..f2d7f1b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,4 +17,5 @@ export(testr_options) export(undecorate) export(write_capture) importFrom(Rcpp,evalCpp) +importFrom(digest,digest) useDynLib(testr) diff --git a/R/generate.R b/R/generate.R index e2de0c6..fc4adb5 100644 --- a/R/generate.R +++ b/R/generate.R @@ -42,8 +42,9 @@ test_gen <- function(root, output_dir, timed = FALSE, verbose=testr_options("ver #' #' @description This function creates a test case file if one does not exist already #' @param name directory where generated test cases will be saved +#' @param funHash hash of function name and function arguments #' @seealso test_gen -ensure_file <- function(name) { +ensure_file <- function(name, funHash) { fname <- gsub(.Platform$file.sep, "sep", name) # replace ::: with ___ so that we work on Windows too @@ -55,14 +56,14 @@ ensure_file <- function(name) { # get the index of the file, based on number of files in the folder (but use the cache information for it) cache$tid[[name]] <- ifelse(is.null(cache$tid[[name]]), 0, cache$tid[[name]] + 1) - tc.file = file.path(tc.folder, paste("test.", gsub("___", ".", fname), ".R", sep = ""), fsep = .Platform$file.sep) + tc.file = file.path(tc.folder, paste("test.", gsub("___", ".", fname), ".", funHash, ".R", sep = ""), fsep = .Platform$file.sep) # TODO perhaps this is not needed for testthat if (!file.exists(tc.file)) { file.create(tc.file) write("library(hamcrest)\n", file = tc.file, append = TRUE) } else { - write("\n", file = tc.file, append = TRUE) + tc.file <- "REPLICATED_TEST_CASE" } return(tc.file) @@ -72,6 +73,7 @@ ensure_file <- function(name) { #' #' @description This function parses file with closure capture information and generates test cases #' @param cap_file path to closure capture file +#' @importFrom digest digest process_capture <- function(cap_file) { lines <- readLines(cap_file) cache$i <- 1 @@ -83,13 +85,17 @@ process_capture <- function(cap_file) { func <- read_value(lines, kFuncPrefix) args <- read_value(lines, kArgsPrefix) - tc.file <- ensure_file(func) + d_func_arg <- digest::digest( paste0(digest::digest(func), digest::digest(args)) ) + + tc.file <- ensure_file(func, d_func_arg) feedback <- generate_tc(symb, vsym, func, args) #### see what we get if (feedback$type == "err") { #### the captured information is not usable write(feedback$msg, file = cache$bad_argv, append = TRUE); + } else if (tc.file == "REPLICATED_TEST_CASE") { + print(tc.file) } else if (feedback$type == "src") { #### good, we get the source code write(feedback$msg, file = tc.file, append = TRUE); diff --git a/man/ensure_file.Rd b/man/ensure_file.Rd index 6a60326..9294590 100644 --- a/man/ensure_file.Rd +++ b/man/ensure_file.Rd @@ -4,10 +4,12 @@ \alias{ensure_file} \title{Manage Test Case file} \usage{ -ensure_file(name) +ensure_file(name, funHash) } \arguments{ \item{name}{directory where generated test cases will be saved} + +\item{funHash}{hash of function name and function arguments} } \description{ This function creates a test case file if one does not exist already From 7e4d3835ca3c1f93b7f9652324a83a233fec2040 Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Mon, 18 Jul 2016 13:10:32 +0200 Subject: [PATCH 05/66] update documentation --- R/generate.R | 2 +- man/bioconductor_gen.Rd | 22 ---------------------- man/capture.Rd | 18 ------------------ man/capture_builtins.Rd | 17 ----------------- man/cran_gen.Rd | 22 ---------------------- man/filter.Rd | 32 -------------------------------- man/gen_from_patch.Rd | 33 --------------------------------- man/generate.Rd | 4 ++-- man/package_gen.Rd | 26 -------------------------- man/run.Rd | 20 -------------------- man/test_gen.Rd | 3 ++- man/testr_addRegression.Rd | 33 --------------------------------- man/testr_code.Rd | 19 ------------------- 13 files changed, 5 insertions(+), 246 deletions(-) delete mode 100644 man/bioconductor_gen.Rd delete mode 100644 man/capture.Rd delete mode 100644 man/capture_builtins.Rd delete mode 100644 man/cran_gen.Rd delete mode 100644 man/filter.Rd delete mode 100644 man/gen_from_patch.Rd delete mode 100644 man/package_gen.Rd delete mode 100644 man/run.Rd delete mode 100644 man/testr_addRegression.Rd delete mode 100644 man/testr_code.Rd diff --git a/R/generate.R b/R/generate.R index fc4adb5..251cfc7 100644 --- a/R/generate.R +++ b/R/generate.R @@ -6,8 +6,8 @@ #' #' @param root a directory containg capture information or capture file #' @param output_dir directory where generated test cases will be saved -#' @param verbose wheater display debug output #' @param timed whether result is dependent on time of generation +#' @param verbose wheater display debug output test_gen <- function(root, output_dir, timed = FALSE, verbose=testr_options("verbose")) { if (verbose) { cat("Output:", output_dir, "\n") diff --git a/man/bioconductor_gen.Rd b/man/bioconductor_gen.Rd deleted file mode 100644 index 088421d..0000000 --- a/man/bioconductor_gen.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testr.R -\name{bioconductor_gen} -\alias{bioconductor_gen} -\title{Capture run information from Bioconductor packages} -\usage{ -bioconductor_gen(name, dir, funcs = NULL, indexes = 1:1000) -} -\arguments{ -\item{name}{name of the package to be downloaded} - -\item{dir}{resulting directory with tests} - -\item{funcs}{functions to Decorate} - -\item{indexes}{indexes of specific packages} -} -\description{ -This function is responsible for getting all possible capture information from Bioconductor -It tries to insstall package and run tests, examples and vignettes -} - diff --git a/man/capture.Rd b/man/capture.Rd deleted file mode 100644 index ae13753..0000000 --- a/man/capture.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testr.R -\name{capture} -\alias{capture} -\title{Enables capturing of the specified functions.} -\usage{ -capture(..., verbose = testr_options("verbose")) -} -\arguments{ -\item{...}{List of functions to capture, either character literals, or symbols} - -\item{verbose}{TRUE to display additional information} -} -\description{ -The functions can be expressed as character literals in the form of either only a function name, -or package name ::: function name, or directly as a symbol (i.e. only function name, or package name ::: function name). -} - diff --git a/man/capture_builtins.Rd b/man/capture_builtins.Rd deleted file mode 100644 index 8128736..0000000 --- a/man/capture_builtins.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testr.R -\name{capture_builtins} -\alias{capture_builtins} -\title{Enables capturing of all builtin functions.} -\usage{ -capture_builtins(internal.only = FALSE, verbose = testr_options("verbose")) -} -\arguments{ -\item{internal.only}{TRUE if only internal functions should be captured} - -\item{verbose}{TRUE to display additional information} -} -\description{ -Wrapper around capture to capture builtin functions -} - diff --git a/man/cran_gen.Rd b/man/cran_gen.Rd deleted file mode 100644 index f911df0..0000000 --- a/man/cran_gen.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testr.R -\name{cran_gen} -\alias{cran_gen} -\title{Capture run information from CRAN packages} -\usage{ -cran_gen(name, dir, funcs = NULL, indexes = 1:10000) -} -\arguments{ -\item{name}{name of the package to be downloaded} - -\item{dir}{resulting directory with tests} - -\item{funcs}{functions to Decorate} - -\item{indexes}{indexes of specific packages} -} -\description{ -This function is responsible for getting all possible capture information from CRAN -It tries to insstall package and run tests, examples and vignettes -} - diff --git a/man/filter.Rd b/man/filter.Rd deleted file mode 100644 index 0dd7e5a..0000000 --- a/man/filter.Rd +++ /dev/null @@ -1,32 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testr.R -\name{filter} -\alias{filter} -\title{Filter the generated tests so that only tests increasing code coverage will be kept.} -\usage{ -filter(test_root, output_dir, ..., package_path = "", remove_tests = FALSE, - compact = FALSE, verbose = testr_options("verbose")) -} -\arguments{ -\item{test_root}{root directory of tests to be filtered} - -\item{output_dir}{resulting directory where tests will be store. If nothing is supplied, tests that don't -increase coverage will be removed from test_root} - -\item{...}{functions that tests should be filtered aganist} - -\item{package_path}{package root of the package that coverage should be measured} - -\item{remove_tests}{if the tests that don't increase coverage should be removed. Default: \code{FALSE}. -This option will be set to \code{TRUE} if \code{output_dir} is not supplied} - -\item{compact}{If TRUE, the filtered tests will be compacted into files one per function, rather than the default one per test.} - -\item{verbose}{whether the additional information should be displayed. Default: \code{TRUE}} -} -\description{ -This function attempts to filter test cases based on code coverage collected by covr package. -Filtering is done in iterational way by measuring code coverage of every test separately and skipping the ones -that don't increase the coverage. -} - diff --git a/man/gen_from_patch.Rd b/man/gen_from_patch.Rd deleted file mode 100644 index 1ec9564..0000000 --- a/man/gen_from_patch.Rd +++ /dev/null @@ -1,33 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testr.R -\name{gen_from_patch} -\alias{gen_from_patch} -\title{Adds regression tests to specified package.} -\usage{ -gen_from_patch(package.dir = ".", code, functions, filter = TRUE, - exclude_existing_tests = FALSE, build = TRUE, timed = FALSE, output, - verbose = testr_options("verbose")) -} -\arguments{ -\item{package.dir}{Name/path to the package, uses devtools notation} - -\item{code}{Function (with no arguments) whose code will be executed and its calls in the package captured.} - -\item{functions}{Functions from the package to be captured, if missing, all package functions will be captured (character vector)} - -\item{filter}{T if the generated tests should be filtered} - -\item{exclude_existing_tests}{If TRUE, existing tests will be ignored from the code coverage} - -\item{build}{T if the package will be built beforehand} - -\item{timed}{TRUE if the tests result depends on time, in which case the current date & time will be appended to the output_dir.} - -\item{output}{If used, specifies where should the tests be unfiltered tests be generated (if not specified, they will use a temp directory and clean it afterwards)} - -\item{verbose}{Prints additional information.} -} -\description{ -Given a package, the code to be executed and a list of functions to capture, the function captures the selected functions from the package, then runs the specified code. It then generates tests from the captured information and using code coverage filters them against existing tests for the package. Those that increase the code coverage will be added to already existing testthat tests for the package. -} - diff --git a/man/generate.Rd b/man/generate.Rd index 69e186a..3d99044 100644 --- a/man/generate.Rd +++ b/man/generate.Rd @@ -4,8 +4,8 @@ \alias{generate} \title{Generates tests from captured information.} \usage{ -generate(output_dir, root = testr_options("capture.folder"), timed = F, - clear_capture = T, verbose = testr_options("verbose")) +generate(output_dir, root = testr_options("capture.folder"), timed = FALSE, + clear_capture = TRUE, verbose = testr_options("verbose")) } \arguments{ \item{output_dir}{Directory to which the tests should be generated.} diff --git a/man/package_gen.Rd b/man/package_gen.Rd deleted file mode 100644 index 97db57c..0000000 --- a/man/package_gen.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testr.R -\name{package_gen} -\alias{package_gen} -\title{Capture run information from package and generate test cases} -\usage{ -package_gen(name, gen.dir, funcs, from.bioc = FALSE, contriburl) -} -\arguments{ -\item{name}{name of the package} - -\item{gen.dir}{resulting directory with tests} - -\item{funcs}{functions to Decorate} - -\item{from.bioc}{if package is from Bioconductior} - -\item{contriburl}{contributor url as in download.packages} - -\item{gen}{if generate test cases} -} -\description{ -This function is responsible for getting all possible capture information from specific package. -It tries to insstall package and run tests, examples and vignettes -} - diff --git a/man/run.Rd b/man/run.Rd deleted file mode 100644 index e64d1f3..0000000 --- a/man/run.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testr.R -\name{run} -\alias{run} -\title{Runs the generated tests.} -\usage{ -run(test_dir, verbose = testr_options("verbose")) -} -\arguments{ -\item{test_dir}{Directory in which the tests are located. If empty, the last output directory for generate or filter functions is assumed.} - -\item{verbose}{TRUE to display additional information.} -} -\value{ -TRUE if all tests passed, FALSE otherwise. -} -\description{ -This function is a shorthand for calling testthat on the previously generated tests. -} - diff --git a/man/test_gen.Rd b/man/test_gen.Rd index cb87605..51b417f 100644 --- a/man/test_gen.Rd +++ b/man/test_gen.Rd @@ -4,7 +4,8 @@ \alias{test_gen} \title{Test Case generator based on capture files} \usage{ -test_gen(root, output_dir, timed = F, verbose = testr_options("verbose")) +test_gen(root, output_dir, timed = FALSE, + verbose = testr_options("verbose")) } \arguments{ \item{root}{a directory containg capture information or capture file} diff --git a/man/testr_addRegression.Rd b/man/testr_addRegression.Rd deleted file mode 100644 index 6b618ab..0000000 --- a/man/testr_addRegression.Rd +++ /dev/null @@ -1,33 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testr.R -\name{testr_addRegression} -\alias{testr_addRegression} -\title{Adds regression tests to specified package.} -\usage{ -testr_addRegression(package.dir = ".", code, functions, filter = TRUE, - exclude_existing_tests = FALSE, build = TRUE, timed = FALSE, output, - verbose = testr_options("verbose")) -} -\arguments{ -\item{package.dir}{Name/path to the package, uses devtools notation} - -\item{code}{Function (with no arguments) whose code will be executed and its calls in the package captured.} - -\item{functions}{Functions from the package to be captured, if missing, all package functions will be captured (character vector)} - -\item{filter}{T if the generated tests should be filtered} - -\item{exclude_existing_tests}{If TRUE, existing tests will be ignored from the code coverage} - -\item{build}{T if the package will be built beforehand} - -\item{timed}{TRUE if the tests result depends on time, in which case the current date & time will be appended to the output_dir.} - -\item{output}{If used, specifies where should the tests be unfiltered tests be generated (if not specified, they will use a temp directory and clean it afterwards)} - -\item{verbose}{Prints additional information.} -} -\description{ -Given a package, the code to be executed and a list of functions to capture, the function captures the selected functions from the package, then runs the specified code. It then generates tests from the captured information and using code coverage filters them against existing tests for the package. Those that increase the code coverage will be added to already existing testthat tests for the package. -} - diff --git a/man/testr_code.Rd b/man/testr_code.Rd deleted file mode 100644 index aaaf697..0000000 --- a/man/testr_code.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testr.R -\name{testr_code} -\alias{testr_code} -\title{Generate tests for give code} -\usage{ -testr_code(code, output_dir, ...) -} -\arguments{ -\item{code}{Code from which the tests will be generated.} - -\item{output_dir}{Directory to which the tests will be generated.} - -\item{...}{functions to be captured during the code execution (same syntax as capture function)} -} -\description{ -Generates tests from given code and specific captured functions -} - From a898733574496e491ab195a87c3a60f1af8887c0 Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Mon, 18 Jul 2016 13:12:07 +0200 Subject: [PATCH 06/66] update documentation --- man/testr_package.Rd | 28 ---------------------------- man/testr_source.Rd | 19 ------------------- 2 files changed, 47 deletions(-) delete mode 100644 man/testr_package.Rd delete mode 100644 man/testr_source.Rd diff --git a/man/testr_package.Rd b/man/testr_package.Rd deleted file mode 100644 index 5a1d832..0000000 --- a/man/testr_package.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testr.R -\name{testr_package} -\alias{testr_package} -\title{Generates tests for a package by running the code associated with it.} -\usage{ -testr_package(package.dir = ".", include.tests = FALSE, timed = FALSE, - filter = TRUE, build = TRUE, output, verbose = testr_options("verbose")) -} -\arguments{ -\item{package.dir}{Name/path to the package, uses devtools notation.} - -\item{include.tests}{If TRUE, captures also execution of package's tests.} - -\item{timed}{TRUE if the tests result depends on time, in which case the current date & time will be appended to the output_dir.} - -\item{filter}{TRUE if generated tests should be filteres so that only those adding to a coverage will be used} - -\item{build}{if to build package before. Default \code{TRUE}} - -\item{output}{If used, specifies where should the tests be unfiltered tests be generated (if not specified, they will use a temp directory and clean it afterwards)} - -\item{verbose}{Prints additional information.} -} -\description{ -Runs the examples, vignettes and possibly tests associated with the package and captures the usage of package's functions. Creates tests from the captured information, filters it according to the already existing tests and if any new tests are found, adds them to package's tests. -} - diff --git a/man/testr_source.Rd b/man/testr_source.Rd deleted file mode 100644 index 3284fcc..0000000 --- a/man/testr_source.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testr.R -\name{testr_source} -\alias{testr_source} -\title{Generate tests for give source} -\usage{ -testr_source(src.root, output_dir, ...) -} -\arguments{ -\item{src.root}{Source file to be executed and captured, or directory containing multiple files.} - -\item{output_dir}{Directory to which the tests will be generated.} - -\item{...}{Functions to be tested.} -} -\description{ -Generates tests by running given source file. -} - From a396b05fd8959730e6ddf2865b54567e34fd2014 Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Mon, 18 Jul 2016 13:12:52 +0200 Subject: [PATCH 07/66] add "unlist" to blacklist since its causing failures --- R/zzz.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/zzz.R b/R/zzz.R index a707efd..124a4ba 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -24,7 +24,9 @@ blacklist <- c(".GlobalEnv", ".Internal", ".Primitive", "substitute", # errors with trace "match.call", ".doTrace", "tracingState", "traceback", "trace", "get0", "forceAndCall", # added in R.3.2.1 - "library" + "library", + # cause error (Parham) + "?", "unlist" ) sys <- c("system.time", "system.file", "sys.status", From a1bc23a1cdf3aa2437e83901f0cde81109344217 Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Mon, 18 Jul 2016 14:58:17 +0200 Subject: [PATCH 08/66] one test per file NOT wrapped in function --- R/generate.R | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/R/generate.R b/R/generate.R index 251cfc7..bed81d3 100644 --- a/R/generate.R +++ b/R/generate.R @@ -213,19 +213,17 @@ generate_tc <- function(symb, vsym, func, argv) { retv <- quoter(retv) # testhat formatter - src <- paste("test.", gsub(":::", ".", func), ".", cache$tid[[func]], " <- function() {\n\n", sep = "") + #src <- paste("test.", gsub(":::", ".", func), ".", cache$tid[[func]], " <- function() {\n\n", sep = "") if (! is.null(cache$errs)) { - src <- paste(src, "\n expected <- try(", paste(deparse(call), " )", collapse = "\n"), "") - src <- paste(src, "\n assertThat( class(tryResult), equalTo(\"try-error\"))", sep = "") - call <- paste("\n}") + # src <- paste(src, "\n expected <- try(", paste(deparse(call), " )", collapse = "\n"), "") + # src <- paste(src, "\n assertThat( class(tryResult), equalTo(\"try-error\"))", sep = "") + # call <- paste("\n}") } else { - src <- paste(src, "\n expected <-", paste(deparse(retv), collapse = "\n"), "") - src <- paste(src, "\n assertThat( ", call, " , ", "equalTo( expected ) )", sep = "") - call <- paste("\n}") + src <- paste(src, "\n expected <-", paste(deparse(retv), collapse = "\n"), "") + call <- paste(src, "\n assertThat( ", call, " , ", "identicalTo( expected, tol = 1e-6 ) )", sep = "") } src <- paste(src, call) - print(func) src <- deparse(parse(text = src)[[1]]) list(type = "src", msg = src); } From 6a457a803d5bb80313d0bb88a4835226fae938b1 Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Mon, 18 Jul 2016 17:29:56 +0200 Subject: [PATCH 09/66] correct parsing during test case generation --- R/generate.R | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/R/generate.R b/R/generate.R index bed81d3..9a89585 100644 --- a/R/generate.R +++ b/R/generate.R @@ -213,17 +213,13 @@ generate_tc <- function(symb, vsym, func, argv) { retv <- quoter(retv) # testhat formatter - #src <- paste("test.", gsub(":::", ".", func), ".", cache$tid[[func]], " <- function() {\n\n", sep = "") - if (! is.null(cache$errs)) { - # src <- paste(src, "\n expected <- try(", paste(deparse(call), " )", collapse = "\n"), "") - # src <- paste(src, "\n assertThat( class(tryResult), equalTo(\"try-error\"))", sep = "") - # call <- paste("\n}") - } else { - src <- paste(src, "\n expected <-", paste(deparse(retv), collapse = "\n"), "") - call <- paste(src, "\n assertThat( ", call, " , ", "identicalTo( expected, tol = 1e-6 ) )", sep = "") + src <- " \n" + if (is.null(cache$errs) && is.null(cache$warns)) { + src <- paste(src, "\nexpected <-", paste(deparse(retv), collapse = "\n"), "\n") + src <- paste(src, "\n\nassertThat(", call, ", equalTo( expected ) )", sep = "") + call <- paste("\n") } - src <- paste(src, call) - src <- deparse(parse(text = src)[[1]]) + src <- paste(src, call, "\n") list(type = "src", msg = src); } From 2141dcdc5a379da200466c22649e2c355fe7c76d Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Tue, 19 Jul 2016 15:11:25 +0200 Subject: [PATCH 10/66] use identicalTo with 1e-6 tolerance instead of equalTo --- R/generate.R | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/R/generate.R b/R/generate.R index 9a89585..179c4b9 100644 --- a/R/generate.R +++ b/R/generate.R @@ -213,13 +213,12 @@ generate_tc <- function(symb, vsym, func, argv) { retv <- quoter(retv) # testhat formatter - src <- " \n" + src <- "" if (is.null(cache$errs) && is.null(cache$warns)) { - src <- paste(src, "\nexpected <-", paste(deparse(retv), collapse = "\n"), "\n") - src <- paste(src, "\n\nassertThat(", call, ", equalTo( expected ) )", sep = "") - call <- paste("\n") + src <- paste(src, "expected <-", paste(deparse(retv), collapse = "\n"), "\n") + call <- paste("\n\nassertThat(", call, ", identicalTo( expected, tol = 1e-6 ) )", sep = "") } - src <- paste(src, call, "\n") + src <- paste(src, call) list(type = "src", msg = src); } From c0829d00092b12484f0ba89c4dbc87bb701e8b11 Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Tue, 26 Jul 2016 10:32:08 +0200 Subject: [PATCH 11/66] output complex numbers with high precision using hexNumeric --- R/generate.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/generate.R b/R/generate.R index 179c4b9..0fcc7dc 100644 --- a/R/generate.R +++ b/R/generate.R @@ -215,7 +215,7 @@ generate_tc <- function(symb, vsym, func, argv) { # testhat formatter src <- "" if (is.null(cache$errs) && is.null(cache$warns)) { - src <- paste(src, "expected <-", paste(deparse(retv), collapse = "\n"), "\n") + src <- paste(src, "expected <-", paste(deparse(retv, control = "hexNumeric"), collapse = "\n"), "\n") call <- paste("\n\nassertThat(", call, ", identicalTo( expected, tol = 1e-6 ) )", sep = "") } From 773647f477b1e7f403f936abeaed83a9acee9491 Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Tue, 26 Jul 2016 11:10:10 +0200 Subject: [PATCH 12/66] save attributes expected values --- R/generate.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/generate.R b/R/generate.R index 0fcc7dc..45cf2f1 100644 --- a/R/generate.R +++ b/R/generate.R @@ -215,7 +215,7 @@ generate_tc <- function(symb, vsym, func, argv) { # testhat formatter src <- "" if (is.null(cache$errs) && is.null(cache$warns)) { - src <- paste(src, "expected <-", paste(deparse(retv, control = "hexNumeric"), collapse = "\n"), "\n") + src <- paste(src, "expected <-", paste(deparse(retv, control = c("hexNumeric", "showAttributes")), collapse = "\n"), "\n") call <- paste("\n\nassertThat(", call, ", identicalTo( expected, tol = 1e-6 ) )", sep = "") } From db44a4c75fa317926853505fdeea5149911c1364 Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Wed, 27 Jul 2016 14:45:38 +0200 Subject: [PATCH 13/66] keepInteger so integers are not converted to doubles during parsing/import. --- R/generate.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/generate.R b/R/generate.R index 45cf2f1..0a9a7d3 100644 --- a/R/generate.R +++ b/R/generate.R @@ -215,7 +215,7 @@ generate_tc <- function(symb, vsym, func, argv) { # testhat formatter src <- "" if (is.null(cache$errs) && is.null(cache$warns)) { - src <- paste(src, "expected <-", paste(deparse(retv, control = c("hexNumeric", "showAttributes")), collapse = "\n"), "\n") + src <- paste(src, "expected <-", paste(deparse(retv, control = c("hexNumeric", "showAttributes", "keepInteger")), collapse = "\n"), "\n") call <- paste("\n\nassertThat(", call, ", identicalTo( expected, tol = 1e-6 ) )", sep = "") } From efe501cbed4360b82d7157911393bd182a7ea848 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 10:48:09 +0200 Subject: [PATCH 14/66] add functions for automated test case generation --- R/generate.R | 37 +++++- R/runTests.R | 354 +++++++++++++++++++++++++++++++++++++++++++++++++++ R/testr.R | 69 ++++++++++ 3 files changed, 454 insertions(+), 6 deletions(-) create mode 100644 R/runTests.R diff --git a/R/generate.R b/R/generate.R index 0a9a7d3..368b290 100644 --- a/R/generate.R +++ b/R/generate.R @@ -8,7 +8,8 @@ #' @param output_dir directory where generated test cases will be saved #' @param timed whether result is dependent on time of generation #' @param verbose wheater display debug output -test_gen <- function(root, output_dir, timed = FALSE, verbose=testr_options("verbose")) { +test_gen <- function(root, output_dir, timed = FALSE, verbose=testr_options("verbose")) +{ if (verbose) { cat("Output:", output_dir, "\n") cat("Root:", root, "\n") @@ -44,7 +45,8 @@ test_gen <- function(root, output_dir, timed = FALSE, verbose=testr_options("ver #' @param name directory where generated test cases will be saved #' @param funHash hash of function name and function arguments #' @seealso test_gen -ensure_file <- function(name, funHash) { +ensure_file <- function(name, funHash) +{ fname <- gsub(.Platform$file.sep, "sep", name) # replace ::: with ___ so that we work on Windows too @@ -74,7 +76,8 @@ ensure_file <- function(name, funHash) { #' @description This function parses file with closure capture information and generates test cases #' @param cap_file path to closure capture file #' @importFrom digest digest -process_capture <- function(cap_file) { +process_capture <- function(cap_file) +{ lines <- readLines(cap_file) cache$i <- 1 while (cache$i < length(lines)) { @@ -107,7 +110,8 @@ process_capture <- function(cap_file) { } -read_symbol_values <- function(lines) { +read_symbol_values <- function(lines) +{ k_sym <- 1 k_value <- 1 symb <- vector() @@ -128,7 +132,8 @@ read_symbol_values <- function(lines) { return(list(symb, vsym)) } -read_value <- function(lines, prefix){ +read_value <- function(lines, prefix) +{ value <- vector() j <- cache$i while (starts_with(prefix, lines[j])){ @@ -147,7 +152,8 @@ read_value <- function(lines, prefix){ #' @param func function name #' @param argv input arguments for a closure function call #' @seealso test_gen ProcessClosure -generate_tc <- function(symb, vsym, func, argv) { +generate_tc <- function(symb, vsym, func, argv) +{ # check validity of symbol values and construct part of the test invalid.symbols <- vector() variables <- "" @@ -222,3 +228,22 @@ generate_tc <- function(symb, vsym, func, argv) { src <- paste(src, call) list(type = "src", msg = src); } + + +#' @title writeCapturedTests +#' @description creates an archive of generated test cases +#' @param path path to store the archive +#' @param test_path location of generated test cases +#' @export +writeCapturedTests <- function(path, test_path= testEnv$test_dir) +{ + tc <- removeFailingTCs() + if (length(tc)) { + if (!dir.exists(path)) + dir.create(path) + zip_call <- paste0("tar -czvf ", path, "/test.", pkg_name, + ".", fname, ".tar.gz -C ", test_path, " .") + system(zip_call) + } +} + diff --git a/R/runTests.R b/R/runTests.R new file mode 100644 index 0000000..1f54f5e --- /dev/null +++ b/R/runTests.R @@ -0,0 +1,354 @@ + +#' @title removeFailingTCs +#' @description removes the test cases that fail in GNU R +#' @export +removeFailingTCs <- function() +{ + ## check if generated test cases run without failure + # get the generated test cases + capt_dir <- getCaptDir() + tc <- getTests(capt_dir) + # check which test cases fail? + res <- sapply(tc, function(x) { + oldGlobals <- c(ls(.GlobalEnv), "testEnv") + z = try(source(x, local = .GlobalEnv)) + allGlobals <- ls(.GlobalEnv) + allGlobals <- allGlobals[!is.element(allGlobals, oldGlobals)] + rm(list = allGlobals, envir = .GlobalEnv) + inherits(z, "try-error") + }) + # remove failing test cases + unlink(names(res[res == TRUE])) + getTests(capt_dir) +} + +#' @title findPackagesUsingFunction +#' @description find packages that use the function of interest +#' @param functionName name of the function +#' @export +findPackagesUsingFunction <- function(functionName, limit = 100, lib.loc = NULL) +{ + require(stringr) + top <- c() + if(missing(lib.loc)) + lib.loc <- .libPaths()[1] + + call <- paste0("egrep -R -n \'\\<",functionName,"\\>\' ",lib.loc) + res <- system(call, intern = TRUE) + + # remove line that dont start with library path + if(length(res)) { + keep <- grepl(.libPaths()[1], res) + res <- res[keep] + # remove library path + res <- sapply(res, function(x) { + strsplit(x[[1]], .libPaths()[1])[[1]][2]}, + simplify = TRUE, USE.NAMES = FALSE) + # select package name from path + res <- sapply(res, function(x) { + strsplit(x[[1]], "/")[[1]][2]}, + simplify = TRUE, USE.NAMES = FALSE) + # make a count table from package name occurence + if(length(res) > 0) { + resTab <- as.data.frame(unclass(rle(sort(res))))[ , 2:1] + resTab <- resTab[with(resTab, order(-lengths)), ] + if (nrow(resTab < threshold)) + top <- row.names(resTab) + else + top <- row.names(resTab[1:threshold, ]) + } + } + top +} + +#' @title runPackageTests +#' @description ectract and run example/test codes from package +#' @param pkg name of the packge +#' @export +runPackageTests <- function (pkg, lib.loc = NULL, outDir) +{ + pkgdir <- find.package(pkg) + owd1 <- setwd(outDir) + # on.exit(setwd(owd1)) + + .createExdotR <- function (pkg, pkgdir, silent = FALSE, use_gct = FALSE, addTiming = FALSE, ..., commentDontrun = TRUE, commentDonttest = TRUE) + { + Rfile <- paste0(pkg, "-Ex.R") + db <- tools::Rd_db(basename(pkgdir), lib.loc = dirname(pkgdir)) + if (!length(db)) { + message("no parsed files found") + return(invisible(NULL)) + } + files <- names(db) + if (pkg == "grDevices") + files <- files[!grepl("^(unix|windows)/", files)] + filedir <- tempfile() + dir.create(filedir) + on.exit(unlink(filedir, recursive = TRUE)) + cnt <- 0L + for (f in files) { + nm <- sub("\\.[Rr]d$", "", basename(f)) + tools::Rd2ex(db[[f]], file.path(filedir, paste(nm, "R", sep = ".")), + defines = NULL, commentDontrun = commentDontrun, + commentDonttest = commentDonttest) + cnt <- cnt + 1L + if (!silent && cnt%%10L == 0L) + message(".", appendLF = FALSE, domain = NA) + } + nof <- length(Sys.glob(file.path(filedir, "*.R"))) + if (!nof) + return(invisible(NULL)) + massageExamples <- function (pkg, files, outFile = stdout(), ..., commentDonttest = TRUE) + { + if (dir.exists(files[1L])) { + old <- Sys.setlocale("LC_COLLATE", "C") + files <- sort(Sys.glob(file.path(files, "*.R"))) + Sys.setlocale("LC_COLLATE", old) + } + if (is.character(outFile)) { + out <- file(outFile, "wt") + on.exit(close(out)) + } + else { + out <- outFile + } + + lines <- c( + paste0("pkgname <- \"", pkg, "\""), + paste0("testr:::setExamedPkgName(\"", pkg, "\")"), + "assign(\"par.postscript\", graphics::par(no.readonly = TRUE))", + "options(contrasts = c(unordered = \"contr.treatment\", ordered = \"contr.poly\"))", + "graphics.off()" + ) + cat(lines, sep = "\n", file = out) + if (pkg == "tcltk") { + if (capabilities("tcltk")) + cat("require('tcltk')\n\n", file = out) + else + cat("stop(\"tcltk not found!\")\n\n", file = out) + } + else if (pkg != "base") + cat("library('", pkg, "')\n\n", sep = "", file = out) + + for (file in files) { + nm <- sub("\\.R$", "", basename(file)) + nm <- gsub("[^- .a-zA-Z0-9_]", ".", nm, perl = TRUE, useBytes = TRUE) + if (pkg == "grDevices" && nm == "postscript") next + if (pkg == "graphics" && nm == "text") next + if (!file.exists(file)) stop("file ", file, " cannot be opened", domain = NA) + lines <- readLines(file) + + patterns <- c("^[[:space:]]*#", "^[[:space:]]*help\\(", + "^[[:space:]]*\\?", "^[[:space:]]*help\\.search", + "^[[:space:]]*nameEx.{2}help\\.search", "demo\\(", + "data\\(package", "data\\(\\)", + "^library\\(\\)", "^library\\(lib\\.loc"#, + #"\\([[:space:]]*help\\(", "[[:space:]]*vignette\\(" + ) + + for (pattern in patterns) { + com <- grep(pattern, lines, perl = TRUE, useBytes = TRUE) + if (length(com)) + lines <- lines[-com] + } + + have_par <- any(grepl("[^a-zA-Z0-9.]par\\(|^par\\(", lines, perl = TRUE, useBytes = TRUE)) + have_contrasts <- any(grepl("options\\(contrasts", lines, perl = TRUE, useBytes = TRUE)) + cat("### * ", nm, "\n\n", sep = "", file = out) + if (commentDonttest) { + dont_test <- FALSE + for (line in lines) { + if (any(grepl("^[[:space:]]*## No test:", line, perl = TRUE, useBytes = TRUE))) dont_test <- TRUE + if (!dont_test) cat(line, "\n", sep = "", file = out) + if (any(grepl("^[[:space:]]*## End\\(No test\\)", line, perl = TRUE, useBytes = TRUE))) dont_test <- FALSE + } + } + else for (line in lines) { + if (!(line = "")) { + cat(line, "\n", sep = "", file = out) + } + } + if (have_par) cat("graphics::par(get(\"par.postscript\"))\n", file = out) + if (have_contrasts) cat("base::options(contrasts = c(unordered = \"contr.treatment\",", "ordered = \"contr.poly\"))\n", sep = "", file = out) + } + cat("###### FOOTER ######\n", file = out) + cat("options(digits = 7L)\n", file = out) + cat("grDevices::dev.off()\n", file = out) + } + + massageExamples(pkg, filedir, Rfile, commentDonttest = commentDonttest, ...) + invisible(Rfile) + } + + message(gettextf("Testing examples for package %s", sQuote(pkg)), + domain = NA) + Rfile <- .createExdotR(pkg, pkgdir, silent = TRUE) + if (length(Rfile)) { + for (file in Rfile) { + print(paste0("@@@@@@@@@@ START EXAMPLE: ", file, " @@@@@@@@@@")) + oldGlobals <- c(ls(.GlobalEnv), "testEnv") + tryCatch( source(file, echo = FALSE, local = .GlobalEnv), error = function(e) print(e) ) + allGlobals <- ls(.GlobalEnv) + allGlobals <- allGlobals[!is.element(allGlobals, oldGlobals)] + rm(list = allGlobals, envir = .GlobalEnv) + print(paste0("@@@@@@@@@@ DONE WITH EXAMPLE: ", file, " @@@@@@@@@@")) + } + } else { + warning(gettextf("no examples found for package %s", sQuote(pkg)), call. = FALSE, domain = NA) + } + + d <- file.path(pkgdir, "tests") + this <- paste(pkg, "tests", sep = "-") + unlink(this, recursive = TRUE) + dir.create(this) + file.copy(Sys.glob(file.path(d, "*")), this, recursive = TRUE) + owd2 <- setwd(".") + setwd(this) + on.exit(setwd(owd2)) + message(gettextf("Running specific tests for package %s", sQuote(pkg)), domain = NA) + Rfiles <- dir(".", pattern = "\\.R$") + if (length(Rfiles)) { + for (file in Rfiles) { + print(paste0("&&&&&&& START TEST: ", file, " &&&&&&&")) + oldGlobals <- c(ls(.GlobalEnv), "testEnv") + tryCatch( source(file, echo = FALSE, local = .GlobalEnv), error = function(e) print(e) ) + allGlobals <- ls(.GlobalEnv) + allGlobals <- allGlobals[!is.element(allGlobals, oldGlobals)] + rm(list = allGlobals, envir = .GlobalEnv) + print(paste0("&&&&&&& DONE WITH TEST: ", file, " &&&&&&&")) + } + } + invisible(0L) +} + + +#' @title runAllTests +#' @description run all the test/example codes from all the selected packages +#' @param outDir root dir +#' @param scope how to prioritize/select packages to run +#' @param pkg_limit maximum number of packages to use for test generation +#' @param custom_pkg_list custom list of packages of interest to use for test generation +#' @export +runAllTests <- + function (outDir = ".", errorsAreFatal = FALSE, + scope = c("all", "base", "recommended", "top"), + srcdir = NULL, pkg_limit = NULL, + custom_pkg_list = NULL) + { + ow <- options(warn = 1); on.exit(ow); scope <- match.arg(scope); + status <- 0L; pkgs <- character(); + + known_packages <- tools:::.get_standard_package_names() + all_avail_packages <- names(installed.packages()[ ,1]) + avail_packages <- all_avail_packages[!is.element(all_avail_packages, c(known_packages$base, known_packages$recommended))] + + pkgs <- c(character(0)) + + if (scope %in% c("all", "base")) + pkgs <- known_packages$base + if (scope %in% c("all", "recommended")) + pkgs <- c(pkgs, known_packages$recommended) + if (scope %in% c("all")) + pkgs <- c(pkgs, avail_packages) + if (scope %in% c("top")) + pkgs <- c( + do.call( + findPackagesUsingFunction, + list(functionName = testEnv$fname, limit = pkg_limit, lib.loc = NULL), + envir = testEnv), + pkgs) + if (!is.na(custom_pkg_list)) { + pkgs <- c( custom_pkg_list[ is.element(custom_pkg_list, all_avail_packages) ], pkgs ) + } + if (pkg_limit > 0) + pkgs <- pkgs[ 1:pkg_limit ] + + pkgs <- pkgs[ !duplicated(pkgs) ] + + # Sometimes last value is NA + pkgs <- pkgs[!is.na(pkgs)] + pkgs <- pkgs[!pkgs == "NA"] + + if (scope %in% c("top") && length(pkgs) < pkg_limit ) { + pkgs <- c(known_packages$base, known_packages$recommended, avail_packages) + pkgs <- pkgs[ !duplicated(pkgs) ] + pkgs <- pkgs[1:pkg_limit] + } + + if(length(pkgs)) { + print("Selected packages:") + print(pkgs) + for (pkg in pkgs) { + print(paste0("############ START PACKAGE: ", pkg, " #######")) + + tryCatch(runPackageTests(pkg, .Library, outDir), error = function(e) print(e) ) + + print(paste0("############ DONE WITH PACKAGE: ", pkg, " #######")) + } + } else { + print("No packages were selected for example/test code extraction") + } + invisible(status) + } + +#' @title getTests +#' @description get the names of all generated test cases +#' @param capt_dir location of test cases +#' @export +getTests <- function(capt_dir) +{ + d <- list.files(capt_dir, pattern = ".R$", recursive = TRUE, + full.names = TRUE) + rm <- grep("^capture", list.files(capt_dir, recursive = TRUE)) + if (length(rm)) + d <- d[-rm] + d +} + +#' @title generateTestCases +#' @description generates test cases based on environmental variables +#' @import devtools methods +#' @export +generateTestCases <- function(){ + setFunctionName(Sys.getenv("function_name")) + setPkgName(Sys.getenv("package_name")) + setJob(Sys.getenv("JOB_NAME")) + setBuild(Sys.getenv("BUILD_NUMBER")) + setPkgLimit(Sys.getenv("pkg_limit")) + setScope(Sys.getenv("scope")) + setRoot(getwd()) + + if (as.logical(Sys.getenv("install_testr"))) { + if(!require(devtools)){ + install.packages("devtools", dependencies = TRUE, + repos = "http://cloud.r-project.org/") + library(devtools) + } + install_git("https://github.com/psolaimani/testr.git", branch = "master", + upgrade_dependencies = FALSE) + install_git("https://github.com/bedatadriven/hamcrest.git", + branch = "master", upgrade_dependencies = FALSE) + } + + setTestOutDir(paste0(testEnv$root, "/", testEnv$job, "_", testEnv$build)) + dir.create(testEnv$testOutDir, recursive = TRUE) + start_capture( paste(testEnv$pkg_name, "::", testEnv$fname, sep = ""), + verbose = TRUE ) + runAllTests( + outDir = testEnv$testOutDir, scope = testEnv$scope, + pkg_limit = as.numeric(testEnv$pkg_limit), + custom_pkg_list = testEnv$custom_pkg_list + ) + + setwd(testEnv$root) + stop_capture_all() + generate("capture") + + setCaptDir(file.path(testEnv$root,"capture")) + + setArchDir(file.path(testEnv$root,"tests")) + setTestDir(file.path(testEnv$root,"capture",paste0(testEnv$pkg_name,"___", + testEnv$fname))) + + writeCapturedTests(testEnv$arch_dir, testEnv$test_dir) +} diff --git a/R/testr.R b/R/testr.R index db6df4f..c95ad8f 100644 --- a/R/testr.R +++ b/R/testr.R @@ -280,3 +280,72 @@ gen_from_source <- function(src.root, output_dir, ...) { } +# setup environment +testEnv <- new.env(parent = .GlobalEnv) +testEnv$pkgname <- c() +testEnv$pkg_name <- c() +testEnv$fname <- c() +testEnv$job <- c() +testEnv$build <- c() +testEnv$pkg_limit <- integer() +testEnv$scope <- c() +testEnv$custom_pkg_list <- NA +testEnv$root <- c() # getwd() +testEnv$testOutDir <- c() # paste0(getwd(), "/", testEnv$job, "_", testEnv$build) +testEnv$capt_dir <- c() # file.path(testEnv$root,"capture") +testEnv$arch_dir <- c() # file.path(testEnv$root,"tests") +testEnv$test_dir <- c() # file.path(testEnv$root,"capture",paste0(testEnv$pkg_name,"___", testEnv$fname)) + + +setExamedPkgName <- function(pkgname) +{ + testEnv$pkgname <- pkgname +} +setPkgName <- function(pkg_name) +{ + testEnv$pkg_name <- pkg_name +} +setFunctionName <- function(fname) +{ + testEnv$fname <- fname +} +setJob <- function(job) +{ + testEnv$job <- job +} +setBuild <- function(build) +{ + testEnv$build <- build +} +setPkgLimit <- function(limit) +{ + testEnv$pkg_limit <- limit +} +setScope <- function(scope = c("all")) +{ + testEnv$scope <- scope +} +setCustomPkgList <- function(pkgs) +{ + testEnv$custom_pkg_list <- pkgs +} +setRoot <- function(root) +{ + testEnv$root <- root +} +setTestOutDir <- function(test_out_dir) +{ + testEnv$testOutDir <- test_out_dir +} +setCaptDir <- function(capt_dir){ + testEnv$capt_dir <- capt_dir +} +getCaptDir <- function(){ + testEnv$capt_dir +} +setArchDir <- function(arch_dir){ + testEnv$arch_dir <- arch_dir +} +setTestDir <- function(test_dir){ + testEnv$test_dir <- test_dir +} From 6f7f3dd129152d6bf4058583c77adbc3878e7c35 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 10:48:34 +0200 Subject: [PATCH 15/66] update package namespace/description --- DESCRIPTION | 8 ++++---- NAMESPACE | 9 +++++++++ 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 92b74f4..31083f1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,9 +1,9 @@ Package: testr Type: Package -Title: What the Package Does (Title Case) -Version: 0.1.0 -Author: Who wrote it -Maintainer: Who to complain to +Title: R test case generator +Version: 0.1.3 +Author: Github com allr +Maintainer: Parham Solaimani Description: Package aimed at generating testthat compatible tests. License: GPL (>= 2) Imports: diff --git a/NAMESPACE b/NAMESPACE index f2d7f1b..fc71a31 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,12 +2,18 @@ export(clear_decoration) export(decorate) +export(findPackagesUsingFunction) export(gen_from_code) export(gen_from_function) export(gen_from_package) export(gen_from_source) export(generate) +export(generateTestCases) +export(getTests) export(prune) +export(removeFailingTCs) +export(runAllTests) +export(runPackageTests) export(setup_capture) export(start_capture) export(start_capture_builtins) @@ -15,7 +21,10 @@ export(stop_capture) export(stop_capture_all) export(testr_options) export(undecorate) +export(writeCapturedTests) export(write_capture) +import(devtools) +import(methods) importFrom(Rcpp,evalCpp) importFrom(digest,digest) useDynLib(testr) From 3761931dc83944682fc78f50d91ea6a46803b359 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 10:48:45 +0200 Subject: [PATCH 16/66] add doc --- man/findPackagesUsingFunction.Rd | 15 +++++++++++++++ man/generateTestCases.Rd | 12 ++++++++++++ man/getTests.Rd | 15 +++++++++++++++ man/removeFailingTCs.Rd | 12 ++++++++++++ man/runAllTests.Rd | 23 +++++++++++++++++++++++ man/runPackageTests.Rd | 15 +++++++++++++++ man/writeCapturedTests.Rd | 17 +++++++++++++++++ 7 files changed, 109 insertions(+) create mode 100644 man/findPackagesUsingFunction.Rd create mode 100644 man/generateTestCases.Rd create mode 100644 man/getTests.Rd create mode 100644 man/removeFailingTCs.Rd create mode 100644 man/runAllTests.Rd create mode 100644 man/runPackageTests.Rd create mode 100644 man/writeCapturedTests.Rd diff --git a/man/findPackagesUsingFunction.Rd b/man/findPackagesUsingFunction.Rd new file mode 100644 index 0000000..60e1e6d --- /dev/null +++ b/man/findPackagesUsingFunction.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runTests.R +\name{findPackagesUsingFunction} +\alias{findPackagesUsingFunction} +\title{findPackagesUsingFunction} +\usage{ +findPackagesUsingFunction(functionName, limit = 100, lib.loc = NULL) +} +\arguments{ +\item{functionName}{name of the function} +} +\description{ +find packages that use the function of interest +} + diff --git a/man/generateTestCases.Rd b/man/generateTestCases.Rd new file mode 100644 index 0000000..04194d6 --- /dev/null +++ b/man/generateTestCases.Rd @@ -0,0 +1,12 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runTests.R +\name{generateTestCases} +\alias{generateTestCases} +\title{generateTestCases} +\usage{ +generateTestCases() +} +\description{ +generates test cases based on environmental variables +} + diff --git a/man/getTests.Rd b/man/getTests.Rd new file mode 100644 index 0000000..309d01d --- /dev/null +++ b/man/getTests.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runTests.R +\name{getTests} +\alias{getTests} +\title{getTests} +\usage{ +getTests(capt_dir) +} +\arguments{ +\item{capt_dir}{location of test cases} +} +\description{ +get the names of all generated test cases +} + diff --git a/man/removeFailingTCs.Rd b/man/removeFailingTCs.Rd new file mode 100644 index 0000000..0b5ddec --- /dev/null +++ b/man/removeFailingTCs.Rd @@ -0,0 +1,12 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runTests.R +\name{removeFailingTCs} +\alias{removeFailingTCs} +\title{removeFailingTCs} +\usage{ +removeFailingTCs() +} +\description{ +removes the test cases that fail in GNU R +} + diff --git a/man/runAllTests.Rd b/man/runAllTests.Rd new file mode 100644 index 0000000..3c99bdf --- /dev/null +++ b/man/runAllTests.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runTests.R +\name{runAllTests} +\alias{runAllTests} +\title{runAllTests} +\usage{ +runAllTests(outDir = ".", errorsAreFatal = FALSE, scope = c("all", "base", + "recommended", "top"), srcdir = NULL, pkg_limit = NULL, + custom_pkg_list = NULL) +} +\arguments{ +\item{outDir}{root dir} + +\item{scope}{how to prioritize/select packages to run} + +\item{pkg_limit}{maximum number of packages to use for test generation} + +\item{custom_pkg_list}{custom list of packages of interest to use for test generation} +} +\description{ +run all the test/example codes from all the selected packages +} + diff --git a/man/runPackageTests.Rd b/man/runPackageTests.Rd new file mode 100644 index 0000000..782ddb1 --- /dev/null +++ b/man/runPackageTests.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runTests.R +\name{runPackageTests} +\alias{runPackageTests} +\title{runPackageTests} +\usage{ +runPackageTests(pkg, lib.loc = NULL, outDir) +} +\arguments{ +\item{pkg}{name of the packge} +} +\description{ +ectract and run example/test codes from package +} + diff --git a/man/writeCapturedTests.Rd b/man/writeCapturedTests.Rd new file mode 100644 index 0000000..4e2f769 --- /dev/null +++ b/man/writeCapturedTests.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/generate.R +\name{writeCapturedTests} +\alias{writeCapturedTests} +\title{writeCapturedTests} +\usage{ +writeCapturedTests(path, test_path = testEnv$test_dir) +} +\arguments{ +\item{path}{path to store the archive} + +\item{test_path}{location of generated test cases} +} +\description{ +creates an archive of generated test cases +} + From bcb9ea1a6926245fdbad8987582ed1a6ecc68a2c Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 11:06:38 +0200 Subject: [PATCH 17/66] fix issue #1 --- R/runTests.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index 1f54f5e..885f5e2 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -52,10 +52,10 @@ findPackagesUsingFunction <- function(functionName, limit = 100, lib.loc = NULL) if(length(res) > 0) { resTab <- as.data.frame(unclass(rle(sort(res))))[ , 2:1] resTab <- resTab[with(resTab, order(-lengths)), ] - if (nrow(resTab < threshold)) + if (nrow(resTab < limit)) top <- row.names(resTab) else - top <- row.names(resTab[1:threshold, ]) + top <- row.names(resTab[1:limit, ]) } } top From 08b626bc0b38b2ace867d1dca3b78001e6dcad10 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 11:19:56 +0200 Subject: [PATCH 18/66] fix syntax (issue #2) --- R/generate.R | 4 ++-- R/runTests.R | 50 +++++++++++++++++++++++++------------------------- R/testr.R | 32 ++++++++++++++++++-------------- 3 files changed, 45 insertions(+), 41 deletions(-) diff --git a/R/generate.R b/R/generate.R index 368b290..efa1034 100644 --- a/R/generate.R +++ b/R/generate.R @@ -235,9 +235,9 @@ generate_tc <- function(symb, vsym, func, argv) #' @param path path to store the archive #' @param test_path location of generated test cases #' @export -writeCapturedTests <- function(path, test_path= testEnv$test_dir) +write_captured_tests <- function(path, test_path= testEnv$test_dir) { - tc <- removeFailingTCs() + tc <- remove_failing_tcs() if (length(tc)) { if (!dir.exists(path)) dir.create(path) diff --git a/R/runTests.R b/R/runTests.R index 885f5e2..d6c64b5 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -1,8 +1,8 @@ -#' @title removeFailingTCs +#' @title remove_failing_tcs #' @description removes the test cases that fail in GNU R #' @export -removeFailingTCs <- function() +remove_failing_tcs <- function() { ## check if generated test cases run without failure # get the generated test cases @@ -22,11 +22,11 @@ removeFailingTCs <- function() getTests(capt_dir) } -#' @title findPackagesUsingFunction +#' @title find_packages_using_function #' @description find packages that use the function of interest #' @param functionName name of the function #' @export -findPackagesUsingFunction <- function(functionName, limit = 100, lib.loc = NULL) +find_packages_using_function <- function(functionName, limit = 100, lib.loc = NULL) { require(stringr) top <- c() @@ -65,7 +65,7 @@ findPackagesUsingFunction <- function(functionName, limit = 100, lib.loc = NULL) #' @description ectract and run example/test codes from package #' @param pkg name of the packge #' @export -runPackageTests <- function (pkg, lib.loc = NULL, outDir) +run_package_tests <- function (pkg, lib.loc = NULL, outDir) { pkgdir <- find.package(pkg) owd1 <- setwd(outDir) @@ -222,14 +222,14 @@ runPackageTests <- function (pkg, lib.loc = NULL, outDir) } -#' @title runAllTests +#' @title run_all_tests #' @description run all the test/example codes from all the selected packages #' @param outDir root dir #' @param scope how to prioritize/select packages to run #' @param pkg_limit maximum number of packages to use for test generation #' @param custom_pkg_list custom list of packages of interest to use for test generation #' @export -runAllTests <- +run_all_tests <- function (outDir = ".", errorsAreFatal = FALSE, scope = c("all", "base", "recommended", "top"), srcdir = NULL, pkg_limit = NULL, @@ -253,8 +253,8 @@ runAllTests <- if (scope %in% c("top")) pkgs <- c( do.call( - findPackagesUsingFunction, - list(functionName = testEnv$fname, limit = pkg_limit, lib.loc = NULL), + find_packages_using_function, + list(functionName = testEnv$fname, limit = testEnv$pkg_limit, lib.loc = NULL), envir = testEnv), pkgs) if (!is.na(custom_pkg_list)) { @@ -281,7 +281,7 @@ runAllTests <- for (pkg in pkgs) { print(paste0("############ START PACKAGE: ", pkg, " #######")) - tryCatch(runPackageTests(pkg, .Library, outDir), error = function(e) print(e) ) + tryCatch(run_package_tests(pkg, .Library, outDir), error = function(e) print(e) ) print(paste0("############ DONE WITH PACKAGE: ", pkg, " #######")) } @@ -291,11 +291,11 @@ runAllTests <- invisible(status) } -#' @title getTests +#' @title get_tests #' @description get the names of all generated test cases #' @param capt_dir location of test cases #' @export -getTests <- function(capt_dir) +get_tests <- function(capt_dir) { d <- list.files(capt_dir, pattern = ".R$", recursive = TRUE, full.names = TRUE) @@ -310,13 +310,13 @@ getTests <- function(capt_dir) #' @import devtools methods #' @export generateTestCases <- function(){ - setFunctionName(Sys.getenv("function_name")) - setPkgName(Sys.getenv("package_name")) - setJob(Sys.getenv("JOB_NAME")) - setBuild(Sys.getenv("BUILD_NUMBER")) - setPkgLimit(Sys.getenv("pkg_limit")) - setScope(Sys.getenv("scope")) - setRoot(getwd()) + set_function_name(Sys.getenv("function_name")) + set_pkg_name(Sys.getenv("package_name")) + set_job(Sys.getenv("JOB_NAME")) + set_build(Sys.getenv("BUILD_NUMBER")) + set_pkg_limit(Sys.getenv("pkg_limit")) + set_scope(Sys.getenv("scope")) + set_root(getwd()) if (as.logical(Sys.getenv("install_testr"))) { if(!require(devtools)){ @@ -330,11 +330,11 @@ generateTestCases <- function(){ branch = "master", upgrade_dependencies = FALSE) } - setTestOutDir(paste0(testEnv$root, "/", testEnv$job, "_", testEnv$build)) + set_test_out_dir(paste0(testEnv$root, "/", testEnv$job, "_", testEnv$build)) dir.create(testEnv$testOutDir, recursive = TRUE) start_capture( paste(testEnv$pkg_name, "::", testEnv$fname, sep = ""), verbose = TRUE ) - runAllTests( + run_all_tests( outDir = testEnv$testOutDir, scope = testEnv$scope, pkg_limit = as.numeric(testEnv$pkg_limit), custom_pkg_list = testEnv$custom_pkg_list @@ -344,11 +344,11 @@ generateTestCases <- function(){ stop_capture_all() generate("capture") - setCaptDir(file.path(testEnv$root,"capture")) + set_capt_dir(file.path(testEnv$root,"capture")) - setArchDir(file.path(testEnv$root,"tests")) - setTestDir(file.path(testEnv$root,"capture",paste0(testEnv$pkg_name,"___", + set_arch_dir(file.path(testEnv$root,"tests")) + set_test_dir(file.path(testEnv$root,"capture",paste0(testEnv$pkg_name,"___", testEnv$fname))) - writeCapturedTests(testEnv$arch_dir, testEnv$test_dir) + write_captured_tests(testEnv$arch_dir, testEnv$test_dir) } diff --git a/R/testr.R b/R/testr.R index c95ad8f..cd45ed3 100644 --- a/R/testr.R +++ b/R/testr.R @@ -297,55 +297,59 @@ testEnv$arch_dir <- c() # file.path(testEnv$root,"tests") testEnv$test_dir <- c() # file.path(testEnv$root,"capture",paste0(testEnv$pkg_name,"___", testEnv$fname)) -setExamedPkgName <- function(pkgname) +set_examed_pkg_name <- function(pkgname) { testEnv$pkgname <- pkgname } -setPkgName <- function(pkg_name) +set_pkg_name <- function(pkg_name) { testEnv$pkg_name <- pkg_name } -setFunctionName <- function(fname) +set_function_name <- function(fname) { testEnv$fname <- fname } -setJob <- function(job) +set_job <- function(job) { testEnv$job <- job } -setBuild <- function(build) +set_build <- function(build) { testEnv$build <- build } -setPkgLimit <- function(limit) +set_pkg_limit <- function(limit) { testEnv$pkg_limit <- limit } -setScope <- function(scope = c("all")) +set_scope <- function(scope = c("all")) { testEnv$scope <- scope } -setCustomPkgList <- function(pkgs) +set_custom_pkg_list <- function(pkgs) { testEnv$custom_pkg_list <- pkgs } -setRoot <- function(root) +set_root <- function(root) { testEnv$root <- root } -setTestOutDir <- function(test_out_dir) +set_test_out_dir <- function(test_out_dir) { testEnv$testOutDir <- test_out_dir } -setCaptDir <- function(capt_dir){ +set_capt_dir <- function(capt_dir) +{ testEnv$capt_dir <- capt_dir } -getCaptDir <- function(){ +get_capt_dir <- function() +{ testEnv$capt_dir } -setArchDir <- function(arch_dir){ +set_arch_dir <- function(arch_dir) +{ testEnv$arch_dir <- arch_dir } -setTestDir <- function(test_dir){ +set_test_dir <- function(test_dir) +{ testEnv$test_dir <- test_dir } From 5500a7be1e0fef916ee10dad6991a256100d1753 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 12:07:36 +0200 Subject: [PATCH 19/66] fix processing generated test cases (issue #4) --- NAMESPACE | 12 ++++----- R/generate.R | 26 +++++++++++++------ R/runTests.R | 7 ++--- R/testr.R | 2 ++ ...ion.Rd => find_packages_using_function.Rd} | 8 +++--- man/{getTests.Rd => get_tests.Rd} | 8 +++--- ...oveFailingTCs.Rd => remove_failing_tcs.Rd} | 8 +++--- man/{runAllTests.Rd => run_all_tests.Rd} | 10 +++---- ...unPackageTests.Rd => run_package_tests.Rd} | 6 ++--- ...pturedTests.Rd => write_captured_tests.Rd} | 8 +++--- 10 files changed, 53 insertions(+), 42 deletions(-) rename man/{findPackagesUsingFunction.Rd => find_packages_using_function.Rd} (54%) rename man/{getTests.Rd => get_tests.Rd} (74%) rename man/{removeFailingTCs.Rd => remove_failing_tcs.Rd} (61%) rename man/{runAllTests.Rd => run_all_tests.Rd} (69%) rename man/{runPackageTests.Rd => run_package_tests.Rd} (70%) rename man/{writeCapturedTests.Rd => write_captured_tests.Rd} (59%) diff --git a/NAMESPACE b/NAMESPACE index fc71a31..fc93f53 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,18 +2,18 @@ export(clear_decoration) export(decorate) -export(findPackagesUsingFunction) +export(find_packages_using_function) export(gen_from_code) export(gen_from_function) export(gen_from_package) export(gen_from_source) export(generate) export(generateTestCases) -export(getTests) +export(get_tests) export(prune) -export(removeFailingTCs) -export(runAllTests) -export(runPackageTests) +export(remove_failing_tcs) +export(run_all_tests) +export(run_package_tests) export(setup_capture) export(start_capture) export(start_capture_builtins) @@ -21,8 +21,8 @@ export(stop_capture) export(stop_capture_all) export(testr_options) export(undecorate) -export(writeCapturedTests) export(write_capture) +export(write_captured_tests) import(devtools) import(methods) importFrom(Rcpp,evalCpp) diff --git a/R/generate.R b/R/generate.R index efa1034..9fc12c5 100644 --- a/R/generate.R +++ b/R/generate.R @@ -233,17 +233,27 @@ generate_tc <- function(symb, vsym, func, argv) #' @title writeCapturedTests #' @description creates an archive of generated test cases #' @param path path to store the archive -#' @param test_path location of generated test cases #' @export -write_captured_tests <- function(path, test_path= testEnv$test_dir) +write_captured_tests <- function(path) { + stop_capture_all() + generate("capture") + if (is.null(testEnv$root)) + set_root(getwd()) + set_capt_dir(file.path(testEnv$root,"capture")) + tc <- remove_failing_tcs() - if (length(tc)) { - if (!dir.exists(path)) - dir.create(path) - zip_call <- paste0("tar -czvf ", path, "/test.", pkg_name, - ".", fname, ".tar.gz -C ", test_path, " .") - system(zip_call) + dirs <- list.dirs(testEnv$capt_dir, recursive = FALSE) + + if (length(grep("___", dirs))) { + if (!dir.exists(file.path(testEnv$root, path))) + dir.create(file.path(testEnv$root, path)) + for (dir in dirs[grep("___", dirs)]) { + zip_call <- paste0("tar -czvf ", file.path(testEnv$root, path), "/test.", + sub("___", ".", basename(dir)), + ".tar.gz -C ", dir, " .") + system(zip_call) + } } } diff --git a/R/runTests.R b/R/runTests.R index d6c64b5..989900e 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -6,8 +6,8 @@ remove_failing_tcs <- function() { ## check if generated test cases run without failure # get the generated test cases - capt_dir <- getCaptDir() - tc <- getTests(capt_dir) + capt_dir <- get_capt_dir() + tc <- get_tests(capt_dir) # check which test cases fail? res <- sapply(tc, function(x) { oldGlobals <- c(ls(.GlobalEnv), "testEnv") @@ -19,7 +19,7 @@ remove_failing_tcs <- function() }) # remove failing test cases unlink(names(res[res == TRUE])) - getTests(capt_dir) + get_tests(capt_dir) } #' @title find_packages_using_function @@ -297,6 +297,7 @@ run_all_tests <- #' @export get_tests <- function(capt_dir) { + print(capt_dir) d <- list.files(capt_dir, pattern = ".R$", recursive = TRUE, full.names = TRUE) rm <- grep("^capture", list.files(capt_dir, recursive = TRUE)) diff --git a/R/testr.R b/R/testr.R index cd45ed3..1aac7d9 100644 --- a/R/testr.R +++ b/R/testr.R @@ -139,6 +139,8 @@ start_capture <- function(..., verbose = testr_options("verbose")) { if (old) testr_options("capture.arguments", FALSE) for (f in parseFunctionNames(...)) { decorate(f[["name"]], f[["package"]], verbose = verbose) + set_pkg_name(c(f[["package"]], testEnv$pkg_name)) + set_function_name(c(f[["name"]], testEnv$fname)) } if (old) testr_options("capture.arguments", TRUE) invisible(NULL) diff --git a/man/findPackagesUsingFunction.Rd b/man/find_packages_using_function.Rd similarity index 54% rename from man/findPackagesUsingFunction.Rd rename to man/find_packages_using_function.Rd index 60e1e6d..17b91ba 100644 --- a/man/findPackagesUsingFunction.Rd +++ b/man/find_packages_using_function.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/runTests.R -\name{findPackagesUsingFunction} -\alias{findPackagesUsingFunction} -\title{findPackagesUsingFunction} +\name{find_packages_using_function} +\alias{find_packages_using_function} +\title{find_packages_using_function} \usage{ -findPackagesUsingFunction(functionName, limit = 100, lib.loc = NULL) +find_packages_using_function(functionName, limit = 100, lib.loc = NULL) } \arguments{ \item{functionName}{name of the function} diff --git a/man/getTests.Rd b/man/get_tests.Rd similarity index 74% rename from man/getTests.Rd rename to man/get_tests.Rd index 309d01d..c8f6f9f 100644 --- a/man/getTests.Rd +++ b/man/get_tests.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/runTests.R -\name{getTests} -\alias{getTests} -\title{getTests} +\name{get_tests} +\alias{get_tests} +\title{get_tests} \usage{ -getTests(capt_dir) +get_tests(capt_dir) } \arguments{ \item{capt_dir}{location of test cases} diff --git a/man/removeFailingTCs.Rd b/man/remove_failing_tcs.Rd similarity index 61% rename from man/removeFailingTCs.Rd rename to man/remove_failing_tcs.Rd index 0b5ddec..14cc5f1 100644 --- a/man/removeFailingTCs.Rd +++ b/man/remove_failing_tcs.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/runTests.R -\name{removeFailingTCs} -\alias{removeFailingTCs} -\title{removeFailingTCs} +\name{remove_failing_tcs} +\alias{remove_failing_tcs} +\title{remove_failing_tcs} \usage{ -removeFailingTCs() +remove_failing_tcs() } \description{ removes the test cases that fail in GNU R diff --git a/man/runAllTests.Rd b/man/run_all_tests.Rd similarity index 69% rename from man/runAllTests.Rd rename to man/run_all_tests.Rd index 3c99bdf..3da13a4 100644 --- a/man/runAllTests.Rd +++ b/man/run_all_tests.Rd @@ -1,11 +1,11 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/runTests.R -\name{runAllTests} -\alias{runAllTests} -\title{runAllTests} +\name{run_all_tests} +\alias{run_all_tests} +\title{run_all_tests} \usage{ -runAllTests(outDir = ".", errorsAreFatal = FALSE, scope = c("all", "base", - "recommended", "top"), srcdir = NULL, pkg_limit = NULL, +run_all_tests(outDir = ".", errorsAreFatal = FALSE, scope = c("all", + "base", "recommended", "top"), srcdir = NULL, pkg_limit = NULL, custom_pkg_list = NULL) } \arguments{ diff --git a/man/runPackageTests.Rd b/man/run_package_tests.Rd similarity index 70% rename from man/runPackageTests.Rd rename to man/run_package_tests.Rd index 782ddb1..7c7c5f6 100644 --- a/man/runPackageTests.Rd +++ b/man/run_package_tests.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/runTests.R -\name{runPackageTests} -\alias{runPackageTests} +\name{run_package_tests} +\alias{run_package_tests} \title{runPackageTests} \usage{ -runPackageTests(pkg, lib.loc = NULL, outDir) +run_package_tests(pkg, lib.loc = NULL, outDir) } \arguments{ \item{pkg}{name of the packge} diff --git a/man/writeCapturedTests.Rd b/man/write_captured_tests.Rd similarity index 59% rename from man/writeCapturedTests.Rd rename to man/write_captured_tests.Rd index 4e2f769..02bf307 100644 --- a/man/writeCapturedTests.Rd +++ b/man/write_captured_tests.Rd @@ -1,15 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/generate.R -\name{writeCapturedTests} -\alias{writeCapturedTests} +\name{write_captured_tests} +\alias{write_captured_tests} \title{writeCapturedTests} \usage{ -writeCapturedTests(path, test_path = testEnv$test_dir) +write_captured_tests(path) } \arguments{ \item{path}{path to store the archive} - -\item{test_path}{location of generated test cases} } \description{ creates an archive of generated test cases From 7cbc8b9d291c33644c6ea86a4e8781e82663ab5f Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 12:30:56 +0200 Subject: [PATCH 20/66] remove decorate from namespace (issue #3) --- NAMESPACE | 1 - R/capture.R | 1 - 2 files changed, 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index fc93f53..118cc84 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,6 @@ # Generated by roxygen2: do not edit by hand export(clear_decoration) -export(decorate) export(find_packages_using_function) export(gen_from_code) export(gen_from_function) diff --git a/R/capture.R b/R/capture.R index c018c69..56d3b20 100644 --- a/R/capture.R +++ b/R/capture.R @@ -5,7 +5,6 @@ #' @param func function name as a character string #' @param package name of package to look for function #' @param verbose if to print additional output -#' @export #' @seealso write_capture #' decorate <- function(func, package, verbose) { From 9091b09e315a8b4d0b453f2e64825b550d87809a Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 12:31:17 +0200 Subject: [PATCH 21/66] code clean up --- R/runTests.R | 1 - R/testr.R | 2 -- 2 files changed, 3 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index 989900e..e59b12e 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -297,7 +297,6 @@ run_all_tests <- #' @export get_tests <- function(capt_dir) { - print(capt_dir) d <- list.files(capt_dir, pattern = ".R$", recursive = TRUE, full.names = TRUE) rm <- grep("^capture", list.files(capt_dir, recursive = TRUE)) diff --git a/R/testr.R b/R/testr.R index 1aac7d9..cd45ed3 100644 --- a/R/testr.R +++ b/R/testr.R @@ -139,8 +139,6 @@ start_capture <- function(..., verbose = testr_options("verbose")) { if (old) testr_options("capture.arguments", FALSE) for (f in parseFunctionNames(...)) { decorate(f[["name"]], f[["package"]], verbose = verbose) - set_pkg_name(c(f[["package"]], testEnv$pkg_name)) - set_function_name(c(f[["name"]], testEnv$fname)) } if (old) testr_options("capture.arguments", TRUE) invisible(NULL) From b36dfbbefc12a4dd38fe15a27c16dff22ff16ee8 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 13:16:27 +0200 Subject: [PATCH 22/66] remove stringr from imports (issue #6) --- R/runTests.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/runTests.R b/R/runTests.R index e59b12e..48575ea 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -28,7 +28,6 @@ remove_failing_tcs <- function() #' @export find_packages_using_function <- function(functionName, limit = 100, lib.loc = NULL) { - require(stringr) top <- c() if(missing(lib.loc)) lib.loc <- .libPaths()[1] From 1c7116001f05e0f9c923d4ae415fab9a48efc8e3 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 13:20:09 +0200 Subject: [PATCH 23/66] added test case (issue #4) --- tests/testthat/test-testgen.R | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/tests/testthat/test-testgen.R b/tests/testthat/test-testgen.R index b2d18e9..a5ee181 100644 --- a/tests/testthat/test-testgen.R +++ b/tests/testthat/test-testgen.R @@ -3,6 +3,25 @@ library(testthat) context("Generation") +test_that('Test write_captured_tests()', { + testr::start_capture("stats::dpois") + dpois(0:7, lambda = 1) + testr::write_captured_tests("/tmp") + expect_true(file.exists("tmp")) + expect_true(file.info("tmp")$isdir) + expect_true(file.exists("capture/stats___dpois")) + expect_true(file.info("capture/stats___dpois")$isdir) + expect_true(file.exists("capture")) + expect_true(file.info("capture")$isdir) + expect_true(file.exists("tmp/test.stats.dpois.tar.gz")) + expect_false(file.info("tmp/test.stats.dpois.tar.gz")$isdir) + expect_equal(length(list.files("tmp",recursive = TRUE)), 1) + expect_equal(length(list.files("capture/stats__dpois",recursive = TRUE)), 1) + unlink("tmp") + unlink("capture") +}) + + test_that('Generate Abbreviate', { expect_warning(generate("abbreviate", "CaptureInfo/capture")) generate("abbreviate", "CaptureInfo/capture_abbreviate", verbose = FALSE) @@ -32,3 +51,4 @@ test_that('Generate Warnings/Errors', { sink() unlink("we", recursive = T) }) + From 627b525a857ca2eb7a13e868a8ee35bff9d79d08 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 13:56:33 +0200 Subject: [PATCH 24/66] fix digest namespace import --- R/generate.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/generate.R b/R/generate.R index 9fc12c5..c510779 100644 --- a/R/generate.R +++ b/R/generate.R @@ -88,7 +88,7 @@ process_capture <- function(cap_file) func <- read_value(lines, kFuncPrefix) args <- read_value(lines, kArgsPrefix) - d_func_arg <- digest::digest( paste0(digest::digest(func), digest::digest(args)) ) + d_func_arg <- digest( paste0(digestdigest(func), digest(args)) ) tc.file <- ensure_file(func, d_func_arg) feedback <- generate_tc(symb, vsym, func, args) From 3c60ea8e8e9e5379eac8e42582eae77f6e9246d3 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 13:56:58 +0200 Subject: [PATCH 25/66] fix find_packages_using_function() output + test case (issue #1) --- R/runTests.R | 42 +++++++++++++++++------------------ tests/testthat/test-testgen.R | 10 ++++++++- 2 files changed, 30 insertions(+), 22 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index 48575ea..3cb8b80 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -28,33 +28,33 @@ remove_failing_tcs <- function() #' @export find_packages_using_function <- function(functionName, limit = 100, lib.loc = NULL) { - top <- c() + top <- c(character()) if(missing(lib.loc)) lib.loc <- .libPaths()[1] - call <- paste0("egrep -R -n \'\\<",functionName,"\\>\' ",lib.loc) res <- system(call, intern = TRUE) - # remove line that dont start with library path if(length(res)) { - keep <- grepl(.libPaths()[1], res) - res <- res[keep] - # remove library path - res <- sapply(res, function(x) { - strsplit(x[[1]], .libPaths()[1])[[1]][2]}, - simplify = TRUE, USE.NAMES = FALSE) - # select package name from path - res <- sapply(res, function(x) { - strsplit(x[[1]], "/")[[1]][2]}, - simplify = TRUE, USE.NAMES = FALSE) - # make a count table from package name occurence - if(length(res) > 0) { - resTab <- as.data.frame(unclass(rle(sort(res))))[ , 2:1] - resTab <- resTab[with(resTab, order(-lengths)), ] - if (nrow(resTab < limit)) - top <- row.names(resTab) - else - top <- row.names(resTab[1:limit, ]) + for (path in .libPaths()) { + keep <- grepl(path, res) + res2 <- res[keep] + # remove library path + res2 <- sapply(res2, function(x) { + strsplit(x[[1]], path)[[1]][2]}, + simplify = TRUE, USE.NAMES = FALSE) + # select package name from path + res2 <- sapply(res2, function(x) { + strsplit(x[[1]], "/")[[1]][2]}, + simplify = TRUE, USE.NAMES = FALSE) + # make a count table from package name occurence + if(length(res2) > 0) { + resTab <- as.data.frame(unclass(rle(sort(res2))))[ , 2:1] + resTab <- resTab[with(resTab, order(-lengths)), ] + if (nrow(resTab) < limit) + top <- c(top, as.character(resTab$values)) + else + top <- c(top, as.character(resTab$values[1:limit])) + } } } top diff --git a/tests/testthat/test-testgen.R b/tests/testthat/test-testgen.R index a5ee181..0716c1c 100644 --- a/tests/testthat/test-testgen.R +++ b/tests/testthat/test-testgen.R @@ -3,7 +3,7 @@ library(testthat) context("Generation") -test_that('Test write_captured_tests()', { +test_that('Test start_capture()', { testr::start_capture("stats::dpois") dpois(0:7, lambda = 1) testr::write_captured_tests("/tmp") @@ -21,6 +21,14 @@ test_that('Test write_captured_tests()', { unlink("capture") }) +test_that('Test find_packages_using_function()', { + x <- testr::find_packages_using_function("cor") + y <- testr::find_packages_using_function("aksagdK*@&e9dgiakegdkgjqge93yqe") + expect_true(length(x) > 0) + expect_true(class(x[1]) == "character") + expect_true(length(x) == 0) + expect_true(class(x) == "character") +}) test_that('Generate Abbreviate', { expect_warning(generate("abbreviate", "CaptureInfo/capture")) From 5b55deab921f54a744971d5d11f88a5ba4b89da4 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 14:01:35 +0200 Subject: [PATCH 26/66] fix digest call --- R/generate.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/generate.R b/R/generate.R index c510779..073c739 100644 --- a/R/generate.R +++ b/R/generate.R @@ -88,7 +88,7 @@ process_capture <- function(cap_file) func <- read_value(lines, kFuncPrefix) args <- read_value(lines, kArgsPrefix) - d_func_arg <- digest( paste0(digestdigest(func), digest(args)) ) + d_func_arg <- digest( paste0(digest(func), digest(args)) ) tc.file <- ensure_file(func, d_func_arg) feedback <- generate_tc(symb, vsym, func, args) From 152692a1e90d8d5217a0753fdadab87d1bb78746 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 14:31:05 +0200 Subject: [PATCH 27/66] fix test cases --- tests/testthat/test-testgen.R | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/tests/testthat/test-testgen.R b/tests/testthat/test-testgen.R index 0716c1c..b2ca415 100644 --- a/tests/testthat/test-testgen.R +++ b/tests/testthat/test-testgen.R @@ -4,21 +4,22 @@ library(testthat) context("Generation") test_that('Test start_capture()', { + unlink(file.path(getwd(),"capture")) + unlink(file.path(getwd(),"tmp")) testr::start_capture("stats::dpois") dpois(0:7, lambda = 1) testr::write_captured_tests("/tmp") - expect_true(file.exists("tmp")) - expect_true(file.info("tmp")$isdir) - expect_true(file.exists("capture/stats___dpois")) - expect_true(file.info("capture/stats___dpois")$isdir) - expect_true(file.exists("capture")) - expect_true(file.info("capture")$isdir) - expect_true(file.exists("tmp/test.stats.dpois.tar.gz")) - expect_false(file.info("tmp/test.stats.dpois.tar.gz")$isdir) - expect_equal(length(list.files("tmp",recursive = TRUE)), 1) - expect_equal(length(list.files("capture/stats__dpois",recursive = TRUE)), 1) - unlink("tmp") - unlink("capture") + expect_true(file.exists(file.path(getwd(),"tmp"))) + expect_true(file.info(file.path(getwd(),"tmp"))$isdir) + expect_true(file.exists(file.path(getwd(),"capture/stats___dpois"))) + expect_true(file.info(file.path(getwd(),"capture/stats___dpois"))$isdir) + expect_true(file.exists(file.path(getwd(),"capture"))) + expect_true(file.info(file.path(getwd(),"capture"))$isdir) + expect_true(file.exists(file.path(getwd(),"tmp/test.stats.dpois.tar.gz"))) + expect_false(file.info(file.path(getwd(),"tmp/test.stats.dpois.tar.gz"))$isdir) + expect_equal(length(list.files(file.path(getwd(),"capture/stats___dpois"), pattern = "*.R$", recursive = FALSE, all.files = FALSE)), 1) + unlink(file.path(getwd(),"tmp")) + unlink(file.path(getwd(),"capture")) }) test_that('Test find_packages_using_function()', { @@ -26,8 +27,8 @@ test_that('Test find_packages_using_function()', { y <- testr::find_packages_using_function("aksagdK*@&e9dgiakegdkgjqge93yqe") expect_true(length(x) > 0) expect_true(class(x[1]) == "character") - expect_true(length(x) == 0) - expect_true(class(x) == "character") + expect_true(length(y) == 0) + expect_true(class(y) == "character") }) test_that('Generate Abbreviate', { From ec70417def61a040f0a57bf84c46e100dbcaea6d Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 15:33:39 +0200 Subject: [PATCH 28/66] fix devtools:check() warnings/errs --- NAMESPACE | 1 - R/generate.R | 3 +-- R/runTests.R | 8 +++++++- README.md | 5 +---- man/find_packages_using_function.Rd | 4 ++++ man/run_all_tests.Rd | 6 +++++- man/run_package_tests.Rd | 4 ++++ 7 files changed, 22 insertions(+), 9 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 118cc84..8f02062 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,5 +25,4 @@ export(write_captured_tests) import(devtools) import(methods) importFrom(Rcpp,evalCpp) -importFrom(digest,digest) useDynLib(testr) diff --git a/R/generate.R b/R/generate.R index 073c739..33779cf 100644 --- a/R/generate.R +++ b/R/generate.R @@ -75,7 +75,6 @@ ensure_file <- function(name, funHash) #' #' @description This function parses file with closure capture information and generates test cases #' @param cap_file path to closure capture file -#' @importFrom digest digest process_capture <- function(cap_file) { lines <- readLines(cap_file) @@ -88,7 +87,7 @@ process_capture <- function(cap_file) func <- read_value(lines, kFuncPrefix) args <- read_value(lines, kArgsPrefix) - d_func_arg <- digest( paste0(digest(func), digest(args)) ) + d_func_arg <- digest::digest( paste0(digest::digest(func), digest::digest(args)) ) tc.file <- ensure_file(func, d_func_arg) feedback <- generate_tc(symb, vsym, func, args) diff --git a/R/runTests.R b/R/runTests.R index 3cb8b80..978eb88 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -25,6 +25,8 @@ remove_failing_tcs <- function() #' @title find_packages_using_function #' @description find packages that use the function of interest #' @param functionName name of the function +#' @param limit max number of packages to use +#' @param lib.loc library location #' @export find_packages_using_function <- function(functionName, limit = 100, lib.loc = NULL) { @@ -63,6 +65,8 @@ find_packages_using_function <- function(functionName, limit = 100, lib.loc = NU #' @title runPackageTests #' @description ectract and run example/test codes from package #' @param pkg name of the packge +#' @param lib.loc library location +#' @param outDir output directory to store extracted code #' @export run_package_tests <- function (pkg, lib.loc = NULL, outDir) { @@ -223,8 +227,10 @@ run_package_tests <- function (pkg, lib.loc = NULL, outDir) #' @title run_all_tests #' @description run all the test/example codes from all the selected packages -#' @param outDir root dir +#' @param outDir output dir +#' @param errorsAreFatal should errors break the process #' @param scope how to prioritize/select packages to run +#' @param srcdir source directory #' @param pkg_limit maximum number of packages to use for test generation #' @param custom_pkg_list custom list of packages of interest to use for test generation #' @export diff --git a/README.md b/README.md index 5630c18..7aa05f2 100644 --- a/README.md +++ b/README.md @@ -1,10 +1,7 @@ testR - test case generation for R ===== -[![Build Status](https://travis-ci.org/allr/testr.svg?branch=master)](https://travis-ci.org/allr/testr) -[![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/allr/testr?branch=master&svg=true)](https://ci.appveyor.com/project/allr/testr) -[![Coverage Status](http://codecov.io/github/allr/testr/coverage.svg?branch=master)](http://codecov.io/github/allr/testr?branch=master) -[![CRAN\_Status\_Badge](http://www.r-pkg.org/badges/version/testr)](http://cran.r-project.org/package=testr) +[![Build Status](http://build.renjin.org/buildStatus/icon?job=testr)](http://build.renjin.org) TestR is a framework for unit tests generation from source code and for test execution, and filtering of test cases based on C code coverage using `gcov` and R code coverage using `rcov` (https://github.com/allr/rcov). diff --git a/man/find_packages_using_function.Rd b/man/find_packages_using_function.Rd index 17b91ba..53c9a58 100644 --- a/man/find_packages_using_function.Rd +++ b/man/find_packages_using_function.Rd @@ -8,6 +8,10 @@ find_packages_using_function(functionName, limit = 100, lib.loc = NULL) } \arguments{ \item{functionName}{name of the function} + +\item{limit}{max number of packages to use} + +\item{lib.loc}{library location} } \description{ find packages that use the function of interest diff --git a/man/run_all_tests.Rd b/man/run_all_tests.Rd index 3da13a4..8b280f2 100644 --- a/man/run_all_tests.Rd +++ b/man/run_all_tests.Rd @@ -9,10 +9,14 @@ run_all_tests(outDir = ".", errorsAreFatal = FALSE, scope = c("all", custom_pkg_list = NULL) } \arguments{ -\item{outDir}{root dir} +\item{outDir}{output dir} + +\item{errorsAreFatal}{should errors break the process} \item{scope}{how to prioritize/select packages to run} +\item{srcdir}{source directory} + \item{pkg_limit}{maximum number of packages to use for test generation} \item{custom_pkg_list}{custom list of packages of interest to use for test generation} diff --git a/man/run_package_tests.Rd b/man/run_package_tests.Rd index 7c7c5f6..5792348 100644 --- a/man/run_package_tests.Rd +++ b/man/run_package_tests.Rd @@ -8,6 +8,10 @@ run_package_tests(pkg, lib.loc = NULL, outDir) } \arguments{ \item{pkg}{name of the packge} + +\item{lib.loc}{library location} + +\item{outDir}{output directory to store extracted code} } \description{ ectract and run example/test codes from package From 60bc9ca5525499096f4eba51b0d5cff051da50c6 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 16:19:46 +0200 Subject: [PATCH 29/66] fix build icon --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 7aa05f2..2d342de 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ testR - test case generation for R ===== -[![Build Status](http://build.renjin.org/buildStatus/icon?job=testr)](http://build.renjin.org) +[![Build Status](http://build.renjin.org/job/Test-Generation/job/testr/badge/icon)](http://build.renjin.org/job/Test-Generation/job/testr/) TestR is a framework for unit tests generation from source code and for test execution, and filtering of test cases based on C code coverage using `gcov` and R code coverage using `rcov` (https://github.com/allr/rcov). From 3b186c7bcb815e57333c0998b5b43ea7b1b2b97d Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 17:22:09 +0200 Subject: [PATCH 30/66] exclude dontrun{} codes in examples and fix function signatures (issue #8) --- R/runTests.R | 28 ++++++++++++++++++---------- 1 file changed, 18 insertions(+), 10 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index 978eb88..5c36b43 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -26,15 +26,16 @@ remove_failing_tcs <- function() #' @description find packages that use the function of interest #' @param functionName name of the function #' @param limit max number of packages to use -#' @param lib.loc library location #' @export -find_packages_using_function <- function(functionName, limit = 100, lib.loc = NULL) +find_packages_using_function <- function(functionName, limit = 100) { top <- c(character()) - if(missing(lib.loc)) - lib.loc <- .libPaths()[1] - call <- paste0("egrep -R -n \'\\<",functionName,"\\>\' ",lib.loc) - res <- system(call, intern = TRUE) + res <- c() + for (path in .libPaths()) { + call <- paste0("egrep -R -n \'\\<",functionName,"\\>\' ",path) + res <- c(res, system(call, intern = TRUE) ) + } + # remove line that dont start with library path if(length(res)) { for (path in .libPaths()) { @@ -101,7 +102,7 @@ run_package_tests <- function (pkg, lib.loc = NULL, outDir) nof <- length(Sys.glob(file.path(filedir, "*.R"))) if (!nof) return(invisible(NULL)) - massageExamples <- function (pkg, files, outFile = stdout(), ..., commentDonttest = TRUE) + massageExamples <- function (pkg, files, outFile = stdout(), ..., commentDonttest = TRUE, commentDontrun = TRUE) { if (dir.exists(files[1L])) { old <- Sys.setlocale("LC_COLLATE", "C") @@ -166,6 +167,14 @@ run_package_tests <- function (pkg, lib.loc = NULL, outDir) if (any(grepl("^[[:space:]]*## End\\(No test\\)", line, perl = TRUE, useBytes = TRUE))) dont_test <- FALSE } } + if (commentDontrun) { + dont_run <- FALSE + for (line in lines) { + if (any(grepl("^[[:space:]]*## No run:", line, perl = TRUE, useBytes = TRUE))) dont_test <- TRUE + if (!dont_test) cat(line, "\n", sep = "", file = out) + if (any(grepl("^[[:space:]]*## End\\(No run\\)", line, perl = TRUE, useBytes = TRUE))) dont_test <- FALSE + } + } else for (line in lines) { if (!(line = "")) { cat(line, "\n", sep = "", file = out) @@ -259,7 +268,7 @@ run_all_tests <- pkgs <- c( do.call( find_packages_using_function, - list(functionName = testEnv$fname, limit = testEnv$pkg_limit, lib.loc = NULL), + list(functionName = testEnv$fname, limit = testEnv$pkg_limit), envir = testEnv), pkgs) if (!is.na(custom_pkg_list)) { @@ -334,7 +343,6 @@ generateTestCases <- function(){ install_git("https://github.com/bedatadriven/hamcrest.git", branch = "master", upgrade_dependencies = FALSE) } - set_test_out_dir(paste0(testEnv$root, "/", testEnv$job, "_", testEnv$build)) dir.create(testEnv$testOutDir, recursive = TRUE) start_capture( paste(testEnv$pkg_name, "::", testEnv$fname, sep = ""), @@ -355,5 +363,5 @@ generateTestCases <- function(){ set_test_dir(file.path(testEnv$root,"capture",paste0(testEnv$pkg_name,"___", testEnv$fname))) - write_captured_tests(testEnv$arch_dir, testEnv$test_dir) + write_captured_tests(testEnv$arch_dir) } From d1f4749fb03b383731a8b9c059005edbaef49129 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 17:28:38 +0200 Subject: [PATCH 31/66] code clean up --- NAMESPACE | 2 +- R/runTests.R | 19 ++++++------------- man/find_packages_using_function.Rd | 4 +--- ...ateTestCases.Rd => generate_test_cases.Rd} | 8 ++++---- 4 files changed, 12 insertions(+), 21 deletions(-) rename man/{generateTestCases.Rd => generate_test_cases.Rd} (61%) diff --git a/NAMESPACE b/NAMESPACE index 8f02062..f09536d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,7 +7,7 @@ export(gen_from_function) export(gen_from_package) export(gen_from_source) export(generate) -export(generateTestCases) +export(generate_test_cases) export(get_tests) export(prune) export(remove_failing_tcs) diff --git a/R/runTests.R b/R/runTests.R index 5c36b43..e306121 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -119,7 +119,6 @@ run_package_tests <- function (pkg, lib.loc = NULL, outDir) lines <- c( paste0("pkgname <- \"", pkg, "\""), - paste0("testr:::setExamedPkgName(\"", pkg, "\")"), "assign(\"par.postscript\", graphics::par(no.readonly = TRUE))", "options(contrasts = c(unordered = \"contr.treatment\", ordered = \"contr.poly\"))", "graphics.off()" @@ -127,12 +126,12 @@ run_package_tests <- function (pkg, lib.loc = NULL, outDir) cat(lines, sep = "\n", file = out) if (pkg == "tcltk") { if (capabilities("tcltk")) - cat("require('tcltk')\n\n", file = out) + cat("require('tcltk')\n", file = out) else - cat("stop(\"tcltk not found!\")\n\n", file = out) + cat("stop(\"tcltk not found!\")\n", file = out) } else if (pkg != "base") - cat("library('", pkg, "')\n\n", sep = "", file = out) + cat("library('", pkg, "')\n", sep = "", file = out) for (file in files) { nm <- sub("\\.R$", "", basename(file)) @@ -146,8 +145,7 @@ run_package_tests <- function (pkg, lib.loc = NULL, outDir) "^[[:space:]]*\\?", "^[[:space:]]*help\\.search", "^[[:space:]]*nameEx.{2}help\\.search", "demo\\(", "data\\(package", "data\\(\\)", - "^library\\(\\)", "^library\\(lib\\.loc"#, - #"\\([[:space:]]*help\\(", "[[:space:]]*vignette\\(" + "^library\\(\\)", "^library\\(lib\\.loc" ) for (pattern in patterns) { @@ -319,11 +317,11 @@ get_tests <- function(capt_dir) d } -#' @title generateTestCases +#' @title generate_test_cases #' @description generates test cases based on environmental variables #' @import devtools methods #' @export -generateTestCases <- function(){ +generate_test_cases <- function(){ set_function_name(Sys.getenv("function_name")) set_pkg_name(Sys.getenv("package_name")) set_job(Sys.getenv("JOB_NAME")) @@ -331,7 +329,6 @@ generateTestCases <- function(){ set_pkg_limit(Sys.getenv("pkg_limit")) set_scope(Sys.getenv("scope")) set_root(getwd()) - if (as.logical(Sys.getenv("install_testr"))) { if(!require(devtools)){ install.packages("devtools", dependencies = TRUE, @@ -352,16 +349,12 @@ generateTestCases <- function(){ pkg_limit = as.numeric(testEnv$pkg_limit), custom_pkg_list = testEnv$custom_pkg_list ) - setwd(testEnv$root) stop_capture_all() generate("capture") - set_capt_dir(file.path(testEnv$root,"capture")) - set_arch_dir(file.path(testEnv$root,"tests")) set_test_dir(file.path(testEnv$root,"capture",paste0(testEnv$pkg_name,"___", testEnv$fname))) - write_captured_tests(testEnv$arch_dir) } diff --git a/man/find_packages_using_function.Rd b/man/find_packages_using_function.Rd index 53c9a58..2165402 100644 --- a/man/find_packages_using_function.Rd +++ b/man/find_packages_using_function.Rd @@ -4,14 +4,12 @@ \alias{find_packages_using_function} \title{find_packages_using_function} \usage{ -find_packages_using_function(functionName, limit = 100, lib.loc = NULL) +find_packages_using_function(functionName, limit = 100) } \arguments{ \item{functionName}{name of the function} \item{limit}{max number of packages to use} - -\item{lib.loc}{library location} } \description{ find packages that use the function of interest diff --git a/man/generateTestCases.Rd b/man/generate_test_cases.Rd similarity index 61% rename from man/generateTestCases.Rd rename to man/generate_test_cases.Rd index 04194d6..131dffd 100644 --- a/man/generateTestCases.Rd +++ b/man/generate_test_cases.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/runTests.R -\name{generateTestCases} -\alias{generateTestCases} -\title{generateTestCases} +\name{generate_test_cases} +\alias{generate_test_cases} +\title{generate_test_cases} \usage{ -generateTestCases() +generate_test_cases() } \description{ generates test cases based on environmental variables From 65fe8dd3e486f1f437fa6e200489dd18d0465fb5 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 17:36:34 +0200 Subject: [PATCH 32/66] 'No run' should be 'Not run' --- R/runTests.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index e306121..c183902 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -168,9 +168,9 @@ run_package_tests <- function (pkg, lib.loc = NULL, outDir) if (commentDontrun) { dont_run <- FALSE for (line in lines) { - if (any(grepl("^[[:space:]]*## No run:", line, perl = TRUE, useBytes = TRUE))) dont_test <- TRUE + if (any(grepl("^[[:space:]]*## Not run:", line, perl = TRUE, useBytes = TRUE))) dont_test <- TRUE if (!dont_test) cat(line, "\n", sep = "", file = out) - if (any(grepl("^[[:space:]]*## End\\(No run\\)", line, perl = TRUE, useBytes = TRUE))) dont_test <- FALSE + if (any(grepl("^[[:space:]]*## End\\(Not run\\)", line, perl = TRUE, useBytes = TRUE))) dont_test <- FALSE } } else for (line in lines) { From 601bcce92bb16c8218a189ab9a02e47791e4b737 Mon Sep 17 00:00:00 2001 From: parham Date: Thu, 25 Aug 2016 18:04:24 +0200 Subject: [PATCH 33/66] remove "file.show(" lines from extracted example codes --- R/runTests.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/runTests.R b/R/runTests.R index c183902..78ad01f 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -145,7 +145,8 @@ run_package_tests <- function (pkg, lib.loc = NULL, outDir) "^[[:space:]]*\\?", "^[[:space:]]*help\\.search", "^[[:space:]]*nameEx.{2}help\\.search", "demo\\(", "data\\(package", "data\\(\\)", - "^library\\(\\)", "^library\\(lib\\.loc" + "^library\\(\\)", "^library\\(lib\\.loc", + "^file\\.show\\(" ) for (pattern in patterns) { From 826a2f4e36db037bb7bcc808feb595d8de8258a4 Mon Sep 17 00:00:00 2001 From: parham Date: Fri, 26 Aug 2016 12:42:13 +0200 Subject: [PATCH 34/66] code style --- R/RcppExports.R | 3 +- R/capture.R | 30 +++++---- R/generate.R | 15 ++--- R/helpers.R | 135 +++++++++++++++++++++++++++++++-------- R/methods_replacements.R | 15 +++-- R/runTests.R | 18 +++--- R/testr.R | 135 +++++++++++---------------------------- R/zzz.R | 41 ++++++++---- 8 files changed, 219 insertions(+), 173 deletions(-) diff --git a/R/RcppExports.R b/R/RcppExports.R index 3dce2cc..0f55059 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -1,7 +1,8 @@ # This file was generated by Rcpp::compileAttributes # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 -WriteCapInfo_cpp <- function(fname, args_env) { +WriteCapInfo_cpp <- function(fname, args_env) +{ invisible(.Call('testr_WriteCapInfo_cpp', PACKAGE = 'testr', fname, args_env)) } diff --git a/R/capture.R b/R/capture.R index 56d3b20..876a4e1 100644 --- a/R/capture.R +++ b/R/capture.R @@ -1,4 +1,4 @@ -#' @title Decorates function to capture calls and return values +#' Decorates function to capture calls and return values #' #' @description This function is respinsible for writing down capture information for decorated function calls. #' Replaces the function by decorated function in the global environment @@ -7,7 +7,8 @@ #' @param verbose if to print additional output #' @seealso write_capture #' -decorate <- function(func, package, verbose) { +decorate <- function(func, package, verbose) +{ if (identical(class(library), "function") && getRversion() < '3.3.0') { suppressMessages(trace(library, exit = quote(if (!missing(package)) testr:::refresh_decoration(package)), @@ -64,7 +65,7 @@ decorate <- function(func, package, verbose) { .decorated[[func]] <- list(func = func, package = package, hidden = hidden) } -#' @title undecorate function +#' undecorate function #' #' @description Reset previously decorate function #' @param func function name as a character string @@ -72,7 +73,8 @@ decorate <- function(func, package, verbose) { #' @export #' @seealso write_capture Decorate #' -undecorate <- function(func, verbose) { +undecorate <- function(func, verbose) +{ if (class(func) == "character"){ fname <- func } else { @@ -95,7 +97,7 @@ undecorate <- function(func, verbose) { rm(list = c(func), envir = .decorated) } -#' @title Write down capture information +#' Write down capture information #' #' @description This function is respinsible for writing down capture information for decorated function calls. #' @param fname function name @@ -105,13 +107,14 @@ undecorate <- function(func, verbose) { #' @importFrom Rcpp evalCpp #' @export #' -write_capture <- function(fname, args.env){ +write_capture <- function(fname, args.env) +{ if (!testr_options("capture.arguments")) return(NULL) .Call("testr_WriteCapInfo_cpp", PACKAGE = "testr", fname, args.env) } -#' @title Setup information capturing for list of function +#' Setup information capturing for list of function #' #' @description This function is respinsible for setting up capturing for functions #' @@ -120,7 +123,8 @@ write_capture <- function(fname, args.env){ #' @param verbose if to print additional status information #' @seealso Decorate #' @export -setup_capture <- function(flist, package, verbose = testr_options("verbose")) { +setup_capture <- function(flist, package, verbose = testr_options("verbose")) +{ old <- testr_options("capture.arguments") if (old) testr_options("capture.arguments", FALSE) @@ -132,14 +136,15 @@ setup_capture <- function(flist, package, verbose = testr_options("verbose")) { testr_options("capture.arguments", TRUE) } -#' @title Check if function is eligible for wrapping to capture arguments and return values +#' Check if function is eligible for wrapping to capture arguments and return values #' #' @description This function checks that supplied function for capture is not a keyword, operator or in the blacklist (functions like rm, .GlobalEnv, etc.) #' This is an internal function and is supposed to be used in setup_capture #' @param func function name to check #' @return TRUE/FALSE if can be captured or not #' @seealso setup_capture -eligible_capture <- function(func){ +eligible_capture <- function(func) +{ return (!length(utils::getAnywhere(func)$objs) == 0 && class(utils::getAnywhere(func)[1]) == "function" && !func %in% blacklist @@ -151,13 +156,14 @@ eligible_capture <- function(func){ } -#' @title Clear decoration +#' Clear decoration #' #' @description Clear anything previously decorate #' @param verbose if to print additional debugging information. Default \code{TRUE}. #' @seealso undecorate #' @export -clear_decoration <- function(verbose) { +clear_decoration <- function(verbose) +{ for (fname in ls(.decorated, all.names = TRUE)) undecorate(fname, verbose = verbose) } diff --git a/R/generate.R b/R/generate.R index 33779cf..1b8304f 100644 --- a/R/generate.R +++ b/R/generate.R @@ -1,9 +1,7 @@ -#' @title Test Case generator based on capture files +#' Test Case generator based on capture files #' #' @description This function works with the trace information generated by instrumented GNU-R. -#' #' It is strictly oriented to that, please see readme for more information. -#' #' @param root a directory containg capture information or capture file #' @param output_dir directory where generated test cases will be saved #' @param timed whether result is dependent on time of generation @@ -39,7 +37,7 @@ test_gen <- function(root, output_dir, timed = FALSE, verbose=testr_options("ver cache$bad_argv <- NULL } -#' @title Manage Test Case file +#' Manage Test Case file #' #' @description This function creates a test case file if one does not exist already #' @param name directory where generated test cases will be saved @@ -71,7 +69,7 @@ ensure_file <- function(name, funHash) return(tc.file) } -#' @title Process File with Closure capture information +#' Process File with Closure capture information #' #' @description This function parses file with closure capture information and generates test cases #' @param cap_file path to closure capture file @@ -108,7 +106,6 @@ process_capture <- function(cap_file) } } - read_symbol_values <- function(lines) { k_sym <- 1 @@ -143,7 +140,7 @@ read_value <- function(lines, prefix) return(paste(value, collapse = "\n", sep = "")) } -#' @title Generates a testcase for closure function +#' Generates a testcase for closure function #' #' @description This function generates a test case for builtin function using supplied arguments. All elements should be given as text. #' @param symb symbols to be initialized before the call @@ -228,8 +225,7 @@ generate_tc <- function(symb, vsym, func, argv) list(type = "src", msg = src); } - -#' @title writeCapturedTests +#' writeCapturedTests #' @description creates an archive of generated test cases #' @param path path to store the archive #' @export @@ -255,4 +251,3 @@ write_captured_tests <- function(path) } } } - diff --git a/R/helpers.R b/R/helpers.R index 2ae7b55..650f896 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -1,30 +1,33 @@ -#' @title Check if function is S3 generic +#' Check if function is S3 generic #' #' @description Determine if function has a call to UseMethod. In that case there is no need to capture it. #' @param fname function name #' @param env environment to check aganist. Default \code{.GlobalEnv} #' @seealso Decorate -is_s3_generic <- function(fname, env=.GlobalEnv) { +is_s3_generic <- function(fname, env=.GlobalEnv) +{ f <- get(fname, mode = "function", envir = env) if (is.null(body(f))) return(FALSE) uses <- codetools::findGlobals(f, merge = FALSE)$functions any(uses == "UseMethod") } -#' @title Clean temporary directory +#' Clean temporary directory #' #' @description Make sure temp dir is empty by deleting unnecessary files -clean_temp <- function() { +clean_temp <- function() +{ for (file in list.files(cache$temp_dir, full.names = TRUE, pattern = "\\.RData|\\.[rR]$")) { file.remove(file) } } -#' @title Parse and evaluate +#' Parse and evaluate #' #' @description Function that wraps parse(eval(...)) call with tryCatch #' @param what text to be parse and evaluate -parse_eval <- function(what) { +parse_eval <- function(what) +{ tryCatch({ eval(parse(text=what)) TRUE @@ -34,11 +37,12 @@ parse_eval <- function(what) { }) } -#' @title Quote language from evaluation +#' Quote language from evaluation #' #' @description In certain cases, language arguments (like calls), need to be quoated #' @param arg list of arguments -quoter <- function(arg) { +quoter <- function(arg) +{ if (is.list(arg)) { org.attrs <- attributes(arg) res <- lapply(arg, function(x) if(is.language(x)) enquote(x) else quoter(x)) @@ -48,12 +52,13 @@ quoter <- function(arg) { else arg } -#' @title Removes prefixes and quote from line +#' Removes prefixes and quote from line #' #' @description Used for processing capture file information. Deletes prefixes to get essential information #' @param l input line #' @seealso ProcessClosure -substr_line <- function(l){ +substr_line <- function(l) +{ if (grepl("^quote\\(", l)){ ret.line <- strsplit(l, "\\(")[[1]][2]; if (substr(ret.line, nchar(ret.line), nchar(ret.line)) == ")") @@ -64,22 +69,24 @@ substr_line <- function(l){ ret.line } -#' @title Check line's starting prefix +#' Check line's starting prefix #' @description Check if line starts with prefix #' #' @param prefix prefix #' @param x text to be checked #' @seealso GenerateTC -starts_with <- function(prefix, x) { +starts_with <- function(prefix, x) +{ grepl(paste("^", prefix, sep=""), x) } -#' @title Find test directory for package +#' Find test directory for package #' #' @description Find a known test location for the package #' @param path package path #' @seealso CapturePackage -find_tests <- function(path) { +find_tests <- function(path) +{ testthat <- file.path(path, "tests", "testthat") if (file.exists(testthat) && file.info(testthat)$isdir) { return(testthat) @@ -92,14 +99,15 @@ find_tests <- function(path) { return(NULL) } -#' @title Reassing object in the namespace +#' Reassing object in the namespace #' #' @description Record that particual line was executed. #' Used in statement coverage, needed for namespace replacement #' @param name name of an object to be replaced #' @param obj object that will be put in the environment #' @param env environment to be replaced in -reassing_in_env <- function(name, obj, env) { +reassing_in_env <- function(name, obj, env) +{ if (exists(name, env)) { if (bindingIsLocked(name, env)) { unlockBinding(name, env) @@ -111,13 +119,14 @@ reassing_in_env <- function(name, obj, env) { } } -#' @title Get function name without special characters +#' Get function name without special characters #' #' @description This function is respinsible for extractng function name from test file name and removing special characters #' @param filename filename to be processed #' @param modify.characters if special characters should be removed #' -extract_func_name <- function(filename, modify.characters = TRUE){ +extract_func_name <- function(filename, modify.characters = TRUE) +{ fname <- filename if (grepl(".[rR]$", filename)) { fname <- gsub("(.*)tc_(.*)_(.*).R", "\\2", filename) @@ -138,14 +147,14 @@ extract_func_name <- function(filename, modify.characters = TRUE){ fname } - -#' @title Parse function names from objects +#' Parse function names from objects #' @description Parses given function names to a list of name, package characters. #' If package is not specified, NA is returned instead of its name. #' #' @param ... Functions either as character vectors, or package:::function expressions. #' @return List of parsed package and function names as characters. -parseFunctionNames <- function(...) { +parseFunctionNames <- function(...) +{ args <- unlist(list(...)) res <- list() getInfo <- function(vector, arg, special) { @@ -177,7 +186,7 @@ parseFunctionNames <- function(...) { res } -#' @title Returns names of functions defined in given file(s) +#' Returns names of functions defined in given file(s) #' #' @description Analyses given file, or files if directory #' is supplied for all functions defined in global scope and returns their names as character vector. @@ -185,7 +194,8 @@ parseFunctionNames <- function(...) { #' @param src.root A source file to be analyzed, or a directory containing source files (*.R or *.r) to be analyzed. #' @param recursive TRUE if subdirectories should be scanned too. #' @return Character vector of function names defined in the file. -list_functions <- function(src.root, recursive = TRUE) { +list_functions <- function(src.root, recursive = TRUE) +{ functions = character() if (file.info(src.root)$isdir) src.root <- list.files(src.root, pattern = "[rR]$", recursive = recursive, full.names = T) @@ -204,15 +214,18 @@ list_functions <- function(src.root, recursive = TRUE) { functions } -split_path <- function(path) { +split_path <- function(path) +{ setdiff(strsplit(path,"/|\\\\")[[1]], "") } -extract_example <- function(ex) { +extract_example <- function(ex) +{ sapply(ex, function(x) x[[1]]) } -example_code <- function(fromFile) { +example_code <- function(fromFile) +{ code <- tools::parse_Rd(fromFile) code <- code[sapply(code, function(x) attr(x, "Rd_tag") == "\\examples")] result = "" @@ -220,3 +233,73 @@ example_code <- function(fromFile) { result = c(result, extract_example(cc)) result } + +set_examed_pkg_name <- function(pkgname) +{ + testEnv$pkgname <- pkgname +} + +set_pkg_name <- function(pkg_name) +{ + testEnv$pkg_name <- pkg_name +} + +set_function_name <- function(fname) +{ + testEnv$fname <- fname +} + +set_job <- function(job) +{ + testEnv$job <- job +} + +set_build <- function(build) +{ + testEnv$build <- build +} + +set_pkg_limit <- function(limit) +{ + testEnv$pkg_limit <- limit +} + +set_scope <- function(scope = c("all")) +{ + testEnv$scope <- scope +} + +set_custom_pkg_list <- function(pkgs) +{ + testEnv$custom_pkg_list <- pkgs +} + +set_root <- function(root) +{ + testEnv$root <- root +} + +set_test_out_dir <- function(test_out_dir) +{ + testEnv$testOutDir <- test_out_dir +} + +set_capt_dir <- function(capt_dir) +{ + testEnv$capt_dir <- capt_dir +} + +get_capt_dir <- function() +{ + testEnv$capt_dir +} + +set_arch_dir <- function(arch_dir) +{ + testEnv$arch_dir <- arch_dir +} + +set_test_dir <- function(test_dir) +{ + testEnv$test_dir <- test_dir +} diff --git a/R/methods_replacements.R b/R/methods_replacements.R index e545e36..b8898dd 100644 --- a/R/methods_replacements.R +++ b/R/methods_replacements.R @@ -268,7 +268,8 @@ TraceWithMethods <- function (what, tracer = NULL, exit = NULL, at = numeric(), what } -getImportsEnv <- function(pkg) { +getImportsEnv <- function(pkg) +{ iname = paste("imports:", pkg, sep="") empty = emptyenv() env = asNamespace(pkg) @@ -280,14 +281,16 @@ getImportsEnv <- function(pkg) { NULL } -updateInImportsEnv <- function(what, newFun, importingPkg) { +updateInImportsEnv <- function(what, newFun, importingPkg) +{ where = getImportsEnv(importingPkg) if (!is.null(where) && (what %in% names(where))) { methods:::.assignOverBinding(what, newFun, where, FALSE) } } -replace_trace <- function() { +replace_trace <- function() +{ assign(".TraceWithMethods", as.environment("package:methods")) unlockBinding(".TraceWithMethods", getNamespace("methods")) environment(TraceWithMethods) <- getNamespace("methods") @@ -296,17 +299,17 @@ replace_trace <- function() { cache$trace_replaced <- TRUE } -#' @title Refresh decoration +#' Refresh decoration #' #' @description In cases when a function that is being traced is used through imports namespace #' by a package that is being loaded, the package won't get the correct copy, which results in #' the information loss. This function is hooked up to the library, to be run upon exist and #' check what functions might need redecoration, to propagate correct version to imports namespace. #' @param pkg package -refresh_decoration <- function(pkg) { +refresh_decoration <- function(pkg) +{ ienv <- getImportsEnv(pkg) need_redecoration <- intersect(ls(ienv), names(.decorated)) sapply(need_redecoration, undecorate) sapply(need_redecoration, decorate) } - diff --git a/R/runTests.R b/R/runTests.R index 78ad01f..5489f7a 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -1,5 +1,5 @@ -#' @title remove_failing_tcs +#' remove_failing_tcs #' @description removes the test cases that fail in GNU R #' @export remove_failing_tcs <- function() @@ -22,7 +22,7 @@ remove_failing_tcs <- function() get_tests(capt_dir) } -#' @title find_packages_using_function +#' find_packages_using_function #' @description find packages that use the function of interest #' @param functionName name of the function #' @param limit max number of packages to use @@ -63,7 +63,7 @@ find_packages_using_function <- function(functionName, limit = 100) top } -#' @title runPackageTests +#' runPackageTests #' @description ectract and run example/test codes from package #' @param pkg name of the packge #' @param lib.loc library location @@ -232,8 +232,7 @@ run_package_tests <- function (pkg, lib.loc = NULL, outDir) invisible(0L) } - -#' @title run_all_tests +#' run_all_tests #' @description run all the test/example codes from all the selected packages #' @param outDir output dir #' @param errorsAreFatal should errors break the process @@ -247,7 +246,7 @@ run_all_tests <- scope = c("all", "base", "recommended", "top"), srcdir = NULL, pkg_limit = NULL, custom_pkg_list = NULL) - { +{ ow <- options(warn = 1); on.exit(ow); scope <- match.arg(scope); status <- 0L; pkgs <- character(); @@ -304,7 +303,7 @@ run_all_tests <- invisible(status) } -#' @title get_tests +#' get_tests #' @description get the names of all generated test cases #' @param capt_dir location of test cases #' @export @@ -318,11 +317,12 @@ get_tests <- function(capt_dir) d } -#' @title generate_test_cases +#' generate_test_cases #' @description generates test cases based on environmental variables #' @import devtools methods #' @export -generate_test_cases <- function(){ +generate_test_cases <- function() +{ set_function_name(Sys.getenv("function_name")) set_pkg_name(Sys.getenv("package_name")) set_job(Sys.getenv("JOB_NAME")) diff --git a/R/testr.R b/R/testr.R index cd45ed3..540118e 100644 --- a/R/testr.R +++ b/R/testr.R @@ -1,4 +1,4 @@ -#' @title Adds regression tests to specified package. +#' Adds regression tests to specified package. #' #' @description Given a package, the code to be executed and a list of functions to capture, the function captures the selected functions from the package, then runs the specified code. It then generates tests from the captured information and using code coverage filters them against existing tests for the package. Those that increase the code coverage will be added to already existing testthat tests for the package. #' @@ -13,7 +13,11 @@ #' @param verbose Prints additional information. #' @export -gen_from_function <- function(package.dir = ".", code, functions, filter = TRUE, exclude_existing_tests = FALSE, build = TRUE, timed = FALSE, output, verbose = testr_options("verbose")) { +gen_from_function <- function(package.dir = ".", code, functions, filter = TRUE, + exclude_existing_tests = FALSE, build = TRUE, + timed = FALSE, output, + verbose = testr_options("verbose")) +{ cleanup = FALSE # stop all ongoing captures stop_capture_all() @@ -76,9 +80,7 @@ gen_from_function <- function(package.dir = ".", code, functions, filter = TRUE, detach(paste("package", package$package, sep=":"), unload = TRUE, character.only = TRUE) } - - -#' @title Generates tests for a package by running the code associated with it. +#' Generates tests for a package by running the code associated with it. #' #' @description Runs the examples, vignettes and possibly tests associated with the package and captures the usage of package's functions. Creates tests from the captured information, filters it according to the already existing tests and if any new tests are found, adds them to package's tests. #' @@ -91,7 +93,10 @@ gen_from_function <- function(package.dir = ".", code, functions, filter = TRUE, #' @param verbose Prints additional information. #' @export #' -gen_from_package <- function(package.dir = ".", include.tests = FALSE, timed = FALSE, filter = TRUE, build = TRUE, output, verbose = testr_options("verbose")) { +gen_from_package <- function(package.dir = ".", include.tests = FALSE, + timed = FALSE, filter = TRUE, build = TRUE, + output, verbose = testr_options("verbose")) +{ package = devtools::as.package(package.dir) devtools::document(package.dir) detach(paste("package", package$package, sep=":"), unload = TRUE, character.only = TRUE) @@ -126,7 +131,7 @@ gen_from_package <- function(package.dir = ".", include.tests = FALSE, timed = F gen_from_function(package.dir, code = f , filter = filter, exclude_existing_tests = include.tests, build = build, timed = timed, output, verbose = verbose) } -#' @title Enables capturing of the specified functions. +#' Enables capturing of the specified functions. #' #' @description The functions can be expressed as character literals in the form of either only a function name, #' or package name ::: function name, or directly as a symbol (i.e. only function name, or package name ::: function name). @@ -134,7 +139,8 @@ gen_from_package <- function(package.dir = ".", include.tests = FALSE, timed = F #' @param ... List of functions to capture, either character literals, or symbols #' @param verbose TRUE to display additional information #' @export -start_capture <- function(..., verbose = testr_options("verbose")) { +start_capture <- function(..., verbose = testr_options("verbose")) +{ old <- testr_options("capture.arguments") if (old) testr_options("capture.arguments", FALSE) for (f in parseFunctionNames(...)) { @@ -144,40 +150,44 @@ start_capture <- function(..., verbose = testr_options("verbose")) { invisible(NULL) } -#' @title Enables capturing of all builtin functions. +#' Enables capturing of all builtin functions. #' #' @description Wrapper around capture to capture builtin functions #' @param internal.only TRUE if only internal functions should be captured #' @param verbose TRUE to display additional information #' @export -start_capture_builtins <- function(internal.only = FALSE, verbose = testr_options("verbose")) { +start_capture_builtins <- function(internal.only = FALSE, + verbose = testr_options("verbose")) +{ functions <- builtins(internal.only) setup_capture(functions, verbose = verbose) } -#' @title Stops capturing the selected functions. +#' Stops capturing the selected functions. #' #' @description This function removes the tracing functionality for specified function #' @param ... Functions whose capture is to be dropped (uses the same format as capture) #' @param verbose TRUE to display additional information #' @export -stop_capture <- function(..., verbose = testr_options("verbose")) { +stop_capture <- function(..., verbose = testr_options("verbose")) +{ for (f in parseFunctionNames(...)) { undecorate(f$name, f$package, verbose = verbose) } invisible(NULL) } -#' @title Stops capturing all currently captured functions. +#' Stops capturing all currently captured functions. #' #' @description Remove tracing functionality for all the functions #' @param verbose TRUE to display additional information #' @export -stop_capture_all <- function(verbose = testr_options("verbose")) { +stop_capture_all <- function(verbose = testr_options("verbose")) +{ clear_decoration(verbose = verbose) } -#' @title Generates tests from captured information. +#' Generates tests from captured information. #' #' @description This function takes the tracing information collected by capture and generates #' testthat compatible testcases. @@ -189,7 +199,9 @@ stop_capture_all <- function(verbose = testr_options("verbose")) { #' @param clear_capture if FALSE captured traces will not be deleted after the generation so that subsequent calls to generate() can use them too #' @export generate <- function(output_dir, root = testr_options("capture.folder"), - timed = FALSE, clear_capture = TRUE, verbose = testr_options("verbose")) { + timed = FALSE, clear_capture = TRUE, + verbose = testr_options("verbose")) +{ cache$output.dir <- output_dir test_gen(root, output_dir, timed, verbose = verbose); if (clear_capture) { @@ -198,7 +210,7 @@ generate <- function(output_dir, root = testr_options("capture.folder"), } -#' @title Filter the generated tests so that only tests increasing code coverage will be kept. +#' Filter the generated tests so that only tests increasing code coverage will be kept. #' #' @description This function attempts to filter test cases based on code coverage collected by covr package. #' Filtering is done in iterational way by measuring code coverage of every test separately and skipping the ones @@ -218,7 +230,8 @@ generate <- function(output_dir, root = testr_options("capture.folder"), #' @export prune <- function(test_root, output_dir, ..., package_path = "", remove_tests = FALSE, compact = FALSE, - verbose = testr_options("verbose")) { + verbose = testr_options("verbose")) +{ functions <- parseFunctionNames(...) if (length(functions) && package_path != "") { stop("Both list of functions and package to be filtered aganist is supplied, please use one of the arguments") @@ -235,19 +248,19 @@ prune <- function(test_root, output_dir, ..., invisible(NULL) } - # helpers ------------------------------------------------------------------------------------------------------------- # TODO these are also in evaluation.R, perhaps evaluation.R should die and its non-api should move to helpers, or someplace else? -#' @title Generate tests for give code +#' Generate tests for give code #' @description Generates tests from given code and specific captured functions #' #' @param code Code from which the tests will be generated. #' @param output_dir Directory to which the tests will be generated. #' @param ... functions to be captured during the code execution (same syntax as capture function) #' @export -gen_from_code <- function(code, output_dir, ...) { +gen_from_code <- function(code, output_dir, ...) +{ code <- substitute(code) start_capture(...) eval(code) @@ -256,14 +269,15 @@ gen_from_code <- function(code, output_dir, ...) { invisible() } -#' @title Generate tests for give source +#' Generate tests for give source #' @description Generates tests by running given source file. #' #' @param src.root Source file to be executed and captured, or directory containing multiple files. #' @param output_dir Directory to which the tests will be generated. #' @param ... Functions to be tested. #' @export -gen_from_source <- function(src.root, output_dir, ...) { +gen_from_source <- function(src.root, output_dir, ...) +{ if (!file.exists(src.root)) { stop("Supplied source does not exist") } @@ -278,78 +292,3 @@ gen_from_source <- function(src.root, output_dir, ...) { generate(output_dir) invisible() } - - -# setup environment -testEnv <- new.env(parent = .GlobalEnv) -testEnv$pkgname <- c() -testEnv$pkg_name <- c() -testEnv$fname <- c() -testEnv$job <- c() -testEnv$build <- c() -testEnv$pkg_limit <- integer() -testEnv$scope <- c() -testEnv$custom_pkg_list <- NA -testEnv$root <- c() # getwd() -testEnv$testOutDir <- c() # paste0(getwd(), "/", testEnv$job, "_", testEnv$build) -testEnv$capt_dir <- c() # file.path(testEnv$root,"capture") -testEnv$arch_dir <- c() # file.path(testEnv$root,"tests") -testEnv$test_dir <- c() # file.path(testEnv$root,"capture",paste0(testEnv$pkg_name,"___", testEnv$fname)) - - -set_examed_pkg_name <- function(pkgname) -{ - testEnv$pkgname <- pkgname -} -set_pkg_name <- function(pkg_name) -{ - testEnv$pkg_name <- pkg_name -} -set_function_name <- function(fname) -{ - testEnv$fname <- fname -} -set_job <- function(job) -{ - testEnv$job <- job -} -set_build <- function(build) -{ - testEnv$build <- build -} -set_pkg_limit <- function(limit) -{ - testEnv$pkg_limit <- limit -} -set_scope <- function(scope = c("all")) -{ - testEnv$scope <- scope -} -set_custom_pkg_list <- function(pkgs) -{ - testEnv$custom_pkg_list <- pkgs -} -set_root <- function(root) -{ - testEnv$root <- root -} -set_test_out_dir <- function(test_out_dir) -{ - testEnv$testOutDir <- test_out_dir -} -set_capt_dir <- function(capt_dir) -{ - testEnv$capt_dir <- capt_dir -} -get_capt_dir <- function() -{ - testEnv$capt_dir -} -set_arch_dir <- function(arch_dir) -{ - testEnv$arch_dir <- arch_dir -} -set_test_dir <- function(test_dir) -{ - testEnv$test_dir <- test_dir -} diff --git a/R/zzz.R b/R/zzz.R index 124a4ba..af5f943 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -13,14 +13,13 @@ kFuncPrefix <- "func: " kArgsPrefix <- "argv: " blacklist <- c(".GlobalEnv", ".Internal", ".Primitive", "substitute", - ".Machine", "on.exit", - "withCallingHandlers", "quote", - "c", "NextMethod", "UseMethod", "standardGeneric", "identity","missing", - "sys.call", "withVisible", "findRestarts", "local", "withRestarts", "formals", - ".C", ".Call", ".External", ".External.graphics", ".External2", ".Fortran", ".Call.graphics", - "length", "as.environment", - "length<-", "call", "switch", "nargs", "as.numeric", "library.dynam.unload", - "suppressMessages", + ".Machine", "on.exit", "withCallingHandlers", "quote", + "c", "NextMethod", "UseMethod", "standardGeneric", "identity", + "sys.call", "withVisible", "findRestarts", "local", ".Fortran", + ".C", ".Call", ".External", ".External.graphics", ".External2", + "length", "as.environment", "missing", "library.dynam.unload", + "length<-", "call", "switch", "nargs", "as.numeric", + "suppressMessages", "withRestarts", "formals", ".Call.graphics", # errors with trace "match.call", ".doTrace", "tracingState", "traceback", "trace", "get0", "forceAndCall", # added in R.3.2.1 @@ -44,7 +43,8 @@ operators <- c("(", ":", "%sep%", "[", "[[", "$", "@", "=", "[<-", primitive_generics_fails <- c(.S3PrimitiveGenerics, "round", "min", "max", "expression", "attr") -.onLoad <- function(libname, pkgname) { +.onLoad <- function(libname, pkgname) +{ # make sure temp_dir is empty cache$temp_dir <- tempdir() clean_temp() @@ -63,7 +63,8 @@ primitive_generics_fails <- c(.S3PrimitiveGenerics, "round", "min", "max", "expr "parallel_tests"=TRUE, "rtests"=FALSE, "rprofile"=' -.First <- function() { +.First <- function() +{ library(testr) library(utils) builtin_capture() @@ -84,7 +85,8 @@ primitive_generics_fails <- c(.S3PrimitiveGenerics, "round", "min", "max", "expr #' @param value value to assign (optional) #' @export #' -testr_options <- function(o, value) { +testr_options <- function(o, value) +{ res <- getOption("testr") if (missing(value)) { ## just querying @@ -109,3 +111,20 @@ testr_options <- function(o, value) { options("testr" = res) } } + + +# setup environment +testEnv <- new.env(parent = .GlobalEnv) +testEnv$pkgname <- c() +testEnv$pkg_name <- c() +testEnv$fname <- c() +testEnv$job <- c() +testEnv$build <- c() +testEnv$pkg_limit <- integer() +testEnv$scope <- c() +testEnv$custom_pkg_list <- NA +testEnv$root <- c() # getwd() +testEnv$testOutDir <- c() # paste0(getwd(), "/", testEnv$job, "_", testEnv$build) +testEnv$capt_dir <- c() # file.path(testEnv$root,"capture") +testEnv$arch_dir <- c() # file.path(testEnv$root,"tests") +testEnv$test_dir <- c() # file.path(testEnv$root,"capture",paste0(testEnv$pkg_name,"___", testEnv$fname)) From 50aa609e13bd683ed95f109cfd56b729c0359ee7 Mon Sep 17 00:00:00 2001 From: parham Date: Fri, 26 Aug 2016 15:49:05 +0200 Subject: [PATCH 35/66] reuse code for extract/run example/testcase/vignet --- R/runTests.R | 178 ++++++--------------------------------------------- 1 file changed, 19 insertions(+), 159 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index 5489f7a..3153d2f 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -69,167 +69,27 @@ find_packages_using_function <- function(functionName, limit = 100) #' @param lib.loc library location #' @param outDir output directory to store extracted code #' @export -run_package_tests <- function (pkg, lib.loc = NULL, outDir) +run_package_tests <- function (pkg, lib.loc = NULL, outDir, verbose = TRUE) { - pkgdir <- find.package(pkg) - owd1 <- setwd(outDir) - # on.exit(setwd(owd1)) - - .createExdotR <- function (pkg, pkgdir, silent = FALSE, use_gct = FALSE, addTiming = FALSE, ..., commentDontrun = TRUE, commentDonttest = TRUE) - { - Rfile <- paste0(pkg, "-Ex.R") - db <- tools::Rd_db(basename(pkgdir), lib.loc = dirname(pkgdir)) - if (!length(db)) { - message("no parsed files found") - return(invisible(NULL)) - } - files <- names(db) - if (pkg == "grDevices") - files <- files[!grepl("^(unix|windows)/", files)] - filedir <- tempfile() - dir.create(filedir) - on.exit(unlink(filedir, recursive = TRUE)) - cnt <- 0L - for (f in files) { - nm <- sub("\\.[Rr]d$", "", basename(f)) - tools::Rd2ex(db[[f]], file.path(filedir, paste(nm, "R", sep = ".")), - defines = NULL, commentDontrun = commentDontrun, - commentDonttest = commentDonttest) - cnt <- cnt + 1L - if (!silent && cnt%%10L == 0L) - message(".", appendLF = FALSE, domain = NA) - } - nof <- length(Sys.glob(file.path(filedir, "*.R"))) - if (!nof) - return(invisible(NULL)) - massageExamples <- function (pkg, files, outFile = stdout(), ..., commentDonttest = TRUE, commentDontrun = TRUE) - { - if (dir.exists(files[1L])) { - old <- Sys.setlocale("LC_COLLATE", "C") - files <- sort(Sys.glob(file.path(files, "*.R"))) - Sys.setlocale("LC_COLLATE", old) - } - if (is.character(outFile)) { - out <- file(outFile, "wt") - on.exit(close(out)) - } - else { - out <- outFile - } - - lines <- c( - paste0("pkgname <- \"", pkg, "\""), - "assign(\"par.postscript\", graphics::par(no.readonly = TRUE))", - "options(contrasts = c(unordered = \"contr.treatment\", ordered = \"contr.poly\"))", - "graphics.off()" - ) - cat(lines, sep = "\n", file = out) - if (pkg == "tcltk") { - if (capabilities("tcltk")) - cat("require('tcltk')\n", file = out) - else - cat("stop(\"tcltk not found!\")\n", file = out) - } - else if (pkg != "base") - cat("library('", pkg, "')\n", sep = "", file = out) - - for (file in files) { - nm <- sub("\\.R$", "", basename(file)) - nm <- gsub("[^- .a-zA-Z0-9_]", ".", nm, perl = TRUE, useBytes = TRUE) - if (pkg == "grDevices" && nm == "postscript") next - if (pkg == "graphics" && nm == "text") next - if (!file.exists(file)) stop("file ", file, " cannot be opened", domain = NA) - lines <- readLines(file) - - patterns <- c("^[[:space:]]*#", "^[[:space:]]*help\\(", - "^[[:space:]]*\\?", "^[[:space:]]*help\\.search", - "^[[:space:]]*nameEx.{2}help\\.search", "demo\\(", - "data\\(package", "data\\(\\)", - "^library\\(\\)", "^library\\(lib\\.loc", - "^file\\.show\\(" - ) - - for (pattern in patterns) { - com <- grep(pattern, lines, perl = TRUE, useBytes = TRUE) - if (length(com)) - lines <- lines[-com] - } - - have_par <- any(grepl("[^a-zA-Z0-9.]par\\(|^par\\(", lines, perl = TRUE, useBytes = TRUE)) - have_contrasts <- any(grepl("options\\(contrasts", lines, perl = TRUE, useBytes = TRUE)) - cat("### * ", nm, "\n\n", sep = "", file = out) - if (commentDonttest) { - dont_test <- FALSE - for (line in lines) { - if (any(grepl("^[[:space:]]*## No test:", line, perl = TRUE, useBytes = TRUE))) dont_test <- TRUE - if (!dont_test) cat(line, "\n", sep = "", file = out) - if (any(grepl("^[[:space:]]*## End\\(No test\\)", line, perl = TRUE, useBytes = TRUE))) dont_test <- FALSE - } - } - if (commentDontrun) { - dont_run <- FALSE - for (line in lines) { - if (any(grepl("^[[:space:]]*## Not run:", line, perl = TRUE, useBytes = TRUE))) dont_test <- TRUE - if (!dont_test) cat(line, "\n", sep = "", file = out) - if (any(grepl("^[[:space:]]*## End\\(Not run\\)", line, perl = TRUE, useBytes = TRUE))) dont_test <- FALSE - } - } - else for (line in lines) { - if (!(line = "")) { - cat(line, "\n", sep = "", file = out) - } - } - if (have_par) cat("graphics::par(get(\"par.postscript\"))\n", file = out) - if (have_contrasts) cat("base::options(contrasts = c(unordered = \"contr.treatment\",", "ordered = \"contr.poly\"))\n", sep = "", file = out) - } - cat("###### FOOTER ######\n", file = out) - cat("options(digits = 7L)\n", file = out) - cat("grDevices::dev.off()\n", file = out) - } - - massageExamples(pkg, filedir, Rfile, commentDonttest = commentDonttest, ...) - invisible(Rfile) - } - - message(gettextf("Testing examples for package %s", sQuote(pkg)), - domain = NA) - Rfile <- .createExdotR(pkg, pkgdir, silent = TRUE) - if (length(Rfile)) { - for (file in Rfile) { - print(paste0("@@@@@@@@@@ START EXAMPLE: ", file, " @@@@@@@@@@")) - oldGlobals <- c(ls(.GlobalEnv), "testEnv") - tryCatch( source(file, echo = FALSE, local = .GlobalEnv), error = function(e) print(e) ) - allGlobals <- ls(.GlobalEnv) - allGlobals <- allGlobals[!is.element(allGlobals, oldGlobals)] - rm(list = allGlobals, envir = .GlobalEnv) - print(paste0("@@@@@@@@@@ DONE WITH EXAMPLE: ", file, " @@@@@@@@@@")) - } - } else { - warning(gettextf("no examples found for package %s", sQuote(pkg)), call. = FALSE, domain = NA) - } - - d <- file.path(pkgdir, "tests") - this <- paste(pkg, "tests", sep = "-") - unlink(this, recursive = TRUE) - dir.create(this) - file.copy(Sys.glob(file.path(d, "*")), this, recursive = TRUE) - owd2 <- setwd(".") - setwd(this) - on.exit(setwd(owd2)) - message(gettextf("Running specific tests for package %s", sQuote(pkg)), domain = NA) - Rfiles <- dir(".", pattern = "\\.R$") - if (length(Rfiles)) { - for (file in Rfiles) { - print(paste0("&&&&&&& START TEST: ", file, " &&&&&&&")) - oldGlobals <- c(ls(.GlobalEnv), "testEnv") - tryCatch( source(file, echo = FALSE, local = .GlobalEnv), error = function(e) print(e) ) - allGlobals <- ls(.GlobalEnv) - allGlobals <- allGlobals[!is.element(allGlobals, oldGlobals)] - rm(list = allGlobals, envir = .GlobalEnv) - print(paste0("&&&&&&& DONE WITH TEST: ", file, " &&&&&&&")) - } + info <- tools::getVignetteInfo(package = pkg) + vdir <- info[ ,2] + vfiles <- info[ ,6] + p <- file.path(vdir, "doc", vfiles) + if (verbose) cat(paste("Running vignettes (", length(vfiles), "files)\n")) + # vignettes are not expected to be runnable, silence errors + invisible( tryCatch( sapply(p, source), error = function(x) invisible() ) ) + # run package examples + package.dir <- find.package(pkg) + manPath <- file.path(package.dir, "man") + examples <- list.files(manPath, pattern = "\\.[Rr]d$", no.. = TRUE) + if (verbose) cat(paste("Running examples (", length(examples), "man files)\n")) + for (f in examples) { + code <- example_code(file.path(manPath, f)) + tryCatch(eval(parse(text = code)), error = function(x) print(x)) } - invisible(0L) + # run tests + if (verbose) cat("Running package tests\n") + testthat::test_dir(file.path(package.dir, "tests", "testthat"), filter = NULL) } #' run_all_tests From 49cfaf93f38a84df5464c0e72ec5d24c0c72ee1d Mon Sep 17 00:00:00 2001 From: parham Date: Fri, 26 Aug 2016 15:52:24 +0200 Subject: [PATCH 36/66] start fix (issue #5) --- R/capture.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/capture.R b/R/capture.R index 876a4e1..459be17 100644 --- a/R/capture.R +++ b/R/capture.R @@ -48,13 +48,15 @@ decorate <- function(func, package, verbose) return(invisible()) } write.call <- call("write_capture", if (is.na(package)) func else paste(package, func, sep = ":::"), quote(sys.frame(-4))) #nolint + write.call[[1]] <- testr::write_capture tc <- call("trace", func, quote(write.call), print = testr_options("verbose")) hidden <- FALSE if (!func %in% ls(as.environment(if (is.na(package)) .GlobalEnv else paste("package", package, sep = ":")))) { - tc[["where"]] <- call("getNamespace", package) + if (!is.na(package)) + tc[["where"]] <- call("getNamespace", package) hidden <- TRUE } if (verbose) { From 5ed5bc4ff64c78b4d440f9e8669e3072422910fb Mon Sep 17 00:00:00 2001 From: parham Date: Fri, 26 Aug 2016 15:57:42 +0200 Subject: [PATCH 37/66] syntax --- R/RcppExports.R | 3 +-- R/generate.R | 18 ++++++++++++------ R/runTests.R | 13 ++++--------- R/testr.R | 30 +++++++++++++++++++++--------- 4 files changed, 38 insertions(+), 26 deletions(-) diff --git a/R/RcppExports.R b/R/RcppExports.R index 0f55059..3dce2cc 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -1,8 +1,7 @@ # This file was generated by Rcpp::compileAttributes # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 -WriteCapInfo_cpp <- function(fname, args_env) -{ +WriteCapInfo_cpp <- function(fname, args_env) { invisible(.Call('testr_WriteCapInfo_cpp', PACKAGE = 'testr', fname, args_env)) } diff --git a/R/generate.R b/R/generate.R index 1b8304f..92fcb38 100644 --- a/R/generate.R +++ b/R/generate.R @@ -6,7 +6,7 @@ #' @param output_dir directory where generated test cases will be saved #' @param timed whether result is dependent on time of generation #' @param verbose wheater display debug output -test_gen <- function(root, output_dir, timed = FALSE, verbose=testr_options("verbose")) +test_gen <- function(root, output_dir, timed = FALSE, verbose = testr_options("verbose")) { if (verbose) { cat("Output:", output_dir, "\n") @@ -18,18 +18,21 @@ test_gen <- function(root, output_dir, timed = FALSE, verbose=testr_options("ver return(invisible()) } if (file.info(root)$isdir) { - all.capture <- lapply(list.files(root, recursive=TRUE, all.files = TRUE), function(x) file.path(root,x)) + all.capture <- lapply(list.files(root, recursive=TRUE, all.files = TRUE), + function(x) file.path(root,x)) } else { all.capture <- root } # output dir checks if (missing(output_dir)) stop("A output directory must be provided!"); if (!file.exists(output_dir) || !file.info(output_dir)$isdir) dir.create(output_dir) - if (timed) output_dir <- file.path(output_dir, format(Sys.time(), "%Y-%m-%d %H:%M:%S")) + if (timed) output_dir <- file.path(output_dir, format(Sys.time(), + "%Y-%m-%d %H:%M:%S")) cache$output_dir <- output_dir # bad.arguments file to store incorrect arguments cache$bad_argv <- file.path(cache$output_dir, "bad_arguments"); - if (!file.exists(cache$bad_argv) && !file.create(cache$bad_argv)) stop("Unable to create file: ", cache$bad_argv) + if (!file.exists(cache$bad_argv) && !file.create(cache$bad_argv)) + stop("Unable to create file: ", cache$bad_argv) cache$tid <- list() Map(function(x) { process_capture(x) }, all.capture) cache$tid <- NULL @@ -55,8 +58,11 @@ ensure_file <- function(name, funHash) dir.create(tc.folder, showWarnings = FALSE) # get the index of the file, based on number of files in the folder (but use the cache information for it) - cache$tid[[name]] <- ifelse(is.null(cache$tid[[name]]), 0, cache$tid[[name]] + 1) - tc.file = file.path(tc.folder, paste("test.", gsub("___", ".", fname), ".", funHash, ".R", sep = ""), fsep = .Platform$file.sep) + cache$tid[[name]] <- ifelse(is.null(cache$tid[[name]]), 0, + cache$tid[[name]] + 1) + tc.file = file.path(tc.folder, paste("test.", gsub("___", ".", fname), ".", + funHash, ".R", sep = ""), + fsep = .Platform$file.sep) # TODO perhaps this is not needed for testthat if (!file.exists(tc.file)) { diff --git a/R/runTests.R b/R/runTests.R index 3153d2f..1e1f820 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -109,11 +109,9 @@ run_all_tests <- { ow <- options(warn = 1); on.exit(ow); scope <- match.arg(scope); status <- 0L; pkgs <- character(); - known_packages <- tools:::.get_standard_package_names() all_avail_packages <- names(installed.packages()[ ,1]) avail_packages <- all_avail_packages[!is.element(all_avail_packages, c(known_packages$base, known_packages$recommended))] - pkgs <- c(character(0)) if (scope %in% c("all", "base")) @@ -130,31 +128,28 @@ run_all_tests <- envir = testEnv), pkgs) if (!is.na(custom_pkg_list)) { - pkgs <- c( custom_pkg_list[ is.element(custom_pkg_list, all_avail_packages) ], pkgs ) + pkgs <- c( custom_pkg_list[ is.element(custom_pkg_list, + all_avail_packages) ], pkgs ) } if (pkg_limit > 0) pkgs <- pkgs[ 1:pkg_limit ] - pkgs <- pkgs[ !duplicated(pkgs) ] - # Sometimes last value is NA pkgs <- pkgs[!is.na(pkgs)] pkgs <- pkgs[!pkgs == "NA"] if (scope %in% c("top") && length(pkgs) < pkg_limit ) { - pkgs <- c(known_packages$base, known_packages$recommended, avail_packages) + pkgs <- c(known_packages$base, known_packages$recommended, + avail_packages) pkgs <- pkgs[ !duplicated(pkgs) ] pkgs <- pkgs[1:pkg_limit] } - if(length(pkgs)) { print("Selected packages:") print(pkgs) for (pkg in pkgs) { print(paste0("############ START PACKAGE: ", pkg, " #######")) - tryCatch(run_package_tests(pkg, .Library, outDir), error = function(e) print(e) ) - print(paste0("############ DONE WITH PACKAGE: ", pkg, " #######")) } } else { diff --git a/R/testr.R b/R/testr.R index 540118e..08820e9 100644 --- a/R/testr.R +++ b/R/testr.R @@ -73,11 +73,13 @@ gen_from_function <- function(package.dir = ".", code, functions, filter = TRUE, if (filter) { if (verbose) cat("Pruning tests - this may take some time...\n") - filter_tests(output, file.path(package$path, "tests/testthat"), functions, package.dir, compact = TRUE, verbose = verbose) + filter_tests(output, file.path(package$path, "tests/testthat"), + functions, package.dir, compact = TRUE, verbose = verbose) } # clear the temp folder, if we used a temp folder implicitly if (cleanup) unlink(output, recursive = T) - detach(paste("package", package$package, sep=":"), unload = TRUE, character.only = TRUE) + detach(paste("package", package$package, sep=":"), unload = TRUE, + character.only = TRUE) } #' Generates tests for a package by running the code associated with it. @@ -99,7 +101,8 @@ gen_from_package <- function(package.dir = ".", include.tests = FALSE, { package = devtools::as.package(package.dir) devtools::document(package.dir) - detach(paste("package", package$package, sep=":"), unload = TRUE, character.only = TRUE) + detach(paste("package", package$package, sep=":"), unload = TRUE, + character.only = TRUE) f <- function() { # run package vignettes info <- tools::getVignetteInfo(package = package$package) @@ -113,7 +116,8 @@ gen_from_package <- function(package.dir = ".", include.tests = FALSE, manPath <- file.path(package.dir, "man") examples <- list.files(manPath, pattern = "\\.[Rr]d$", no.. = TRUE) if (length(examples) != 0) { - if (verbose) cat(paste("Running examples (", length(examples), "man files)\n")) + if (verbose) + cat(paste("Running examples (", length(examples), "man files)\n")) for (f in examples) { code <- example_code(file.path(manPath, f)) tryCatch(eval(parse(text = code)), error = function(x) print(x)) @@ -122,13 +126,18 @@ gen_from_package <- function(package.dir = ".", include.tests = FALSE, # run tests if (include.tests) { if (verbose) cat("Running package tests\n") - testthat::test_dir(file.path(package.dir, "tests", "testthat"), filter = NULL) + testthat::test_dir(file.path(package.dir, "tests", "testthat"), + filter = NULL) } } if (missing(output)) - gen_from_function(package.dir, code = f , filter = filter, exclude_existing_tests = include.tests, build = build, timed = timed, verbose = verbose) + gen_from_function(package.dir, code = f , filter = filter, + exclude_existing_tests = include.tests, build = build, + timed = timed, verbose = verbose) else - gen_from_function(package.dir, code = f , filter = filter, exclude_existing_tests = include.tests, build = build, timed = timed, output, verbose = verbose) + gen_from_function(package.dir, code = f , filter = filter, + exclude_existing_tests = include.tests, build = build, + timed = timed, output, verbose = verbose) } #' Enables capturing of the specified functions. @@ -244,7 +253,9 @@ prune <- function(test_root, output_dir, ..., fn <- sapply(functions, `[`, 1) functions <- sapply(functions, `[`, 2) names(functions) <- fn - filter_tests(test_root, output_dir, functions, package_path, remove_tests = remove_tests, compact = compact, verbose = verbose) + filter_tests(test_root, output_dir, functions, package_path, + remove_tests = remove_tests, compact = compact, + verbose = verbose) invisible(NULL) } @@ -282,7 +293,8 @@ gen_from_source <- function(src.root, output_dir, ...) stop("Supplied source does not exist") } if (file.info(src.root)$isdir) { - src.root <- list.files(src.root, pattern = "\\[rR]", recursive = TRUE, full.names = TRUE) + src.root <- list.files(src.root, pattern = "\\[rR]", + recursive = TRUE, full.names = TRUE) } start_capture(...) for (src.file in src.root) { From 03ef09c8ced8bee55a68d91529995940aac7b4b1 Mon Sep 17 00:00:00 2001 From: parham Date: Fri, 26 Aug 2016 15:58:08 +0200 Subject: [PATCH 38/66] documentation --- man/run_package_tests.Rd | 2 +- man/test_gen.Rd | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/man/run_package_tests.Rd b/man/run_package_tests.Rd index 5792348..5bfabf9 100644 --- a/man/run_package_tests.Rd +++ b/man/run_package_tests.Rd @@ -4,7 +4,7 @@ \alias{run_package_tests} \title{runPackageTests} \usage{ -run_package_tests(pkg, lib.loc = NULL, outDir) +run_package_tests(pkg, lib.loc = NULL, outDir, verbose = TRUE) } \arguments{ \item{pkg}{name of the packge} diff --git a/man/test_gen.Rd b/man/test_gen.Rd index 51b417f..4870e27 100644 --- a/man/test_gen.Rd +++ b/man/test_gen.Rd @@ -18,7 +18,6 @@ test_gen(root, output_dir, timed = FALSE, } \description{ This function works with the trace information generated by instrumented GNU-R. - It is strictly oriented to that, please see readme for more information. } From 69e4b462f060dbb43421f1b766fec65d05ed1982 Mon Sep 17 00:00:00 2001 From: parham Date: Sun, 28 Aug 2016 14:28:36 +0200 Subject: [PATCH 39/66] fix location generated test cases --- R/runTests.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/runTests.R b/R/runTests.R index 1e1f820..85203b8 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -212,5 +212,5 @@ generate_test_cases <- function() set_arch_dir(file.path(testEnv$root,"tests")) set_test_dir(file.path(testEnv$root,"capture",paste0(testEnv$pkg_name,"___", testEnv$fname))) - write_captured_tests(testEnv$arch_dir) + write_captured_tests("tests") } From a52b6d8839d5b2089387164f08e4cf7a4945574c Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Thu, 12 Jan 2017 10:33:11 +0100 Subject: [PATCH 40/66] Do not remove failing test cases. Keep them for subsequent debugging. --- R/generate.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/generate.R b/R/generate.R index 92fcb38..978fef0 100644 --- a/R/generate.R +++ b/R/generate.R @@ -243,7 +243,7 @@ write_captured_tests <- function(path) set_root(getwd()) set_capt_dir(file.path(testEnv$root,"capture")) - tc <- remove_failing_tcs() + #tc <- remove_failing_tcs() dirs <- list.dirs(testEnv$capt_dir, recursive = FALSE) if (length(grep("___", dirs))) { From 1432dadcd1cf33467881c09ba02d38339b14e127 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Thu, 12 Jan 2017 13:18:47 +0100 Subject: [PATCH 41/66] Fixes for broken test-generation tool - Run all test scripts in tests/ instead of just testthat (packages should be installed with "--install-tests" or NO tests will be run) - Look for example source in R-ex (packages should be installed with --example) - Invalid test cases are preserved for debugging purposes The test generation code appears to be generating a large number of invalid test cases (~ 90% invalid). --- NAMESPACE | 4 - R/RcppExports.R | 2 +- R/helpers.R | 69 ------- R/runTests.R | 279 ++++++++++------------------ R/zzz.R | 17 -- man/find_packages_using_function.Rd | 17 -- man/generate_test_cases.Rd | 6 +- man/remove_failing_tcs.Rd | 12 -- man/run_all_tests.Rd | 27 --- man/run_package.Rd | 21 +++ man/run_package_source.Rd | 23 +++ man/run_package_tests.Rd | 19 -- man/validate_tests.Rd | 12 ++ src/RcppExports.cpp | 4 +- 14 files changed, 160 insertions(+), 352 deletions(-) delete mode 100644 man/find_packages_using_function.Rd delete mode 100644 man/remove_failing_tcs.Rd delete mode 100644 man/run_all_tests.Rd create mode 100644 man/run_package.Rd create mode 100644 man/run_package_source.Rd delete mode 100644 man/run_package_tests.Rd create mode 100644 man/validate_tests.Rd diff --git a/NAMESPACE b/NAMESPACE index f09536d..3747ca2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,6 @@ # Generated by roxygen2: do not edit by hand export(clear_decoration) -export(find_packages_using_function) export(gen_from_code) export(gen_from_function) export(gen_from_package) @@ -10,9 +9,6 @@ export(generate) export(generate_test_cases) export(get_tests) export(prune) -export(remove_failing_tcs) -export(run_all_tests) -export(run_package_tests) export(setup_capture) export(start_capture) export(start_capture_builtins) diff --git a/R/RcppExports.R b/R/RcppExports.R index 3dce2cc..4a7bc7c 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -1,4 +1,4 @@ -# This file was generated by Rcpp::compileAttributes +# Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 WriteCapInfo_cpp <- function(fname, args_env) { diff --git a/R/helpers.R b/R/helpers.R index 650f896..a1fc783 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -234,72 +234,3 @@ example_code <- function(fromFile) result } -set_examed_pkg_name <- function(pkgname) -{ - testEnv$pkgname <- pkgname -} - -set_pkg_name <- function(pkg_name) -{ - testEnv$pkg_name <- pkg_name -} - -set_function_name <- function(fname) -{ - testEnv$fname <- fname -} - -set_job <- function(job) -{ - testEnv$job <- job -} - -set_build <- function(build) -{ - testEnv$build <- build -} - -set_pkg_limit <- function(limit) -{ - testEnv$pkg_limit <- limit -} - -set_scope <- function(scope = c("all")) -{ - testEnv$scope <- scope -} - -set_custom_pkg_list <- function(pkgs) -{ - testEnv$custom_pkg_list <- pkgs -} - -set_root <- function(root) -{ - testEnv$root <- root -} - -set_test_out_dir <- function(test_out_dir) -{ - testEnv$testOutDir <- test_out_dir -} - -set_capt_dir <- function(capt_dir) -{ - testEnv$capt_dir <- capt_dir -} - -get_capt_dir <- function() -{ - testEnv$capt_dir -} - -set_arch_dir <- function(arch_dir) -{ - testEnv$arch_dir <- arch_dir -} - -set_test_dir <- function(test_dir) -{ - testEnv$test_dir <- test_dir -} diff --git a/R/runTests.R b/R/runTests.R index 85203b8..8c922ff 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -1,162 +1,90 @@ -#' remove_failing_tcs -#' @description removes the test cases that fail in GNU R -#' @export -remove_failing_tcs <- function() -{ - ## check if generated test cases run without failure - # get the generated test cases - capt_dir <- get_capt_dir() - tc <- get_tests(capt_dir) - # check which test cases fail? - res <- sapply(tc, function(x) { - oldGlobals <- c(ls(.GlobalEnv), "testEnv") - z = try(source(x, local = .GlobalEnv)) - allGlobals <- ls(.GlobalEnv) - allGlobals <- allGlobals[!is.element(allGlobals, oldGlobals)] - rm(list = allGlobals, envir = .GlobalEnv) - inherits(z, "try-error") - }) - # remove failing test cases - unlink(names(res[res == TRUE])) - get_tests(capt_dir) -} -#' find_packages_using_function -#' @description find packages that use the function of interest -#' @param functionName name of the function -#' @param limit max number of packages to use -#' @export -find_packages_using_function <- function(functionName, limit = 100) -{ - top <- c(character()) - res <- c() - for (path in .libPaths()) { - call <- paste0("egrep -R -n \'\\<",functionName,"\\>\' ",path) - res <- c(res, system(call, intern = TRUE) ) +#' Runs all available source code from a package in order to generate +#' usable tests. +#' +#' @param pkg the name of the package (must be installed) +#' @param flist list of functions to instrument for capture +#' @param output.dir directory to write all harnes scripts, tests, and generated content. +run_package <- function(pkg, flist, output.dir = getwd()) { + + cat(sprintf("Package %s:\n", pkg)) + + package.dir <- find.package(pkg) + exScripts <- list.files(file.path(package.dir, "R-ex"), pattern = ".+\\.[RSrs]", full.names = TRUE) + testScripts <- list.files(file.path(package.dir, "tests"), pattern = ".+\\.[RSrs]", full.names = TRUE) + + pkg.output.dir <- file.path(output.dir, pkg) + + if(dir.exists(pkg.output.dir)) { + unlink(pkg.output.dir, recursive = TRUE) } + dir.create(pkg.output.dir) - # remove line that dont start with library path - if(length(res)) { - for (path in .libPaths()) { - keep <- grepl(path, res) - res2 <- res[keep] - # remove library path - res2 <- sapply(res2, function(x) { - strsplit(x[[1]], path)[[1]][2]}, - simplify = TRUE, USE.NAMES = FALSE) - # select package name from path - res2 <- sapply(res2, function(x) { - strsplit(x[[1]], "/")[[1]][2]}, - simplify = TRUE, USE.NAMES = FALSE) - # make a count table from package name occurence - if(length(res2) > 0) { - resTab <- as.data.frame(unclass(rle(sort(res2))))[ , 2:1] - resTab <- resTab[with(resTab, order(-lengths)), ] - if (nrow(resTab) < limit) - top <- c(top, as.character(resTab$values)) - else - top <- c(top, as.character(resTab$values[1:limit])) - } - } + for(script in c(exScripts, testScripts)) { + run_package_source(pkg, flist, script, pkg.output.dir) } - top + + validate_tests(file.path(pkg.output.dir, "captured")) } -#' runPackageTests -#' @description ectract and run example/test codes from package -#' @param pkg name of the packge -#' @param lib.loc library location -#' @param outDir output directory to store extracted code -#' @export -run_package_tests <- function (pkg, lib.loc = NULL, outDir, verbose = TRUE) -{ - info <- tools::getVignetteInfo(package = pkg) - vdir <- info[ ,2] - vfiles <- info[ ,6] - p <- file.path(vdir, "doc", vfiles) - if (verbose) cat(paste("Running vignettes (", length(vfiles), "files)\n")) - # vignettes are not expected to be runnable, silence errors - invisible( tryCatch( sapply(p, source), error = function(x) invisible() ) ) - # run package examples - package.dir <- find.package(pkg) - manPath <- file.path(package.dir, "man") - examples <- list.files(manPath, pattern = "\\.[Rr]d$", no.. = TRUE) - if (verbose) cat(paste("Running examples (", length(examples), "man files)\n")) - for (f in examples) { - code <- example_code(file.path(manPath, f)) - tryCatch(eval(parse(text = code)), error = function(x) print(x)) +#' Executes a script in an independent R session and stores the output in the +#' package working directory. +#' +#' @param pkg the name of the package (must be installed) +#' @param source.file the full path of the source file to execute +#' @param flist list of functions to intrument +#' @param output.dir the output dir to write capture tests and output +run_package_source <- function(pkg, flist, source, output.dir) { + + + cat(sprintf(" Running %s... ", basename(source))) + + script <- c( + "library(testr)", + sprintf("library(%s)", pkg), + sprintf("setwd('%s')", dirname(source)), + sprintf("start_capture(%s)", deparse(flist)), + sprintf("source('%s', echo = TRUE)", basename(source)), + sprintf("generate('%s')", file.path(output.dir, "captured")) + ) + + harnessScript <- file.path(output.dir, basename(source)) + writeLines(script, harnessScript) + + scriptOutput = paste(harnessScript, "out", sep=".") + errorCode <- system2(command = "Rscript", args = c(harnessScript), stdout = scriptOutput, stderr = scriptOutput) + + if(errorCode == 0) { + cat("OK\n") + } else { + cat(sprintf("FAILED: Exited with %d\n", errorCode)) } - # run tests - if (verbose) cat("Running package tests\n") - testthat::test_dir(file.path(package.dir, "tests", "testthat"), filter = NULL) } -#' run_all_tests -#' @description run all the test/example codes from all the selected packages -#' @param outDir output dir -#' @param errorsAreFatal should errors break the process -#' @param scope how to prioritize/select packages to run -#' @param srcdir source directory -#' @param pkg_limit maximum number of packages to use for test generation -#' @param custom_pkg_list custom list of packages of interest to use for test generation -#' @export -run_all_tests <- - function (outDir = ".", errorsAreFatal = FALSE, - scope = c("all", "base", "recommended", "top"), - srcdir = NULL, pkg_limit = NULL, - custom_pkg_list = NULL) -{ - ow <- options(warn = 1); on.exit(ow); scope <- match.arg(scope); - status <- 0L; pkgs <- character(); - known_packages <- tools:::.get_standard_package_names() - all_avail_packages <- names(installed.packages()[ ,1]) - avail_packages <- all_avail_packages[!is.element(all_avail_packages, c(known_packages$base, known_packages$recommended))] - pkgs <- c(character(0)) - - if (scope %in% c("all", "base")) - pkgs <- known_packages$base - if (scope %in% c("all", "recommended")) - pkgs <- c(pkgs, known_packages$recommended) - if (scope %in% c("all")) - pkgs <- c(pkgs, avail_packages) - if (scope %in% c("top")) - pkgs <- c( - do.call( - find_packages_using_function, - list(functionName = testEnv$fname, limit = testEnv$pkg_limit), - envir = testEnv), - pkgs) - if (!is.na(custom_pkg_list)) { - pkgs <- c( custom_pkg_list[ is.element(custom_pkg_list, - all_avail_packages) ], pkgs ) - } - if (pkg_limit > 0) - pkgs <- pkgs[ 1:pkg_limit ] - pkgs <- pkgs[ !duplicated(pkgs) ] - # Sometimes last value is NA - pkgs <- pkgs[!is.na(pkgs)] - pkgs <- pkgs[!pkgs == "NA"] - - if (scope %in% c("top") && length(pkgs) < pkg_limit ) { - pkgs <- c(known_packages$base, known_packages$recommended, - avail_packages) - pkgs <- pkgs[ !duplicated(pkgs) ] - pkgs <- pkgs[1:pkg_limit] - } - if(length(pkgs)) { - print("Selected packages:") - print(pkgs) - for (pkg in pkgs) { - print(paste0("############ START PACKAGE: ", pkg, " #######")) - tryCatch(run_package_tests(pkg, .Library, outDir), error = function(e) print(e) ) - print(paste0("############ DONE WITH PACKAGE: ", pkg, " #######")) - } - } else { - print("No packages were selected for example/test code extraction") +#' Attempts to run all generated tests to verify that they're actually correct. +#' +#' +validate_tests <- function(capture.dir) { + + cat(sprintf(" Validating tests... ", pkg)) + + test.files <- list.files("R6/captured/base___gsub/", pattern=".+\\.R", full.names = TRUE) + + ok <- sapply(test.files, function(test.file) { + + test.output <- paste0(test.file, ".out") + exitCode <- system2("Rscript", args = test.file, stdout = test.output, stderr = test.output) + if(exitCode != 0) { + file.rename(test.file, paste0(test.file, ".bad")) } - invisible(status) - } + exitCode == 0 + }) + + cat(sprintf("%d/%d OK\n", sum(ok), length(test.files))) +} + + #' get_tests #' @description get the names of all generated test cases @@ -173,44 +101,29 @@ get_tests <- function(capt_dir) } #' generate_test_cases -#' @description generates test cases based on environmental variables +#' +#' Systematically generates test cases for a given base function by running as many package +#' examples and tests as possible to capture inputs and outputs of functions. +#' +#' If the functions argument is missing, then the list of functions is read from the +#' environment variable FUNCTIONS +#' +#' @description generates test cases of base functions using package sources #' @import devtools methods #' @export -generate_test_cases <- function() +generate_test_cases <- function(functions) { - set_function_name(Sys.getenv("function_name")) - set_pkg_name(Sys.getenv("package_name")) - set_job(Sys.getenv("JOB_NAME")) - set_build(Sys.getenv("BUILD_NUMBER")) - set_pkg_limit(Sys.getenv("pkg_limit")) - set_scope(Sys.getenv("scope")) - set_root(getwd()) - if (as.logical(Sys.getenv("install_testr"))) { - if(!require(devtools)){ - install.packages("devtools", dependencies = TRUE, - repos = "http://cloud.r-project.org/") - library(devtools) + # Read from environment if not explicitly provided + if(missing(functions)) { + functions <- strsplit(Sys.getenv("FUNCTIONS"), split="\\s*,\\s*")[[1]] + if(length(functions) == 0) { + stop("No functions provided. Set the FUNCTIONS environment variable with a comma-delimited list of functions") } - install_git("https://github.com/psolaimani/testr.git", branch = "master", - upgrade_dependencies = FALSE) - install_git("https://github.com/bedatadriven/hamcrest.git", - branch = "master", upgrade_dependencies = FALSE) } - set_test_out_dir(paste0(testEnv$root, "/", testEnv$job, "_", testEnv$build)) - dir.create(testEnv$testOutDir, recursive = TRUE) - start_capture( paste(testEnv$pkg_name, "::", testEnv$fname, sep = ""), - verbose = TRUE ) - run_all_tests( - outDir = testEnv$testOutDir, scope = testEnv$scope, - pkg_limit = as.numeric(testEnv$pkg_limit), - custom_pkg_list = testEnv$custom_pkg_list - ) - setwd(testEnv$root) - stop_capture_all() - generate("capture") - set_capt_dir(file.path(testEnv$root,"capture")) - set_arch_dir(file.path(testEnv$root,"tests")) - set_test_dir(file.path(testEnv$root,"capture",paste0(testEnv$pkg_name,"___", - testEnv$fname))) - write_captured_tests("tests") + + packages <- installed.packages()[, 1] + + for(pkg in packages) { + run_package(pkg, functions) + } } diff --git a/R/zzz.R b/R/zzz.R index af5f943..f8c2801 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -111,20 +111,3 @@ testr_options <- function(o, value) options("testr" = res) } } - - -# setup environment -testEnv <- new.env(parent = .GlobalEnv) -testEnv$pkgname <- c() -testEnv$pkg_name <- c() -testEnv$fname <- c() -testEnv$job <- c() -testEnv$build <- c() -testEnv$pkg_limit <- integer() -testEnv$scope <- c() -testEnv$custom_pkg_list <- NA -testEnv$root <- c() # getwd() -testEnv$testOutDir <- c() # paste0(getwd(), "/", testEnv$job, "_", testEnv$build) -testEnv$capt_dir <- c() # file.path(testEnv$root,"capture") -testEnv$arch_dir <- c() # file.path(testEnv$root,"tests") -testEnv$test_dir <- c() # file.path(testEnv$root,"capture",paste0(testEnv$pkg_name,"___", testEnv$fname)) diff --git a/man/find_packages_using_function.Rd b/man/find_packages_using_function.Rd deleted file mode 100644 index 2165402..0000000 --- a/man/find_packages_using_function.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/runTests.R -\name{find_packages_using_function} -\alias{find_packages_using_function} -\title{find_packages_using_function} -\usage{ -find_packages_using_function(functionName, limit = 100) -} -\arguments{ -\item{functionName}{name of the function} - -\item{limit}{max number of packages to use} -} -\description{ -find packages that use the function of interest -} - diff --git a/man/generate_test_cases.Rd b/man/generate_test_cases.Rd index 131dffd..ceeb666 100644 --- a/man/generate_test_cases.Rd +++ b/man/generate_test_cases.Rd @@ -4,9 +4,13 @@ \alias{generate_test_cases} \title{generate_test_cases} \usage{ -generate_test_cases() +generate_test_cases(functions) } \description{ generates test cases based on environmental variables } +\details{ +Systematically generates test cases for a given base function by running as many package +examples and tests as possible to capture inputs and outputs of functions. +} diff --git a/man/remove_failing_tcs.Rd b/man/remove_failing_tcs.Rd deleted file mode 100644 index 14cc5f1..0000000 --- a/man/remove_failing_tcs.Rd +++ /dev/null @@ -1,12 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/runTests.R -\name{remove_failing_tcs} -\alias{remove_failing_tcs} -\title{remove_failing_tcs} -\usage{ -remove_failing_tcs() -} -\description{ -removes the test cases that fail in GNU R -} - diff --git a/man/run_all_tests.Rd b/man/run_all_tests.Rd deleted file mode 100644 index 8b280f2..0000000 --- a/man/run_all_tests.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/runTests.R -\name{run_all_tests} -\alias{run_all_tests} -\title{run_all_tests} -\usage{ -run_all_tests(outDir = ".", errorsAreFatal = FALSE, scope = c("all", - "base", "recommended", "top"), srcdir = NULL, pkg_limit = NULL, - custom_pkg_list = NULL) -} -\arguments{ -\item{outDir}{output dir} - -\item{errorsAreFatal}{should errors break the process} - -\item{scope}{how to prioritize/select packages to run} - -\item{srcdir}{source directory} - -\item{pkg_limit}{maximum number of packages to use for test generation} - -\item{custom_pkg_list}{custom list of packages of interest to use for test generation} -} -\description{ -run all the test/example codes from all the selected packages -} - diff --git a/man/run_package.Rd b/man/run_package.Rd new file mode 100644 index 0000000..2030ebb --- /dev/null +++ b/man/run_package.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runTests.R +\name{run_package} +\alias{run_package} +\title{Runs all available source code from a package in order to generate +usable tests.} +\usage{ +run_package(pkg, flist, output.dir = getwd()) +} +\arguments{ +\item{pkg}{the name of the package (must be installed)} + +\item{flist}{list of functions to instrument for capture} + +\item{output.dir}{directory to write all harnes scripts, tests, and generated content.} +} +\description{ +Runs all available source code from a package in order to generate +usable tests. +} + diff --git a/man/run_package_source.Rd b/man/run_package_source.Rd new file mode 100644 index 0000000..9f75166 --- /dev/null +++ b/man/run_package_source.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runTests.R +\name{run_package_source} +\alias{run_package_source} +\title{Executes a script in an independent R session and stores the output in the +package working directory.} +\usage{ +run_package_source(pkg, flist, source, output.dir) +} +\arguments{ +\item{pkg}{the name of the package (must be installed)} + +\item{flist}{list of functions to intrument} + +\item{output.dir}{the output dir to write capture tests and output} + +\item{source.file}{the full path of the source file to execute} +} +\description{ +Executes a script in an independent R session and stores the output in the +package working directory. +} + diff --git a/man/run_package_tests.Rd b/man/run_package_tests.Rd deleted file mode 100644 index 5bfabf9..0000000 --- a/man/run_package_tests.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/runTests.R -\name{run_package_tests} -\alias{run_package_tests} -\title{runPackageTests} -\usage{ -run_package_tests(pkg, lib.loc = NULL, outDir, verbose = TRUE) -} -\arguments{ -\item{pkg}{name of the packge} - -\item{lib.loc}{library location} - -\item{outDir}{output directory to store extracted code} -} -\description{ -ectract and run example/test codes from package -} - diff --git a/man/validate_tests.Rd b/man/validate_tests.Rd new file mode 100644 index 0000000..623443f --- /dev/null +++ b/man/validate_tests.Rd @@ -0,0 +1,12 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runTests.R +\name{validate_tests} +\alias{validate_tests} +\title{Attempts to run all generated tests to verify that they're actually correct.} +\usage{ +validate_tests(capture.dir) +} +\description{ +Attempts to run all generated tests to verify that they're actually correct. +} + diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 0d9708c..85173f4 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -1,4 +1,4 @@ -// This file was generated by Rcpp::compileAttributes +// Generated by using Rcpp::compileAttributes() -> do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #include "../inst/include/testr.h" @@ -10,7 +10,7 @@ using namespace Rcpp; void WriteCapInfo_cpp(CharacterVector fname, SEXP args_env); RcppExport SEXP testr_WriteCapInfo_cpp(SEXP fnameSEXP, SEXP args_envSEXP) { BEGIN_RCPP - Rcpp::RNGScope __rngScope; + Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< CharacterVector >::type fname(fnameSEXP); Rcpp::traits::input_parameter< SEXP >::type args_env(args_envSEXP); WriteCapInfo_cpp(fname, args_env); From 765c7db67616dc8b68dede079b7dc8ec8641c9e9 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Thu, 12 Jan 2017 14:09:43 +0100 Subject: [PATCH 42/66] Fixed typo in validate_tests() --- R/runTests.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/runTests.R b/R/runTests.R index 8c922ff..8a06bd4 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -67,7 +67,7 @@ run_package_source <- function(pkg, flist, source, output.dir) { #' validate_tests <- function(capture.dir) { - cat(sprintf(" Validating tests... ", pkg)) + cat(sprintf(" Validating tests... ")) test.files <- list.files("R6/captured/base___gsub/", pattern=".+\\.R", full.names = TRUE) From f61a346b2291991c14338558f1355d525f78654e Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Thu, 12 Jan 2017 14:20:18 +0100 Subject: [PATCH 43/66] Fixes for validate_tests() --- R/runTests.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index 8a06bd4..bb93e23 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -69,9 +69,9 @@ validate_tests <- function(capture.dir) { cat(sprintf(" Validating tests... ")) - test.files <- list.files("R6/captured/base___gsub/", pattern=".+\\.R", full.names = TRUE) + test.files <- list.files(capture.dir, pattern=".+\\.R", full.names = TRUE) - ok <- sapply(test.files, function(test.file) { + ok <- vapply(test.files, FUN.VALUE = logical(1), function(test.file) { test.output <- paste0(test.file, ".out") exitCode <- system2("Rscript", args = test.file, stdout = test.output, stderr = test.output) From ffb80be011285c90aaca724ee245c6e98d66173f Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Thu, 12 Jan 2017 14:27:17 +0100 Subject: [PATCH 44/66] Recursively search for tests for validation --- R/runTests.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/runTests.R b/R/runTests.R index bb93e23..f4736e0 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -69,7 +69,7 @@ validate_tests <- function(capture.dir) { cat(sprintf(" Validating tests... ")) - test.files <- list.files(capture.dir, pattern=".+\\.R", full.names = TRUE) + test.files <- list.files(capture.dir, pattern=".+\\.R", full.names = TRUE, recursive = TRUE) ok <- vapply(test.files, FUN.VALUE = logical(1), function(test.file) { From 60456bbe26bd29ecb04bd97f48cb93d973022fb5 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Thu, 12 Jan 2017 15:38:43 +0100 Subject: [PATCH 45/66] Tightened-up R script regex --- R/runTests.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index f4736e0..e4fac80 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -11,8 +11,8 @@ run_package <- function(pkg, flist, output.dir = getwd()) { cat(sprintf("Package %s:\n", pkg)) package.dir <- find.package(pkg) - exScripts <- list.files(file.path(package.dir, "R-ex"), pattern = ".+\\.[RSrs]", full.names = TRUE) - testScripts <- list.files(file.path(package.dir, "tests"), pattern = ".+\\.[RSrs]", full.names = TRUE) + exScripts <- list.files(file.path(package.dir, "R-ex"), pattern = ".+\\.[RSrs]$", full.names = TRUE) + testScripts <- list.files(file.path(package.dir, "tests"), pattern = ".+\\.[RSrs]$", full.names = TRUE) pkg.output.dir <- file.path(output.dir, pkg) From 44a7a3fa114dd4a654c57ef87978c5ebbda551a7 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Thu, 12 Jan 2017 15:47:02 +0100 Subject: [PATCH 46/66] Fixed FUNCTIONS environment variable parsing --- R/runTests.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/runTests.R b/R/runTests.R index e4fac80..5f38c64 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -115,12 +115,15 @@ generate_test_cases <- function(functions) { # Read from environment if not explicitly provided if(missing(functions)) { - functions <- strsplit(Sys.getenv("FUNCTIONS"), split="\\s*,\\s*")[[1]] + functions <- strsplit(Sys.getenv("FUNCTIONS"), split="[\\s,]]+")[[1]] + functions <- functions[ nzchar(functions) > 0 ] if(length(functions) == 0) { stop("No functions provided. Set the FUNCTIONS environment variable with a comma-delimited list of functions") } } + cat(sprintf("function: %s\n", functions)) + packages <- installed.packages()[, 1] for(pkg in packages) { From cea3b8952c89a66423fc14c8d663e55b3fa69123 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Thu, 12 Jan 2017 15:50:19 +0100 Subject: [PATCH 47/66] Fixed FUNCTIONS environment handling --- R/runTests.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/runTests.R b/R/runTests.R index 5f38c64..5acbb5c 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -115,7 +115,7 @@ generate_test_cases <- function(functions) { # Read from environment if not explicitly provided if(missing(functions)) { - functions <- strsplit(Sys.getenv("FUNCTIONS"), split="[\\s,]]+")[[1]] + functions <- strsplit(Sys.getenv("FUNCTIONS"), split="[\\s,]+", perl = TRUE)[[1]] functions <- functions[ nzchar(functions) > 0 ] if(length(functions) == 0) { stop("No functions provided. Set the FUNCTIONS environment variable with a comma-delimited list of functions") From 2be5f3cee9eb3b42430f0c370f09122a4f489613 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Thu, 12 Jan 2017 15:53:01 +0100 Subject: [PATCH 48/66] Fixed handling of bigger list of functions --- R/runTests.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/runTests.R b/R/runTests.R index 5acbb5c..20c3b00 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -44,7 +44,7 @@ run_package_source <- function(pkg, flist, source, output.dir) { "library(testr)", sprintf("library(%s)", pkg), sprintf("setwd('%s')", dirname(source)), - sprintf("start_capture(%s)", deparse(flist)), + sprintf("start_capture(%s)", paste(deparse(flist), collapse="")), sprintf("source('%s', echo = TRUE)", basename(source)), sprintf("generate('%s')", file.path(output.dir, "captured")) ) From 1b9246fab93ebdbfc975c19a8392cc1bae33bda2 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Thu, 12 Jan 2017 16:27:29 +0100 Subject: [PATCH 49/66] Added more status information during validation run --- R/runTests.R | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index 20c3b00..3f054de 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -67,21 +67,27 @@ run_package_source <- function(pkg, flist, source, output.dir) { #' validate_tests <- function(capture.dir) { - cat(sprintf(" Validating tests... ")) + cat(sprintf(" Validating tests...\n")) test.files <- list.files(capture.dir, pattern=".+\\.R", full.names = TRUE, recursive = TRUE) - ok <- vapply(test.files, FUN.VALUE = logical(1), function(test.file) { - + ok <- 0 + total <- 0 + for(test.file in test.files) { test.output <- paste0(test.file, ".out") exitCode <- system2("Rscript", args = test.file, stdout = test.output, stderr = test.output) if(exitCode != 0) { file.rename(test.file, paste0(test.file, ".bad")) + } else { + ok <- ok + 1 + } + total <- total + 1 + if(total %% 500 == 0) { + cat(sprintf(" Validated %d tests so far...\n", total)) } - exitCode == 0 - }) + } - cat(sprintf("%d/%d OK\n", sum(ok), length(test.files))) + cat(sprintf(" Validated %d/%d tests.\n", ok, length(test.files))) } From 7c09b7d3b410f97c11476a65f88955d967d2877e Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Thu, 12 Jan 2017 16:28:22 +0100 Subject: [PATCH 50/66] Improved status output of script running --- R/runTests.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index 3f054de..4cd1861 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -56,9 +56,9 @@ run_package_source <- function(pkg, flist, source, output.dir) { errorCode <- system2(command = "Rscript", args = c(harnessScript), stdout = scriptOutput, stderr = scriptOutput) if(errorCode == 0) { - cat("OK\n") + cat("\n") } else { - cat(sprintf("FAILED: Exited with %d\n", errorCode)) + cat(sprintf("ERROR(%d)\n", errorCode)) } } From 1c2aba832098e207b923ceaecd1e93066d160045 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Sun, 15 Jan 2017 20:34:14 +0100 Subject: [PATCH 51/66] Add timeouts to package examples, tests - Also run package examples via example() so that don't run / don't test is respected. --- R/runTests.R | 51 ++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 44 insertions(+), 7 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index 4cd1861..3185226 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -10,24 +10,61 @@ run_package <- function(pkg, flist, output.dir = getwd()) { cat(sprintf("Package %s:\n", pkg)) - package.dir <- find.package(pkg) - exScripts <- list.files(file.path(package.dir, "R-ex"), pattern = ".+\\.[RSrs]$", full.names = TRUE) - testScripts <- list.files(file.path(package.dir, "tests"), pattern = ".+\\.[RSrs]$", full.names = TRUE) - + # Create a folder for test output, deleting it + # if it already exists pkg.output.dir <- file.path(output.dir, pkg) - if(dir.exists(pkg.output.dir)) { unlink(pkg.output.dir, recursive = TRUE) } dir.create(pkg.output.dir) - for(script in c(exScripts, testScripts)) { + # Run package examples + run_package_examples(pkg, flist, pkg.output.dir) + + # Run test scripts + package.dir <- find.package(pkg) + testScripts <- list.files(file.path(package.dir, "tests"), pattern = ".+\\.[RSrs]$", full.names = TRUE) + + for(script in testScripts) { run_package_source(pkg, flist, script, pkg.output.dir) } validate_tests(file.path(pkg.output.dir, "captured")) } +#' Executes a script in an independent R session and stores the output in the +#' package working directory. +#' +#' @param pkg the name of the package (must be installed) +#' @param source.file the full path of the source file to execute +#' @param flist list of functions to intrument +#' @param output.dir the output dir to write capture tests and output +run_package_examples <- function(pkg, flist, output.dir) { + + cat(sprintf(" Running Examples... ")) + + script <- c( + "library(testr)", + sprintf("library(%s)", pkg), + sprintf("start_capture(%s)", paste(deparse(flist), collapse="")), + sprintf("example(%s)", pkg), + sprintf("generate('%s')", file.path(output.dir, "captured")) + ) + + harnessScript <- file.path(output.dir, "examples.R") + writeLines(script, harnessScript) + + scriptOutput = paste(harnessScript, "out", sep=".") + errorCode <- system2(command = "timeout", args = c("30s", "Rscript", harnessScript), stdout = scriptOutput, stderr = scriptOutput) + + if(errorCode == 0) { + cat("\n") + } else { + cat(sprintf("ERROR(%d)\n", errorCode)) + } +} + + #' Executes a script in an independent R session and stores the output in the #' package working directory. #' @@ -53,7 +90,7 @@ run_package_source <- function(pkg, flist, source, output.dir) { writeLines(script, harnessScript) scriptOutput = paste(harnessScript, "out", sep=".") - errorCode <- system2(command = "Rscript", args = c(harnessScript), stdout = scriptOutput, stderr = scriptOutput) + errorCode <- system2(command = "timeout", args = c("30s", "Rscript", harnessScript), stdout = scriptOutput, stderr = scriptOutput) if(errorCode == 0) { cat("\n") From b708ef66f1c8e830a9bad5d0bcf0f0b9245578ed Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Sun, 15 Jan 2017 21:47:23 +0100 Subject: [PATCH 52/66] Increased timeouts --- R/runTests.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index 3185226..cc29b04 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -55,7 +55,7 @@ run_package_examples <- function(pkg, flist, output.dir) { writeLines(script, harnessScript) scriptOutput = paste(harnessScript, "out", sep=".") - errorCode <- system2(command = "timeout", args = c("30s", "Rscript", harnessScript), stdout = scriptOutput, stderr = scriptOutput) + errorCode <- system2(command = "timeout", args = c("45s", "Rscript", harnessScript), stdout = scriptOutput, stderr = scriptOutput) if(errorCode == 0) { cat("\n") @@ -90,7 +90,7 @@ run_package_source <- function(pkg, flist, source, output.dir) { writeLines(script, harnessScript) scriptOutput = paste(harnessScript, "out", sep=".") - errorCode <- system2(command = "timeout", args = c("30s", "Rscript", harnessScript), stdout = scriptOutput, stderr = scriptOutput) + errorCode <- system2(command = "timeout", args = c("90s", "Rscript", harnessScript), stdout = scriptOutput, stderr = scriptOutput) if(errorCode == 0) { cat("\n") From ad34dc2f9a6ca5ec34f69cb6ff10e16a0bc6b188 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Sun, 15 Jan 2017 22:21:36 +0100 Subject: [PATCH 53/66] Added validation cache For some base packages there is a fair degree of tests generated over and over again that don't need to be validated each time. --- R/runTests.R | 57 +++++++++++++++++++++++++++++++++++----------------- 1 file changed, 39 insertions(+), 18 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index cc29b04..11273b2 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -6,17 +6,17 @@ #' @param pkg the name of the package (must be installed) #' @param flist list of functions to instrument for capture #' @param output.dir directory to write all harnes scripts, tests, and generated content. -run_package <- function(pkg, flist, output.dir = getwd()) { +run_package <- function(pkg, flist, output.dir = getwd(), validation.cache = new.env()) { cat(sprintf("Package %s:\n", pkg)) # Create a folder for test output, deleting it # if it already exists - pkg.output.dir <- file.path(output.dir, pkg) + pkg.output.dir <- file.path(output.dir, "packages", pkg) if(dir.exists(pkg.output.dir)) { unlink(pkg.output.dir, recursive = TRUE) } - dir.create(pkg.output.dir) + dir.create(pkg.output.dir, recursive = TRUE) # Run package examples run_package_examples(pkg, flist, pkg.output.dir) @@ -29,7 +29,9 @@ run_package <- function(pkg, flist, output.dir = getwd()) { run_package_source(pkg, flist, script, pkg.output.dir) } - validate_tests(file.path(pkg.output.dir, "captured")) + validate_tests(capture.dir = file.path(pkg.output.dir, "captured"), + validated.test.dir = file.path(output.dir, "validated"), + cache = validation.cache) } #' Executes a script in an independent R session and stores the output in the @@ -39,7 +41,7 @@ run_package <- function(pkg, flist, output.dir = getwd()) { #' @param source.file the full path of the source file to execute #' @param flist list of functions to intrument #' @param output.dir the output dir to write capture tests and output -run_package_examples <- function(pkg, flist, output.dir) { +run_package_examples <- function(pkg, flist, output.dir, validation.cache) { cat(sprintf(" Running Examples... ")) @@ -55,7 +57,9 @@ run_package_examples <- function(pkg, flist, output.dir) { writeLines(script, harnessScript) scriptOutput = paste(harnessScript, "out", sep=".") - errorCode <- system2(command = "timeout", args = c("45s", "Rscript", harnessScript), stdout = scriptOutput, stderr = scriptOutput) + errorCode <- system2(command = "timeout", args = c("45s", "Rscript", harnessScript), + stdout = scriptOutput, + stderr = scriptOutput) if(errorCode == 0) { cat("\n") @@ -102,29 +106,43 @@ run_package_source <- function(pkg, flist, source, output.dir) { #' Attempts to run all generated tests to verify that they're actually correct. #' #' -validate_tests <- function(capture.dir) { +validate_tests <- function(capture.dir, validated.test.dir, cache = new.env()) { cat(sprintf(" Validating tests...\n")) test.files <- list.files(capture.dir, pattern=".+\\.R", full.names = TRUE, recursive = TRUE) + # Create the validated test dir if doesn't exist + if(!dir.exists(validated.test.dir)) { + dir.create(validated.test.dir) + } + ok <- 0 total <- 0 + cacheHits <- 0 for(test.file in test.files) { - test.output <- paste0(test.file, ".out") - exitCode <- system2("Rscript", args = test.file, stdout = test.output, stderr = test.output) - if(exitCode != 0) { - file.rename(test.file, paste0(test.file, ".bad")) + cacheKey <- basename(test.file) + cached <- cache[[cacheKey]] + if(!is.null(cached)) { + cacheHits <- cacheHits + 1 } else { - ok <- ok + 1 - } - total <- total + 1 - if(total %% 500 == 0) { - cat(sprintf(" Validated %d tests so far...\n", total)) + test.output <- paste0(test.file, ".out") + exitCode <- system2("Rscript", args = test.file, stdout = test.output, stderr = test.output) + if(exitCode != 0) { + cache[[cacheKey]] <- FALSE + } else { + cache[[cacheKey]] <- TRUE + file.copy(test.file, file.path(validated.test.dir, basename(test.file))) + ok <- ok + 1 + } + total <- total + 1 + if(total %% 500 == 0) { + cat(sprintf(" Validated %d tests so far...\n", total)) + } } } - cat(sprintf(" Validated %d/%d tests.\n", ok, length(test.files))) + cat(sprintf(" Validated %d/%d new tests, %d cached.\n", ok, (length(test.files)-cacheHits), cacheHits)) } @@ -169,7 +187,10 @@ generate_test_cases <- function(functions) packages <- installed.packages()[, 1] + # Set up validation cache and output dir + validation.cache <- new.env(hash = TRUE) + for(pkg in packages) { - run_package(pkg, functions) + run_package(pkg, functions, validation.cache = validation.cache) } } From d2724c992d8b7520710397ae704485bb473a4f4f Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Sun, 15 Jan 2017 23:34:44 +0100 Subject: [PATCH 54/66] Set seperate capture.folder for each package Otherwise failed tests/examples can lead to corrupted capture files that never get removed. --- R/runTests.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/runTests.R b/R/runTests.R index 11273b2..eb5803a 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -48,6 +48,8 @@ run_package_examples <- function(pkg, flist, output.dir, validation.cache) { script <- c( "library(testr)", sprintf("library(%s)", pkg), + sprintf("setwd('%s')", output.dir), + sprintf("testr_options('capture.folder', '%s')", file.path(output.dir, "example_capture")), sprintf("start_capture(%s)", paste(deparse(flist), collapse="")), sprintf("example(%s)", pkg), sprintf("generate('%s')", file.path(output.dir, "captured")) @@ -85,6 +87,7 @@ run_package_source <- function(pkg, flist, source, output.dir) { "library(testr)", sprintf("library(%s)", pkg), sprintf("setwd('%s')", dirname(source)), + sprintf("testr_options('capture.folder', '%s')", file.path(output.dir, "test_capture")), sprintf("start_capture(%s)", paste(deparse(flist), collapse="")), sprintf("source('%s', echo = TRUE)", basename(source)), sprintf("generate('%s')", file.path(output.dir, "captured")) From 4e0ba4a86309c9802b6e8d627d1a7f2976db1b52 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Sun, 15 Jan 2017 23:43:05 +0100 Subject: [PATCH 55/66] Reverted attempt to set capture directory Does not seem to be working. Will just set the current directory when running examples --- R/generate.R | 7 +++++++ R/runTests.R | 2 -- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/R/generate.R b/R/generate.R index 978fef0..81bd313 100644 --- a/R/generate.R +++ b/R/generate.R @@ -156,6 +156,13 @@ read_value <- function(lines, prefix) #' @seealso test_gen ProcessClosure generate_tc <- function(symb, vsym, func, argv) { + # Fixup specials + if(func == "base::[") { + func <- "`[`" + } else if(func == "base::[[") { + func <- "`[[`" + } + # check validity of symbol values and construct part of the test invalid.symbols <- vector() variables <- "" diff --git a/R/runTests.R b/R/runTests.R index eb5803a..68273bd 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -49,7 +49,6 @@ run_package_examples <- function(pkg, flist, output.dir, validation.cache) { "library(testr)", sprintf("library(%s)", pkg), sprintf("setwd('%s')", output.dir), - sprintf("testr_options('capture.folder', '%s')", file.path(output.dir, "example_capture")), sprintf("start_capture(%s)", paste(deparse(flist), collapse="")), sprintf("example(%s)", pkg), sprintf("generate('%s')", file.path(output.dir, "captured")) @@ -87,7 +86,6 @@ run_package_source <- function(pkg, flist, source, output.dir) { "library(testr)", sprintf("library(%s)", pkg), sprintf("setwd('%s')", dirname(source)), - sprintf("testr_options('capture.folder', '%s')", file.path(output.dir, "test_capture")), sprintf("start_capture(%s)", paste(deparse(flist), collapse="")), sprintf("source('%s', echo = TRUE)", basename(source)), sprintf("generate('%s')", file.path(output.dir, "captured")) From 789a14d0ee8491e22f95be5dfdc356252c19a055 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Mon, 16 Jan 2017 12:17:08 +0100 Subject: [PATCH 56/66] Added size limit and timeout for test validation --- R/runTests.R | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index 68273bd..92c4ad7 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -127,12 +127,20 @@ validate_tests <- function(capture.dir, validated.test.dir, cache = new.env()) { if(!is.null(cached)) { cacheHits <- cacheHits + 1 } else { - test.output <- paste0(test.file, ".out") - exitCode <- system2("Rscript", args = test.file, stdout = test.output, stderr = test.output) - if(exitCode != 0) { - cache[[cacheKey]] <- FALSE + + if(file.size(test.file) > (1024 * 10)) { + valid <- FALSE } else { - cache[[cacheKey]] <- TRUE + test.output <- paste0(test.file, ".out") + exitCode <- system2("timeout", args = c("2s", "Rscript", test.file), + stdout = test.output, + stderr = test.output) + + valid <- (exitCode == 0) + } + cache[[cacheKey]] <- valid + + if(valid) { file.copy(test.file, file.path(validated.test.dir, basename(test.file))) ok <- ok + 1 } From 9a5498297ac6c448273b40437f4778f2124cf044 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Tue, 17 Jan 2017 09:03:04 +0100 Subject: [PATCH 57/66] Ensure even throughly hung scripts are eventually killed The linux timeout tool will only send a TERM signal by default. Adding the --kill-after flag will ensure that the script is sent the KILL signal if it fails to exit cleanly. --- R/runTests.R | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index 92c4ad7..dffd8a2 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -58,9 +58,7 @@ run_package_examples <- function(pkg, flist, output.dir, validation.cache) { writeLines(script, harnessScript) scriptOutput = paste(harnessScript, "out", sep=".") - errorCode <- system2(command = "timeout", args = c("45s", "Rscript", harnessScript), - stdout = scriptOutput, - stderr = scriptOutput) + errorCode <- run_script_with_timeout(harnessScript, scriptOutput) if(errorCode == 0) { cat("\n") @@ -95,7 +93,7 @@ run_package_source <- function(pkg, flist, source, output.dir) { writeLines(script, harnessScript) scriptOutput = paste(harnessScript, "out", sep=".") - errorCode <- system2(command = "timeout", args = c("90s", "Rscript", harnessScript), stdout = scriptOutput, stderr = scriptOutput) + errorCode <- run_script_with_timeout(harnessScript, scriptOutput) if(errorCode == 0) { cat("\n") @@ -104,6 +102,17 @@ run_package_source <- function(pkg, flist, source, output.dir) { } } +#' Spawns a new VM to run the given script and write the output to the given file. +#' +#' If the script does not complete within 90 seconds, it is sent the the TERM signal. +#' If the process does not exit within 5 seconds, it is sent the KILL signal. +run_script_with_timeout <- function(script.file, output.file) { + system2(command = "timeout", + args = c("--kill-after=5s", "90s", "Rscript", script.file), + stdout = output.file, + stderr = output.file) +} + #' Attempts to run all generated tests to verify that they're actually correct. #' #' From 1f6ec3aeb55059951acd466326c1457ae4370a94 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Tue, 17 Jan 2017 09:11:58 +0100 Subject: [PATCH 58/66] Skip existing package dirs to allow resuming an aborted job --- R/runTests.R | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index dffd8a2..5aea94f 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -6,7 +6,7 @@ #' @param pkg the name of the package (must be installed) #' @param flist list of functions to instrument for capture #' @param output.dir directory to write all harnes scripts, tests, and generated content. -run_package <- function(pkg, flist, output.dir = getwd(), validation.cache = new.env()) { +run_package <- function(pkg, flist, output.dir = getwd(), validation.cache = new.env(), skip.existing = TRUE) { cat(sprintf("Package %s:\n", pkg)) @@ -14,7 +14,12 @@ run_package <- function(pkg, flist, output.dir = getwd(), validation.cache = new # if it already exists pkg.output.dir <- file.path(output.dir, "packages", pkg) if(dir.exists(pkg.output.dir)) { - unlink(pkg.output.dir, recursive = TRUE) + if(skip.existing) { + cat(sprintf(" Already done, skipping.\n")) + return(NULL) + } else { + unlink(pkg.output.dir, recursive = TRUE) + } } dir.create(pkg.output.dir, recursive = TRUE) @@ -76,8 +81,6 @@ run_package_examples <- function(pkg, flist, output.dir, validation.cache) { #' @param flist list of functions to intrument #' @param output.dir the output dir to write capture tests and output run_package_source <- function(pkg, flist, source, output.dir) { - - cat(sprintf(" Running %s... ", basename(source))) script <- c( From 50b26b6100e962ae0b368efb70d668507ce76e81 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Tue, 17 Jan 2017 16:16:05 +0100 Subject: [PATCH 59/66] Extended limit for captured arguments to 10k --- src/WriteCapInfo.cpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/WriteCapInfo.cpp b/src/WriteCapInfo.cpp index bbbc44f..321ee72 100644 --- a/src/WriteCapInfo.cpp +++ b/src/WriteCapInfo.cpp @@ -16,7 +16,7 @@ std::ofstream tracefile; void printCapture(CharacterVector x, std::string prefix) { if (x[0] != "NULL"){ - if (x.length() < 1000) { + if (x.length() < 10000) { for (int i = 0; i < x.length(); i++) { tracefile << prefix << x[i] << std::endl; } From d9baf6750d229a18639e16f32ec10284ffcd97f3 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Tue, 17 Jan 2017 16:16:17 +0100 Subject: [PATCH 60/66] Fixed bug in argument capture routine. --- src/GetArgs.cpp | 42 +++++++++++++++++++++++------------------- 1 file changed, 23 insertions(+), 19 deletions(-) diff --git a/src/GetArgs.cpp b/src/GetArgs.cpp index d848a17..71b747c 100644 --- a/src/GetArgs.cpp +++ b/src/GetArgs.cpp @@ -13,29 +13,33 @@ SEXP GetArgs(SEXP dotsE){ for( int i=0; i(envNames[i]); -// Rcout << "name - " << name << endl; SEXP nameSym = Rf_install(name.c_str()); unevaluatedArg = Rf_findVar(nameSym, dotsE); if (missing(nameSym, dotsE)) { continue; } - -// args[name] = R_forcePromise(unevaluatedArg); - if (unevaluatedArg != R_UnboundValue && TYPEOF(unevaluatedArg) == PROMSXP) { - SEXP prcode = PRCODE(unevaluatedArg); - if (!Rf_isNull(PRENV(unevaluatedArg))){ - evalEnv = PRENV(unevaluatedArg); - } else { - evalEnv = dotsE; - } - int err = 0; - SEXP res = R_tryEvalSilent(unevaluatedArg, evalEnv, &err); - if(err){ - evaluatedArg = prcode; - } else { - evaluatedArg = res; - } - args[name] = evaluatedArg; + + if (unevaluatedArg != R_UnboundValue) { + if(TYPEOF(unevaluatedArg) == PROMSXP) { + SEXP prcode = PRCODE(unevaluatedArg); + if (!Rf_isNull(PRENV(unevaluatedArg))){ + evalEnv = PRENV(unevaluatedArg); + } else { + evalEnv = dotsE; + } + int err = 0; + SEXP res = R_tryEvalSilent(unevaluatedArg, evalEnv, &err); + if(err){ + evaluatedArg = prcode; + } else { + evaluatedArg = res; + } + args[name] = evaluatedArg; + } else { + // Non promises such as vectors or other constants + // are already evaluated. + args[name] = unevaluatedArg; + } } } nArgs--; @@ -43,7 +47,7 @@ SEXP GetArgs(SEXP dotsE){ SEXP dots = dotsEnv.get("..."); vector promises; int dArgs = 0; - if( dots != R_MissingArg ){ + if( dots != R_MissingArg ){ while(dots != R_NilValue){ promises.push_back(CAR(dots)) ; dots = CDR(dots); From f7f1b938d0de495b7b36cc4088b04e0b52da397c Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Tue, 17 Jan 2017 16:17:26 +0100 Subject: [PATCH 61/66] Increased total test case limit length to 20k --- R/runTests.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/runTests.R b/R/runTests.R index 5aea94f..818d38a 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -140,7 +140,7 @@ validate_tests <- function(capture.dir, validated.test.dir, cache = new.env()) { cacheHits <- cacheHits + 1 } else { - if(file.size(test.file) > (1024 * 10)) { + if(file.size(test.file) > (1024 * 20)) { valid <- FALSE } else { test.output <- paste0(test.file, ".out") From af8b127eaf80275f7e56beb6176aafd8fe3c3627 Mon Sep 17 00:00:00 2001 From: Alex Bertram Date: Wed, 29 Mar 2017 21:36:57 +0200 Subject: [PATCH 62/66] Deparse function inputs with hex doubles as well as expected --- R/generate.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/generate.R b/R/generate.R index 81bd313..3424bf4 100644 --- a/R/generate.R +++ b/R/generate.R @@ -191,11 +191,12 @@ generate_tc <- function(symb, vsym, func, argv) # TODO: potentially good arguments, alter it # argv.obj.lst <- alter.arguments(argv.obj); + deparsec <- c("hexNumeric", "showAttributes", "keepInteger") call <- "" args <- eval(parse(text=argv)); if (length(args) > 0) { - args <- lapply(args, function(x) paste(deparse(x), collapse = "\n")) + args <- lapply(args, function(x) paste(deparse(x, control = deparsec), collapse = "\n")) if (!is.null(names(args)) && length(names(args)) == length(args)) { call.args <- "" arg_names <- names(args) @@ -230,7 +231,7 @@ generate_tc <- function(symb, vsym, func, argv) # testhat formatter src <- "" if (is.null(cache$errs) && is.null(cache$warns)) { - src <- paste(src, "expected <-", paste(deparse(retv, control = c("hexNumeric", "showAttributes", "keepInteger")), collapse = "\n"), "\n") + src <- paste(src, "expected <-", paste(deparse(retv, control = deparsec), collapse = "\n"), "\n") call <- paste("\n\nassertThat(", call, ", identicalTo( expected, tol = 1e-6 ) )", sep = "") } From 6cdb396cda6a1b70137efb8c1947af316c00c247 Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Thu, 31 Aug 2017 11:10:51 +0200 Subject: [PATCH 63/66] in generate_test_cases add extra arg to limit the number of packages --- R/runTests.R | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/R/runTests.R b/R/runTests.R index 818d38a..fe48061 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -192,8 +192,12 @@ get_tests <- function(capt_dir) #' #' @description generates test cases of base functions using package sources #' @import devtools methods +#' @param functions Comma delimited names of functions to be decorated for test generation. +#' Provided as string vector or through environment variable FUNCTIONS. +#' @param limit max number of packages to be runned for test case generation. Provided as +#' integer or through environment variable MAX_PACKAGES_TO_RUN. #' @export -generate_test_cases <- function(functions) +generate_test_cases <- function(functions, limit) { # Read from environment if not explicitly provided if(missing(functions)) { @@ -203,10 +207,21 @@ generate_test_cases <- function(functions) stop("No functions provided. Set the FUNCTIONS environment variable with a comma-delimited list of functions") } } + if(missing(limit)) { + limit <- strsplit(Sys.getenv("MAX_PACKAGES_TO_RUN"), split="[\\s,]+", perl = TRUE)[[1]] + limit <- limit[ nzchar(limit) > 0 ] + if(length(limit) == 0) { + limit = 0 + } else { + limit = as.integer(limit[1]) + } + } cat(sprintf("function: %s\n", functions)) + if(limit) cat(sprintf("Number of packages to use: %s\n", limit)) packages <- installed.packages()[, 1] + if(limit) packages <- packages[1:limit] # Set up validation cache and output dir validation.cache <- new.env(hash = TRUE) From 51687536b80b1f4e246a2229e1857943b1f53cc1 Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Thu, 31 Aug 2017 11:54:50 +0200 Subject: [PATCH 64/66] add generate_test_cases_using() to use provided list of packages --- R/runTests.R | 41 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 40 insertions(+), 1 deletion(-) diff --git a/R/runTests.R b/R/runTests.R index fe48061..a43bd11 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -185,7 +185,9 @@ get_tests <- function(capt_dir) #' generate_test_cases #' #' Systematically generates test cases for a given base function by running as many package -#' examples and tests as possible to capture inputs and outputs of functions. +#' examples and tests as possible to capture inputs and outputs of functions. Or limited +#' number of packages are used, if a 'limit' argument or 'MAX_PACKAGES_TO_RUN' environment +#' variable is provided, #' #' If the functions argument is missing, then the list of functions is read from the #' environment variable FUNCTIONS @@ -230,3 +232,40 @@ generate_test_cases <- function(functions, limit) run_package(pkg, functions, validation.cache = validation.cache) } } + +#' generate_test_cases_using +#' +#' @description Generates test cases using the provided packages +#' @import devtools methods +#' @param functions list of functions to annotate for test case generation +#' @param packages list of packages to be used for test case generation +#' @export +generate_test_cases_using <- function(functions, packages) +{ + # Read from environment if not explicitly provided + if(missing(functions)) { + functions <- strsplit(Sys.getenv("FUNCTIONS"), split="[\\s,]+", perl = TRUE)[[1]] + functions <- functions[ nzchar(functions) > 0 ] + if(length(functions) == 0) { + stop("No functions provided. Set the FUNCTIONS environment variable with a comma-delimited list of functions") + } + } + if(missing(packages)) { + packages <- strsplit(Sys.getenv("USE_PACKAGES"), split="[\\s,]+", perl = TRUE)[[1]] + packages <- packages[ nzchar(limit) > 0 ] + if(length(packages) == 0) { + stop("No packages provided. Set the USE_PACKAGES environment variable with a comma-delimited list of package names") + } + } + + cat(sprintf("function(s): %s\n", functions)) + cat(sprintf("packages(s): %s\n", limit)) + + # Set up validation cache and output dir + validation.cache <- new.env(hash = TRUE) + + for(pkg in packages) { + run_package(pkg, functions, validation.cache = validation.cache) + } +} + From ecb36908d8a18e644b8e81f0cdbbd202b5161bfe Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Thu, 31 Aug 2017 11:56:37 +0200 Subject: [PATCH 65/66] update documentation and namespace --- DESCRIPTION | 2 +- NAMESPACE | 1 + man/clean_temp.Rd | 1 - man/clear_decoration.Rd | 1 - man/decorate.Rd | 1 - man/eligible_capture.Rd | 1 - man/ensure_file.Rd | 1 - man/extract_func_name.Rd | 1 - man/filter_tests.Rd | 1 - man/find_tests.Rd | 1 - man/gen_from_code.Rd | 1 - man/gen_from_function.Rd | 1 - man/gen_from_package.Rd | 1 - man/gen_from_source.Rd | 1 - man/generate.Rd | 1 - man/generate_tc.Rd | 1 - man/generate_test_cases.Rd | 19 +++++++++++++++---- man/generate_test_cases_using.Rd | 16 ++++++++++++++++ man/get_tests.Rd | 1 - man/is_s3_generic.Rd | 1 - man/list_functions.Rd | 1 - man/parseFunctionNames.Rd | 1 - man/parse_eval.Rd | 1 - man/process_capture.Rd | 1 - man/prune.Rd | 1 - man/quoter.Rd | 1 - man/reassing_in_env.Rd | 1 - man/refresh_decoration.Rd | 1 - man/run_package.Rd | 4 ++-- man/run_package_examples.Rd | 22 ++++++++++++++++++++++ man/run_package_source.Rd | 1 - man/run_script_with_timeout.Rd | 12 ++++++++++++ man/setup_capture.Rd | 1 - man/start_capture.Rd | 1 - man/start_capture_builtins.Rd | 1 - man/starts_with.Rd | 1 - man/stop_capture.Rd | 1 - man/stop_capture_all.Rd | 1 - man/substr_line.Rd | 1 - man/test_gen.Rd | 1 - man/testr_options.Rd | 1 - man/undecorate.Rd | 1 - man/validate_tests.Rd | 3 +-- man/write_capture.Rd | 1 - man/write_captured_tests.Rd | 1 - src/RcppExports.cpp | 10 ++++++++++ 46 files changed, 80 insertions(+), 46 deletions(-) create mode 100644 man/generate_test_cases_using.Rd create mode 100644 man/run_package_examples.Rd create mode 100644 man/run_script_with_timeout.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 31083f1..c653393 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -22,5 +22,5 @@ Suggests: rmarkdown, roxygen2 LazyData: TRUE -RoxygenNote: 5.0.1 +RoxygenNote: 6.0.1 VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index 3747ca2..a26a0c9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,6 +7,7 @@ export(gen_from_package) export(gen_from_source) export(generate) export(generate_test_cases) +export(generate_test_cases_using) export(get_tests) export(prune) export(setup_capture) diff --git a/man/clean_temp.Rd b/man/clean_temp.Rd index e19c825..8a34570 100644 --- a/man/clean_temp.Rd +++ b/man/clean_temp.Rd @@ -9,4 +9,3 @@ clean_temp() \description{ Make sure temp dir is empty by deleting unnecessary files } - diff --git a/man/clear_decoration.Rd b/man/clear_decoration.Rd index d7b9496..5a92308 100644 --- a/man/clear_decoration.Rd +++ b/man/clear_decoration.Rd @@ -15,4 +15,3 @@ Clear anything previously decorate \seealso{ undecorate } - diff --git a/man/decorate.Rd b/man/decorate.Rd index 4532f49..5862ad3 100644 --- a/man/decorate.Rd +++ b/man/decorate.Rd @@ -20,4 +20,3 @@ Replaces the function by decorated function in the global environment \seealso{ write_capture } - diff --git a/man/eligible_capture.Rd b/man/eligible_capture.Rd index f6d279e..3d02801 100644 --- a/man/eligible_capture.Rd +++ b/man/eligible_capture.Rd @@ -19,4 +19,3 @@ This is an internal function and is supposed to be used in setup_capture \seealso{ setup_capture } - diff --git a/man/ensure_file.Rd b/man/ensure_file.Rd index 9294590..912d345 100644 --- a/man/ensure_file.Rd +++ b/man/ensure_file.Rd @@ -17,4 +17,3 @@ This function creates a test case file if one does not exist already \seealso{ test_gen } - diff --git a/man/extract_func_name.Rd b/man/extract_func_name.Rd index c9ca888..540a3bf 100644 --- a/man/extract_func_name.Rd +++ b/man/extract_func_name.Rd @@ -14,4 +14,3 @@ extract_func_name(filename, modify.characters = TRUE) \description{ This function is respinsible for extractng function name from test file name and removing special characters } - diff --git a/man/filter_tests.Rd b/man/filter_tests.Rd index 30ef745..88856ff 100644 --- a/man/filter_tests.Rd +++ b/man/filter_tests.Rd @@ -29,4 +29,3 @@ filter_tests(tc_root, tc_result_root, functions, package_path, This function attemps to filter the test cases for given functions based on code coverage information collected by covr. } - diff --git a/man/find_tests.Rd b/man/find_tests.Rd index 5fdb3d3..891e0f1 100644 --- a/man/find_tests.Rd +++ b/man/find_tests.Rd @@ -15,4 +15,3 @@ Find a known test location for the package \seealso{ CapturePackage } - diff --git a/man/gen_from_code.Rd b/man/gen_from_code.Rd index 45d9b3b..5d7a69c 100644 --- a/man/gen_from_code.Rd +++ b/man/gen_from_code.Rd @@ -16,4 +16,3 @@ gen_from_code(code, output_dir, ...) \description{ Generates tests from given code and specific captured functions } - diff --git a/man/gen_from_function.Rd b/man/gen_from_function.Rd index 797be62..51561cd 100644 --- a/man/gen_from_function.Rd +++ b/man/gen_from_function.Rd @@ -30,4 +30,3 @@ gen_from_function(package.dir = ".", code, functions, filter = TRUE, \description{ Given a package, the code to be executed and a list of functions to capture, the function captures the selected functions from the package, then runs the specified code. It then generates tests from the captured information and using code coverage filters them against existing tests for the package. Those that increase the code coverage will be added to already existing testthat tests for the package. } - diff --git a/man/gen_from_package.Rd b/man/gen_from_package.Rd index 9ded14b..f9b9add 100644 --- a/man/gen_from_package.Rd +++ b/man/gen_from_package.Rd @@ -25,4 +25,3 @@ gen_from_package(package.dir = ".", include.tests = FALSE, timed = FALSE, \description{ Runs the examples, vignettes and possibly tests associated with the package and captures the usage of package's functions. Creates tests from the captured information, filters it according to the already existing tests and if any new tests are found, adds them to package's tests. } - diff --git a/man/gen_from_source.Rd b/man/gen_from_source.Rd index 75806af..71aa9c8 100644 --- a/man/gen_from_source.Rd +++ b/man/gen_from_source.Rd @@ -16,4 +16,3 @@ gen_from_source(src.root, output_dir, ...) \description{ Generates tests by running given source file. } - diff --git a/man/generate.Rd b/man/generate.Rd index 3d99044..68ae6c7 100644 --- a/man/generate.Rd +++ b/man/generate.Rd @@ -22,4 +22,3 @@ generate(output_dir, root = testr_options("capture.folder"), timed = FALSE, This function takes the tracing information collected by capture and generates testthat compatible testcases. } - diff --git a/man/generate_tc.Rd b/man/generate_tc.Rd index 99f9c7f..d15bb38 100644 --- a/man/generate_tc.Rd +++ b/man/generate_tc.Rd @@ -21,4 +21,3 @@ This function generates a test case for builtin function using supplied argument \seealso{ test_gen ProcessClosure } - diff --git a/man/generate_test_cases.Rd b/man/generate_test_cases.Rd index ceeb666..6098da9 100644 --- a/man/generate_test_cases.Rd +++ b/man/generate_test_cases.Rd @@ -4,13 +4,24 @@ \alias{generate_test_cases} \title{generate_test_cases} \usage{ -generate_test_cases(functions) +generate_test_cases(functions, limit) +} +\arguments{ +\item{functions}{Comma delimited names of functions to be decorated for test generation. +Provided as string vector or through environment variable FUNCTIONS.} + +\item{limit}{max number of packages to be runned for test case generation. Provided as +integer or through environment variable MAX_PACKAGES_TO_RUN.} } \description{ -generates test cases based on environmental variables +generates test cases of base functions using package sources } \details{ Systematically generates test cases for a given base function by running as many package -examples and tests as possible to capture inputs and outputs of functions. -} +examples and tests as possible to capture inputs and outputs of functions. Or limited +number of packages are used, if a 'limit' argument or 'MAX_PACKAGES_TO_RUN' environment +variable is provided, +If the functions argument is missing, then the list of functions is read from the +environment variable FUNCTIONS +} diff --git a/man/generate_test_cases_using.Rd b/man/generate_test_cases_using.Rd new file mode 100644 index 0000000..6ddd592 --- /dev/null +++ b/man/generate_test_cases_using.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runTests.R +\name{generate_test_cases_using} +\alias{generate_test_cases_using} +\title{generate_test_cases_using} +\usage{ +generate_test_cases_using(functions, packages) +} +\arguments{ +\item{functions}{list of functions to annotate for test case generation} + +\item{packages}{list of packages to be used for test case generation} +} +\description{ +Generates test cases using the provided packages +} diff --git a/man/get_tests.Rd b/man/get_tests.Rd index c8f6f9f..f82b6d2 100644 --- a/man/get_tests.Rd +++ b/man/get_tests.Rd @@ -12,4 +12,3 @@ get_tests(capt_dir) \description{ get the names of all generated test cases } - diff --git a/man/is_s3_generic.Rd b/man/is_s3_generic.Rd index 28eddae..a7f2f5e 100644 --- a/man/is_s3_generic.Rd +++ b/man/is_s3_generic.Rd @@ -17,4 +17,3 @@ Determine if function has a call to UseMethod. In that case there is no need to \seealso{ Decorate } - diff --git a/man/list_functions.Rd b/man/list_functions.Rd index 1d0db86..56b389e 100644 --- a/man/list_functions.Rd +++ b/man/list_functions.Rd @@ -18,4 +18,3 @@ Character vector of function names defined in the file. Analyses given file, or files if directory is supplied for all functions defined in global scope and returns their names as character vector. } - diff --git a/man/parseFunctionNames.Rd b/man/parseFunctionNames.Rd index 7374aaa..94d7e62 100644 --- a/man/parseFunctionNames.Rd +++ b/man/parseFunctionNames.Rd @@ -16,4 +16,3 @@ List of parsed package and function names as characters. Parses given function names to a list of name, package characters. If package is not specified, NA is returned instead of its name. } - diff --git a/man/parse_eval.Rd b/man/parse_eval.Rd index 54bcab7..9e8c05b 100644 --- a/man/parse_eval.Rd +++ b/man/parse_eval.Rd @@ -12,4 +12,3 @@ parse_eval(what) \description{ Function that wraps parse(eval(...)) call with tryCatch } - diff --git a/man/process_capture.Rd b/man/process_capture.Rd index 1e30246..75accad 100644 --- a/man/process_capture.Rd +++ b/man/process_capture.Rd @@ -12,4 +12,3 @@ process_capture(cap_file) \description{ This function parses file with closure capture information and generates test cases } - diff --git a/man/prune.Rd b/man/prune.Rd index b70e430..caae788 100644 --- a/man/prune.Rd +++ b/man/prune.Rd @@ -29,4 +29,3 @@ This function attempts to filter test cases based on code coverage collected by Filtering is done in iterational way by measuring code coverage of every test separately and skipping the ones that don't increase the coverage. } - diff --git a/man/quoter.Rd b/man/quoter.Rd index 7b1403f..d5e1774 100644 --- a/man/quoter.Rd +++ b/man/quoter.Rd @@ -12,4 +12,3 @@ quoter(arg) \description{ In certain cases, language arguments (like calls), need to be quoated } - diff --git a/man/reassing_in_env.Rd b/man/reassing_in_env.Rd index ed62b0c..423ad0f 100644 --- a/man/reassing_in_env.Rd +++ b/man/reassing_in_env.Rd @@ -17,4 +17,3 @@ reassing_in_env(name, obj, env) Record that particual line was executed. Used in statement coverage, needed for namespace replacement } - diff --git a/man/refresh_decoration.Rd b/man/refresh_decoration.Rd index 9f2f590..5c4c17c 100644 --- a/man/refresh_decoration.Rd +++ b/man/refresh_decoration.Rd @@ -15,4 +15,3 @@ by a package that is being loaded, the package won't get the correct copy, which the information loss. This function is hooked up to the library, to be run upon exist and check what functions might need redecoration, to propagate correct version to imports namespace. } - diff --git a/man/run_package.Rd b/man/run_package.Rd index 2030ebb..e536479 100644 --- a/man/run_package.Rd +++ b/man/run_package.Rd @@ -5,7 +5,8 @@ \title{Runs all available source code from a package in order to generate usable tests.} \usage{ -run_package(pkg, flist, output.dir = getwd()) +run_package(pkg, flist, output.dir = getwd(), validation.cache = new.env(), + skip.existing = TRUE) } \arguments{ \item{pkg}{the name of the package (must be installed)} @@ -18,4 +19,3 @@ run_package(pkg, flist, output.dir = getwd()) Runs all available source code from a package in order to generate usable tests. } - diff --git a/man/run_package_examples.Rd b/man/run_package_examples.Rd new file mode 100644 index 0000000..599efc5 --- /dev/null +++ b/man/run_package_examples.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runTests.R +\name{run_package_examples} +\alias{run_package_examples} +\title{Executes a script in an independent R session and stores the output in the +package working directory.} +\usage{ +run_package_examples(pkg, flist, output.dir, validation.cache) +} +\arguments{ +\item{pkg}{the name of the package (must be installed)} + +\item{flist}{list of functions to intrument} + +\item{output.dir}{the output dir to write capture tests and output} + +\item{source.file}{the full path of the source file to execute} +} +\description{ +Executes a script in an independent R session and stores the output in the +package working directory. +} diff --git a/man/run_package_source.Rd b/man/run_package_source.Rd index 9f75166..1414ad4 100644 --- a/man/run_package_source.Rd +++ b/man/run_package_source.Rd @@ -20,4 +20,3 @@ run_package_source(pkg, flist, source, output.dir) Executes a script in an independent R session and stores the output in the package working directory. } - diff --git a/man/run_script_with_timeout.Rd b/man/run_script_with_timeout.Rd new file mode 100644 index 0000000..ede782f --- /dev/null +++ b/man/run_script_with_timeout.Rd @@ -0,0 +1,12 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runTests.R +\name{run_script_with_timeout} +\alias{run_script_with_timeout} +\title{Spawns a new VM to run the given script and write the output to the given file.} +\usage{ +run_script_with_timeout(script.file, output.file) +} +\description{ +If the script does not complete within 90 seconds, it is sent the the TERM signal. +If the process does not exit within 5 seconds, it is sent the KILL signal. +} diff --git a/man/setup_capture.Rd b/man/setup_capture.Rd index c169e58..6e3ac96 100644 --- a/man/setup_capture.Rd +++ b/man/setup_capture.Rd @@ -19,4 +19,3 @@ This function is respinsible for setting up capturing for functions \seealso{ Decorate } - diff --git a/man/start_capture.Rd b/man/start_capture.Rd index 4644f53..e804720 100644 --- a/man/start_capture.Rd +++ b/man/start_capture.Rd @@ -15,4 +15,3 @@ start_capture(..., verbose = testr_options("verbose")) The functions can be expressed as character literals in the form of either only a function name, or package name ::: function name, or directly as a symbol (i.e. only function name, or package name ::: function name). } - diff --git a/man/start_capture_builtins.Rd b/man/start_capture_builtins.Rd index 3250d26..b18e84c 100644 --- a/man/start_capture_builtins.Rd +++ b/man/start_capture_builtins.Rd @@ -15,4 +15,3 @@ start_capture_builtins(internal.only = FALSE, \description{ Wrapper around capture to capture builtin functions } - diff --git a/man/starts_with.Rd b/man/starts_with.Rd index ccaf236..f63967a 100644 --- a/man/starts_with.Rd +++ b/man/starts_with.Rd @@ -17,4 +17,3 @@ Check if line starts with prefix \seealso{ GenerateTC } - diff --git a/man/stop_capture.Rd b/man/stop_capture.Rd index 27fa8ec..a52a0e0 100644 --- a/man/stop_capture.Rd +++ b/man/stop_capture.Rd @@ -14,4 +14,3 @@ stop_capture(..., verbose = testr_options("verbose")) \description{ This function removes the tracing functionality for specified function } - diff --git a/man/stop_capture_all.Rd b/man/stop_capture_all.Rd index 7f8b6e1..fe499d2 100644 --- a/man/stop_capture_all.Rd +++ b/man/stop_capture_all.Rd @@ -12,4 +12,3 @@ stop_capture_all(verbose = testr_options("verbose")) \description{ Remove tracing functionality for all the functions } - diff --git a/man/substr_line.Rd b/man/substr_line.Rd index 2377b76..85c1d2a 100644 --- a/man/substr_line.Rd +++ b/man/substr_line.Rd @@ -15,4 +15,3 @@ Used for processing capture file information. Deletes prefixes to get essential \seealso{ ProcessClosure } - diff --git a/man/test_gen.Rd b/man/test_gen.Rd index 4870e27..f7df07c 100644 --- a/man/test_gen.Rd +++ b/man/test_gen.Rd @@ -20,4 +20,3 @@ test_gen(root, output_dir, timed = FALSE, This function works with the trace information generated by instrumented GNU-R. It is strictly oriented to that, please see readme for more information. } - diff --git a/man/testr_options.Rd b/man/testr_options.Rd index 969f3f2..136c13a 100644 --- a/man/testr_options.Rd +++ b/man/testr_options.Rd @@ -21,4 +21,3 @@ The following \code{testr} options are available: \item \code{digits}: numeric (default: \code{2}) passed to \code{format} } } - diff --git a/man/undecorate.Rd b/man/undecorate.Rd index 9e6ee0e..9bb082d 100644 --- a/man/undecorate.Rd +++ b/man/undecorate.Rd @@ -17,4 +17,3 @@ Reset previously decorate function \seealso{ write_capture Decorate } - diff --git a/man/validate_tests.Rd b/man/validate_tests.Rd index 623443f..43a268a 100644 --- a/man/validate_tests.Rd +++ b/man/validate_tests.Rd @@ -4,9 +4,8 @@ \alias{validate_tests} \title{Attempts to run all generated tests to verify that they're actually correct.} \usage{ -validate_tests(capture.dir) +validate_tests(capture.dir, validated.test.dir, cache = new.env()) } \description{ Attempts to run all generated tests to verify that they're actually correct. } - diff --git a/man/write_capture.Rd b/man/write_capture.Rd index 5858d15..5487f45 100644 --- a/man/write_capture.Rd +++ b/man/write_capture.Rd @@ -17,4 +17,3 @@ This function is respinsible for writing down capture information for decorated \seealso{ Decorate } - diff --git a/man/write_captured_tests.Rd b/man/write_captured_tests.Rd index 02bf307..4a79895 100644 --- a/man/write_captured_tests.Rd +++ b/man/write_captured_tests.Rd @@ -12,4 +12,3 @@ write_captured_tests(path) \description{ creates an archive of generated test cases } - diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 85173f4..cd653ee 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -17,3 +17,13 @@ BEGIN_RCPP return R_NilValue; END_RCPP } + +static const R_CallMethodDef CallEntries[] = { + {"testr_WriteCapInfo_cpp", (DL_FUNC) &testr_WriteCapInfo_cpp, 2}, + {NULL, NULL, 0} +}; + +RcppExport void R_init_testr(DllInfo *dll) { + R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); + R_useDynamicSymbols(dll, FALSE); +} From 413bbe0917bd4312bb2bacf65a8f17232c250018 Mon Sep 17 00:00:00 2001 From: Parham Solaimani Date: Thu, 31 Aug 2017 12:04:06 +0200 Subject: [PATCH 66/66] fix generate_test_cases_using() --- R/runTests.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/runTests.R b/R/runTests.R index a43bd11..db333e5 100644 --- a/R/runTests.R +++ b/R/runTests.R @@ -252,14 +252,14 @@ generate_test_cases_using <- function(functions, packages) } if(missing(packages)) { packages <- strsplit(Sys.getenv("USE_PACKAGES"), split="[\\s,]+", perl = TRUE)[[1]] - packages <- packages[ nzchar(limit) > 0 ] + packages <- packages[ nzchar(packages) > 0 ] if(length(packages) == 0) { stop("No packages provided. Set the USE_PACKAGES environment variable with a comma-delimited list of package names") } } cat(sprintf("function(s): %s\n", functions)) - cat(sprintf("packages(s): %s\n", limit)) + cat(sprintf("packages(s): %s\n", packages)) # Set up validation cache and output dir validation.cache <- new.env(hash = TRUE)