Skip to content

Commit 01f23cd

Browse files
HenrikBengtssonHenrikBengtsson
committed
TESTS: Move to 'testme' structure
1 parent 4969ca1 commit 01f23cd

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

56 files changed

+630
-87
lines changed

‎.Rbuildignore

+1-1
Original file line numberDiff line numberDiff line change
@@ -51,7 +51,7 @@ Rplots.pdf$
5151
# Package specific
5252
#----------------------------
5353
^[.]BatchJobs[.]R$
54-
[.]future
54+
^[.]future
5555

5656
#----------------------------
5757
# Miscellaneous

‎DESCRIPTION

+1-1
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
Package: future.callr
2-
Version: 0.8.2-9203
2+
Version: 0.8.2-9204
33
Depends:
44
R (>= 3.4.0),
55
future (>= 1.34.0)

‎R/testme.R

+10
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
## This runs 'testme' test inst/testme/test-<name>.R scripts
2+
## Don't edit - it was autogenerated by inst/testme/deploy.R
3+
testme <- function(name) {
4+
path <- system.file(package = 'future.callr', 'testme', mustWork = TRUE)
5+
Sys.setenv(R_TESTME_PATH = path)
6+
Sys.setenv(R_TESTME_PACKAGE = 'future.callr')
7+
Sys.setenv(R_TESTME_NAME = name)
8+
on.exit(Sys.unsetenv('R_TESTME_NAME'))
9+
source(file.path(path, 'run.R'))
10+
}

‎inst/testme/_epilogue/001.undo-future.R

+5
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
## Undo future debug
2+
options(future.debug = FALSE)
3+
4+
## Undo future strategy
5+
future::plan(oplan)

‎inst/testme/_epilogue/002.undo-state.R

+77
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,77 @@
1+
testme <- as.environment("testme")
2+
3+
## Undo options
4+
## (a) Reset
5+
options(oopts0)
6+
7+
## (b) Remove added
8+
local({
9+
added <- setdiff(names(options()), names(oopts0))
10+
opts <- vector("list", length = length(added))
11+
names(opts) <- added
12+
options(opts)
13+
})
14+
15+
## (c) Assert that everything was undone
16+
if (!identical(options(), oopts0)) {
17+
message("Failed to undo options:")
18+
oopts <- options()
19+
message(sprintf(" - Expected options: [n=%d] %s",
20+
length(oopts0), hpaste(sQuote(names(oopts0)))))
21+
extra <- setdiff(names(oopts), names(oopts0))
22+
message(paste(sprintf(" - Options still there: [n=%d]", length(extra)),
23+
hpaste(sQuote(extra))))
24+
missing <- setdiff(names(oopts0), names(oopts))
25+
message(paste(sprintf(" - Options missing: [n=%d]", length(missing)),
26+
hpaste(sQuote(missing))))
27+
message("Differences option by option:")
28+
for (name in names(oopts0)) {
29+
value0 <- oopts0[[name]]
30+
value <- oopts[[name]]
31+
if (!identical(value, value0)) {
32+
if (testme[["debug"]]) {
33+
utils::str(list(name = name, expected = value0, actual = value))
34+
}
35+
}
36+
}
37+
}
38+
39+
40+
## Undo system environment variables
41+
## (a) Reset
42+
do.call(Sys.setenv, args=as.list(oenvs0))
43+
## (b) Removed added
44+
added <- setdiff(names(Sys.getenv()), names(oenvs0))
45+
Sys.unsetenv(added)
46+
## (c) Assert that everything was undone
47+
if (!identical(Sys.getenv(), oenvs0)) {
48+
message("Failed to undo environment variables:")
49+
oenvs <- Sys.getenv()
50+
message(sprintf(" - Expected environment variables: [n=%d] %s",
51+
length(oenvs0), hpaste(sQuote(names(oenvs0)))))
52+
extra <- setdiff(names(oenvs), names(oenvs0))
53+
message(paste(sprintf(" - Environment variables still there: [n=%d]", length(extra)),
54+
hpaste(sQuote(extra))))
55+
missing <- setdiff(names(oenvs0), names(oenvs))
56+
message(paste(sprintf(" - Environment variables missing: [n=%d]", length(missing)),
57+
hpaste(sQuote(missing))))
58+
message("Differences environment variable by environment variable:")
59+
for (name in names(oenvs0)) {
60+
value0 <- unname(oenvs0[name])
61+
value <- unname(oenvs[name])
62+
if (!identical(value, value0)) {
63+
if (testme[["debug"]]) {
64+
utils::str(list(name = name, expected = value0, actual = value))
65+
}
66+
}
67+
}
68+
}
69+
70+
71+
## Assert undo was successful
72+
if (testme[["debug"]]) {
73+
stopifnot(identical(options(), oopts0))
74+
}
75+
76+
## Undo variables
77+
rm(list = c(setdiff(ls(envir = globalenv()), ovars)), envir = globalenv())

