TESTME: prepare

HenrikBengtsson · HenrikBengtsson · commit 4484556d1094 · 2025-12-20T14:55:10.000-08:00
diff --git a/inst/testme/_epilogue/002.undo-state.R b/inst/testme/_epilogue/002.undo-state.R
@@ -0,0 +1,77 @@
+testme <- as.environment("testme")
+
+## Undo options
+## (a) Reset
+options(oopts0)
+
+## (b) Remove added
+local({
+  added <- setdiff(names(options()), names(oopts0))
+  opts <- vector("list", length = length(added))
+  names(opts) <- added
+  options(opts)
+})
+
+## (c) Assert that everything was undone
+if (!identical(options(), oopts0)) {
+  message("Failed to undo options:")
+  oopts <- options()
+  message(sprintf(" - Expected options: [n=%d] %s",
+                  length(oopts0), hpaste(sQuote(names(oopts0)))))
+  extra <- setdiff(names(oopts), names(oopts0))
+  message(paste(sprintf(" - Options still there: [n=%d]", length(extra)),
+                hpaste(sQuote(extra))))
+  missing <- setdiff(names(oopts0), names(oopts))
+  message(paste(sprintf(" - Options missing: [n=%d]", length(missing)),
+                hpaste(sQuote(missing))))
+  message("Differences option by option:")                
+  for (name in names(oopts0)) {
+    value0 <- oopts0[[name]]
+    value  <- oopts[[name]]
+    if (!identical(value, value0)) {
+      if (testme[["debug"]]) {
+        utils::str(list(name = name, expected = value0, actual = value))
+      }
+    }
+  }
+}
+
+
+## Undo system environment variables
+## (a) Reset
+do.call(Sys.setenv, args=as.list(oenvs0))
+## (b) Removed added
+added <- setdiff(names(Sys.getenv()), names(oenvs0))
+Sys.unsetenv(added)
+## (c) Assert that everything was undone
+if (!identical(Sys.getenv(), oenvs0)) {
+  message("Failed to undo environment variables:")
+  oenvs <- Sys.getenv()
+  message(sprintf(" - Expected environment variables: [n=%d] %s",
+                  length(oenvs0), hpaste(sQuote(names(oenvs0)))))
+  extra <- setdiff(names(oenvs), names(oenvs0))
+  message(paste(sprintf(" - Environment variables still there: [n=%d]", length(extra)),
+                hpaste(sQuote(extra))))
+  missing <- setdiff(names(oenvs0), names(oenvs))
+  message(paste(sprintf(" - Environment variables missing: [n=%d]", length(missing)),
+                hpaste(sQuote(missing))))
+  message("Differences environment variable by environment variable:")
+  for (name in names(oenvs0)) {
+    value0 <- unname(oenvs0[name])
+    value  <- unname(oenvs[name])
+    if (!identical(value, value0)) {
+      if (testme[["debug"]]) {
+        utils::str(list(name = name, expected = value0, actual = value))
+      }
+    }
+  }
+}
+
+
+## Assert undo was successful
+if (testme[["debug"]]) {
+  stopifnot(identical(options(), oopts0))
+}
+
+## Undo variables
+rm(list = c(setdiff(ls(envir = globalenv()), ovars)), envir = globalenv())
diff --git a/inst/testme/_epilogue/090.gc.R b/inst/testme/_epilogue/090.gc.R
@@ -0,0 +1,8 @@
+## Travis CI specific: Explicit garbage collection because it
+## looks like Travis CI might run out of memory during 'covr'
+## testing and we now have so many tests. /HB 2017-01-11
+if ("covr" %in% loadedNamespaces()) {
+  res <- gc()
+  testme <- as.environment("testme")
+  if (testme[["debug"]]) print(res)
+}
diff --git a/inst/testme/_epilogue/099.session_info.R b/inst/testme/_epilogue/099.session_info.R
@@ -0,0 +1,6 @@
+testme <- as.environment("testme")
+if (testme[["debug"]]) {
+  info <- utils::sessionInfo()
+  message("Session information:")
+  print(info)
+}
diff --git a/inst/testme/_epilogue/995.detritus-connections.R b/inst/testme/_epilogue/995.detritus-connections.R
@@ -0,0 +1,8 @@
+## Look for detritus files
+testme <- as.environment("testme")
+delta <- diff_connections(get_connections(), testme[["testme_connections"]])
+if (any(lengths(delta) > 0)) {
+  message(sprintf("Detritus connections generated by test %s:", sQuote(testme[["name"]])))
+  print(delta)
+}
+
diff --git a/inst/testme/_epilogue/999.detritus-files.R b/inst/testme/_epilogue/999.detritus-files.R
@@ -0,0 +1,28 @@
+## Look for detritus files
+testme <- as.environment("testme")
+path <- dirname(tempdir())
+
+if (basename(path) == "working_dir") {
+  files <- dir(pattern = "^Rscript", path = path, all.files = TRUE, full.names = TRUE)
+  if (length(files) > 0L) {
+    message(sprintf("Detritus 'Rscript*' files generated by test %s:", sQuote(testme[["name"]])))
+    print(files)
+
+    ## Remove detritus files produced by this test script, so that
+    ## other test scripts will not fail because of these files.
+    unlink(files)
+
+    ## Signal the problem
+    msg <- sprintf("Detected 'Rscript*' files: [n=%d] %s", length(files), paste(sQuote(basename(files)), collapse = ", "))
+    ## Are detritus files files expected by design on MS Windows?
+    ## If so, produce a warning, otherwise an error
+    if ("detritus-files" %in% testme[["tags"]] &&
+        .Platform[["OS.type"]] == "windows") {
+      warning(msg, immediate. = TRUE)
+    } else {
+      stop(msg)
+    }
+  }
+} else {
+  message(sprintf("Skipping, because path appears not to be an 'R CMD check' folder: %s", sQuote(path)))
+}
diff --git a/inst/testme/_prologue/001.load.R b/inst/testme/_prologue/001.load.R
@@ -0,0 +1,2 @@
+testme <- as.environment("testme")
+loadNamespace(testme[["package"]])
diff --git a/inst/testme/_prologue/002.record-state.R b/inst/testme/_prologue/002.record-state.R
@@ -0,0 +1,4 @@
+## Record original state
+ovars <- ls(envir = globalenv())
+oenvs <- oenvs0 <- Sys.getenv()
+oopts0 <- options()
diff --git a/inst/testme/_prologue/030.imports.R b/inst/testme/_prologue/030.imports.R
@@ -0,0 +1,3 @@
+## Private package functions
+printf <- function(...) cat(sprintf(...))
+
diff --git a/inst/testme/_prologue/040.context.R b/inst/testme/_prologue/040.context.R
@@ -0,0 +1,12 @@
+check_full <- (Sys.getenv("_R_CHECK_FULL_") != "")
+
+covr <- ("covr" %in% loadedNamespaces())
+on_macos <- grepl("^darwin", R.version$os)
+on_githubactions <- as.logical(Sys.getenv("GITHUB_ACTIONS", "FALSE"))
+
+# WORKAROUND: Make sure tests also work with 'covr' package
+if (covr) {
+  globalenv <- function() parent.frame()
+  baseenv <- function() environment(base::sample)
+}
+
diff --git a/inst/testme/_prologue/080.options.R b/inst/testme/_prologue/080.options.R
@@ -0,0 +1 @@
+## Settings
diff --git a/inst/testme/_prologue/995.detrius-connections.R b/inst/testme/_prologue/995.detrius-connections.R
@@ -0,0 +1,63 @@
+get_connections <- function() {
+  cons <- lapply(getAllConnections(), FUN = function(idx) {
+    tryCatch({
+      con <- getConnection(idx)
+      as.data.frame(c(index = idx, summary(con)))
+    }, error = function(e) {
+      NULL
+    })
+  })
+  do.call(rbind, cons)
+}
+
+diff_connections <- function(after, before) {
+  index <- NULL ## To please R CMD check
+  
+  ## Nothing to do?
+  if (length(before) + length(after) == 0L) {
+    return(c(added = NULL, removed = NULL, replaced = NULL))
+  }
+
+  idxs <- setdiff(after[["index"]], before[["index"]])
+  if (length(idxs) > 0) {
+    added <- subset(after, index %in% idxs)
+    after <- subset(after, ! index %in% idxs)
+  } else {
+    added <- NULL
+  }
+  
+  idxs <- setdiff(before[["index"]], after[["index"]])
+  if (length(idxs) > 0) {
+    removed <- subset(before, index %in% idxs)
+    before <- subset(before, ! index %in% idxs)
+  } else {
+    removed <- NULL
+  }
+
+  idxs <- intersect(before[["index"]], after[["index"]])
+  if (length(idxs) > 0) {
+    replaced <- list()
+    for (idx in idxs) {
+      before_idx <- subset(before, index == idx)
+      after_idx <- subset(after, index == idx)
+      if (!identical(before_idx, after_idx)) {
+        for (name in colnames(after_idx)) {
+          value <- after_idx[[name]]
+          if (!identical(before_idx[[name]], value)) {
+            value <- sprintf("%s (was %s)", value, before_idx[[name]])
+            after_idx[[name]] <- value
+          }
+        }
+        replaced <- c(replaced, list(after_idx))
+      }
+    }
+    replaced <- do.call(rbind, replaced)
+  } else {
+    replaced <- NULL
+  }
+
+  list(added = added, removed = removed, replaced = replaced)
+}
+
+testme <- as.environment("testme")
+testme[["testme_connections"]] <- get_connections()
diff --git a/inst/testme/deploy.R b/inst/testme/deploy.R
@@ -0,0 +1,74 @@
+#!/usr/bin/env Rscript
+
+source <- "./inst/testme"
+if (!utils::file_test("-d", source)) {
+  stop("Source 'testme' folder not found: ", sQuote(source))
+}
+
+target <- "./tests"
+if (!utils::file_test("-d", target)) {
+  stop("Target 'tests' folder not found: ", sQuote(target))
+}
+
+r_path <- "./R"
+if (!utils::file_test("-d", r_path)) {
+  stop("Target 'R' folder not found: ", sQuote(r_path))
+}
+
+desc <- "./DESCRIPTION"
+if (!utils::file_test("-f", desc)) {
+  stop("'DESCRIPTION' file not found: ", sQuote(desc))
+}
+pkgname <- read.dcf(desc)[, "Package"]
+if (is.na(pkgname) || !nzchar(pkgname)) {
+  stop("Failed to infer package name from 'DESCRIPTION' file: ", sQuote(pkgname))
+} else if (!requireNamespace(pkgname)) {
+  stop("Package fail to load: ", sQuote(pkgname))
+}
+
+
+files <- dir(path = source, pattern = "^test-.*[.]R$", full.names = TRUE)
+message(sprintf("Deploying %d test scripts ...", length(files)))
+
+## Generate R unit test script
+code <- c(
+  "## This runs 'testme' test inst/testme/test-<name>.R scripts",
+  "## Don't edit - it was autogenerated by inst/testme/deploy.R",
+  "testme <- function(name) {",
+  sprintf("  path <- system.file(package = '%s', 'testme', mustWork = TRUE)", pkgname),
+  "  Sys.setenv(R_TESTME_PATH = path)",
+  sprintf("  Sys.setenv(R_TESTME_PACKAGE = '%s')", pkgname),
+  "  Sys.setenv(R_TESTME_NAME = name)",
+  "  on.exit(Sys.unsetenv('R_TESTME_NAME'))",
+  "  source(file.path(path, 'run.R'))",
+  "}"
+)
+writeLines(code, con = file.path("./R/testme.R"))
+
+for (kk in seq_along(files)) {
+  file <- files[kk]
+
+  source_file <- basename(file)
+  name <- sub("^test-", "", sub("[.]R$", "", source_file))
+  target_file <- file.path(target, source_file)
+  
+  message(sprintf("%02d/%02d test script %s", kk, length(files), sQuote(target_file)))
+
+  ## Assert that testme script can be parsed
+  res <- tryCatch(parse(file = file), error = identity)
+  if (inherits(res, "error")) {
+    stop("Syntax error: ", sQuote(file))
+  }
+
+  ## Generate R unit test script
+  code <- c(
+    "#! /usr/bin/env Rscript",
+    sprintf("## This runs testme test script inst/testme/test-%s.R", name),
+    "## Don't edit - it was autogenerated by inst/testme/deploy.R",
+    sprintf('%s:::testme("%s")', pkgname, name)
+  )
+  writeLines(code, con = target_file)
+  Sys.chmod(target_file, mode = "0755")
+}
+
+message(sprintf("Deploying %d test scripts ... done", length(files)))
diff --git a/inst/testme/run.R b/inst/testme/run.R

Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,2 @@`
	`1`	`+testme <- as.environment("testme")`
	`2`	`+loadNamespace(testme[["package"]])`
Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,3 @@`
	`1`	`+## Private package functions`
	`2`	`+printf <- function(...) cat(sprintf(...))`
	`3`	`+`