‎inst/testme/_epilogue/090.gc.R

+8
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
## Travis CI specific: Explicit garbage collection because it
2+
## looks like Travis CI might run out of memory during 'covr'
3+
## testing and we now have so many tests. /HB 2017-01-11
4+
if ("covr" %in% loadedNamespaces()) {
5+
res <- gc()
6+
testme <- as.environment("testme")
7+
if (testme[["debug"]]) print(res)
8+
}

‎inst/testme/_epilogue/099.session_info.R

+6
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
testme <- as.environment("testme")
2+
if (testme[["debug"]]) {
3+
info <- utils::sessionInfo()
4+
message("Session information:")
5+
print(info)
6+
}

‎inst/testme/_epilogue/995.detritus-connections.R

+8
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
## Look for detritus files
2+
testme <- as.environment("testme")
3+
delta <- diff_connections(get_connections(), testme[["testme_connections"]])
4+
if (any(lengths(delta) > 0)) {
5+
message(sprintf("Detritus connections generated by test %s:", sQuote(testme[["name"]])))
6+
print(delta)
7+
}
8+

‎inst/testme/_epilogue/999.detritus-files.R

+28
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,28 @@
1+
## Look for detritus files
2+
testme <- as.environment("testme")
3+
path <- dirname(tempdir())
4+
5+
if (basename(path) == "working_dir") {
6+
files <- dir(pattern = "^Rscript", path = path, all.files = TRUE, full.names = TRUE)
7+
if (length(files) > 0L) {
8+
message(sprintf("Detritus 'Rscript*' files generated by test %s:", sQuote(testme[["name"]])))
9+
print(files)
10+
11+
## Remove detritus files produced by this test script, so that
12+
## other test scripts will not fail because of these files.
13+
unlink(files)
14+
15+
## Signal the problem
16+
msg <- sprintf("Detected 'Rscript*' files: [n=%d] %s", length(files), paste(sQuote(basename(files)), collapse = ", "))
17+
## Are detritus files files expected by design on MS Windows?
18+
## If so, produce a warning, otherwise an error
19+
if ("detritus-files" %in% testme[["tags"]] &&
20+
.Platform[["OS.type"]] == "windows") {
21+
warning(msg, immediate. = TRUE)
22+
} else {
23+
stop(msg)
24+
}
25+
}
26+
} else {
27+
message(sprintf("Skipping, because path appears not to be an 'R CMD check' folder: %s", sQuote(path)))
28+
}

‎inst/testme/_prologue/001.load.R

+1
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
loadNamespace("future.callr")

‎inst/testme/_prologue/002.record-state.R

+4
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
## Record original state
2+
ovars <- ls(envir = globalenv())
3+
oenvs <- oenvs0 <- Sys.getenv()
4+
oopts0 <- options()

‎inst/testme/_prologue/030.imports.R

+13
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
## Private future.callr functions
2+
await <- future.callr:::await
3+
import_future <- future.callr:::import_future
4+
is_false <- future.callr:::is_false
5+
is_na <- future.callr:::is_na
6+
is_os <- future.callr:::is_os
7+
hpaste <- future.callr:::hpaste
8+
mcat <- future.callr:::mcat
9+
mprintf <- future.callr:::mprintf
10+
mprint <- future.callr:::mprint
11+
mstr <- future.callr:::mstr
12+
printf <- future.callr:::printf
13+
trim <- future.callr:::trim

‎inst/testme/_prologue/050.utils.R

+5
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
attach_locally <- function(x, envir = parent.frame()) {
2+
for (name in names(x)) {
3+
assign(name, value = x[[name]], envir = envir)
4+
}
5+
}

‎inst/testme/_prologue/090.context.R

+5
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
fullTest <- (Sys.getenv("_R_CHECK_FULL_") != "")
2+
3+
covr_testing <- ("covr" %in% loadedNamespaces())
4+
on_macos <- grepl("^darwin", R.version$os)
5+
on_githubactions <- as.logical(Sys.getenv("GITHUB_ACTIONS", "FALSE"))

‎inst/testme/_prologue/090.options.R

+12
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
## Default options
2+
oopts <- options(
3+
warn = 1L,
4+
showNCalls = 500L,
5+
mc.cores = 2L,
6+
7+
future.debug = FALSE,
8+
## Reset the following during testing in case
9+
## they are set on the test system
10+
future.availableCores.system = NULL,
11+
future.availableCores.fallback = NULL
12+
)

‎inst/testme/_prologue/091.envvars.R

+26
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
## Comment: The below should be set automatically whenever the future package
2+
## is loaded and 'R CMD check' runs. The below is added in case R is changed
3+
## in the future and we fail to detect 'R CMD check'.
4+
Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_CONNECTTIMEOUT = 2 * 60)
5+
Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_TIMEOUT = 2 * 60)
6+
Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_SESSIONINFO_PKGS = TRUE)
7+
Sys.setenv(R_FUTURE_WAIT_INTERVAL = 0.01) ## 0.01s (instead of default 0.2s)
8+
9+
## Label PSOCK cluster workers (to help troubleshooting)
10+
test_script <- grep("[.]R$", commandArgs(), value = TRUE)[1]
11+
if (is.na(test_script)) test_script <- "UNKNOWN"
12+
worker_label <- sprintf("future/tests/%s:%s:%s:%s", test_script, Sys.info()[["nodename"]], Sys.info()[["user"]], Sys.getpid())
13+
Sys.setenv(R_PARALLELLY_MAKENODEPSOCK_RSCRIPT_LABEL = worker_label)
14+
15+
## Reset the following during testing in case
16+
## they are set on the test system
17+
oenvs2 <- Sys.unsetenv(c(
18+
"R_PARALLELLY_AVAILABLECORES_SYSTEM",
19+
"R_PARALLELLY_AVAILABLECORES_FALLBACK",
20+
## SGE
21+
"NSLOTS", "PE_HOSTFILE",
22+
## Slurm
23+
"SLURM_CPUS_PER_TASK",
24+
## TORQUE / PBS
25+
"NCPUS", "PBS_NUM_PPN", "PBS_NODEFILE", "PBS_NP", "PBS_NUM_NODES"
26+
))

‎inst/testme/_prologue/099.future-setup.R

+19
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
## Use local callr futures by default
2+
oplan <- local({
3+
oopts <- options(future.debug = FALSE)
4+
on.exit(options(oopts))
5+
future::plan(future.callr::callr)
6+
})
7+
8+
all_strategies <- function() {
9+
strategies <- Sys.getenv("R_FUTURE_TESTS_STRATEGIES")
10+
strategies <- unlist(strsplit(strategies, split = ","))
11+
strategies <- gsub(" ", "", strategies)
12+
strategies <- strategies[nzchar(strategies)]
13+
strategies <- c(future:::supportedStrategies(), strategies)
14+
unique(strategies)
15+
}
16+
17+
test_strategy <- function(strategy) {
18+
strategy %in% all_strategies()
19+
}

‎inst/testme/_prologue/995.detrius-connections.R

+63
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,63 @@
1+
get_connections <- function() {
2+
cons <- lapply(getAllConnections(), FUN = function(idx) {
3+
tryCatch({
4+
con <- getConnection(idx)
5+
as.data.frame(c(index = idx, summary(con)))
6+
}, error = function(e) {
7+
NULL
8+
})
9+
})
10+
do.call(rbind, cons)
11+
}
12+
13+
diff_connections <- function(after, before) {
14+
index <- NULL ## To please R CMD check
15+
16+
## Nothing to do?
17+
if (length(before) + length(after) == 0L) {
18+
return(c(added = NULL, removed = NULL, replaced = NULL))
19+
}
20+
21+
idxs <- setdiff(after[["index"]], before[["index"]])
22+
if (length(idxs) > 0) {
23+
added <- subset(after, index %in% idxs)
24+
after <- subset(after, ! index %in% idxs)
25+
} else {
26+
added <- NULL
27+
}
28+
29+
idxs <- setdiff(before[["index"]], after[["index"]])
30+
if (length(idxs) > 0) {
31+
removed <- subset(before, index %in% idxs)
32+
before <- subset(before, ! index %in% idxs)
33+
} else {
34+
removed <- NULL
35+
}
36+
37+
idxs <- intersect(before[["index"]], after[["index"]])
38+
if (length(idxs) > 0) {
39+
replaced <- list()
40+
for (idx in idxs) {
41+
before_idx <- subset(before, index == idx)
42+
after_idx <- subset(after, index == idx)
43+
if (!identical(before_idx, after_idx)) {
44+
for (name in colnames(after_idx)) {
45+
value <- after_idx[[name]]
46+
if (!identical(before_idx[[name]], value)) {
47+
value <- sprintf("%s (was %s)", value, before_idx[[name]])
48+
after_idx[[name]] <- value
49+
}
50+
}
51+
replaced <- c(replaced, list(after_idx))
52+
}
53+
}
54+
replaced <- do.call(rbind, replaced)
55+
} else {
56+
replaced <- NULL
57+
}
58+
59+
list(added = added, removed = removed, replaced = replaced)
60+
}
61+
62+
testme <- as.environment("testme")
63+
testme[["testme_connections"]] <- get_connections()

‎inst/testme/deploy.R

+70
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,70 @@
1+
source <- "./inst/testme"
2+
if (!utils::file_test("-d", source)) {
3+
stop("Source 'testme' folder not found: ", sQuote(source))
4+
}
5+
6+
target <- "./tests"
7+
if (!utils::file_test("-d", target)) {
8+
stop("Target 'tests' folder not found: ", sQuote(target))
9+
}
10+
11+
r_path <- "./R"
12+
if (!utils::file_test("-d", r_path)) {
13+
stop("Target 'R' folder not found: ", sQuote(r_path))
14+
}
15+
16+
desc <- "./DESCRIPTION"
17+
if (!utils::file_test("-f", desc)) {
18+
stop("'DESCRIPTION' file not found: ", sQuote(desc))
19+
}
20+
pkgname <- read.dcf(desc)[, "Package"]
21+
if (is.na(pkgname) || !nzchar(pkgname)) {
22+
stop("Failed to infer package name from 'DESCRIPTION' file: ", sQuote(pkgname))
23+
} else if (!requireNamespace(pkgname)) {
24+
stop("Package fail to load: ", sQuote(pkgname))
25+
}
26+
27+
28+
files <- dir(path = source, pattern = "^test-.*[.]R$", full.names = TRUE)
29+
message(sprintf("Deploying %d test scripts ...", length(files)))
30+
31+
## Generate R unit test script
32+
code <- c(
33+
"## This runs 'testme' test inst/testme/test-<name>.R scripts",
34+
"## Don't edit - it was autogenerated by inst/testme/deploy.R",
35+
"testme <- function(name) {",
36+
sprintf(" path <- system.file(package = '%s', 'testme', mustWork = TRUE)", pkgname),
37+
" Sys.setenv(R_TESTME_PATH = path)",
38+
sprintf(" Sys.setenv(R_TESTME_PACKAGE = '%s')", pkgname),
39+
" Sys.setenv(R_TESTME_NAME = name)",
40+
" on.exit(Sys.unsetenv('R_TESTME_NAME'))",
41+
" source(file.path(path, 'run.R'))",
42+
"}"
43+
)
44+
writeLines(code, con = file.path("./R/testme.R"))
45+
46+
for (kk in seq_along(files)) {
47+
file <- files[kk]
48+
49+
source_file <- basename(file)
50+
name <- sub("^test-", "", sub("[.]R$", "", source_file))
51+
target_file <- file.path(target, source_file)
52+
53+
message(sprintf("%02d/%02d test script %s", kk, length(files), sQuote(target_file)))
54+
55+
## Assert that testme script can be parsed
56+
res <- tryCatch(parse(file = file), error = identity)
57+
if (inherits(res, "error")) {
58+
stop("Syntax error: ", sQuote(file))
59+
}
60+
61+
## Generate R unit test script
62+
code <- c(
63+
sprintf("## This runs testme test script incl/testme/test-%s.R", name),
64+
"## Don't edit - it was autogenerated by inst/testme/deploy.R",
65+
sprintf('%s:::testme("%s")', pkgname, name)
66+
)
67+
writeLines(code, con = target_file)
68+
}
69+
70+
message(sprintf("Deploying %d test scripts ... done", length(files)))

0 commit comments

Comments
 (0)