context("record_tests")
cov_func <- withr::with_options(
list(covr.record_tests = TRUE),
package_coverage(test_path("TestFunctional")))
cov_tests_not_recorded <- withr::with_options(
list(covr.record_tests = NULL),
package_coverage(test_path("TestFunctional")))
test_that("covr.record_tests causes test traces to be recorded", {
expect_gt(length(attr(cov_func, "tests")), 0L)
expect_gt(length(attr(cov_func, "tests")[[1]]), 0L)
})
test_that("covr.record_tests records test indices and depth for each trace", {
expect_equal(ncol(cov_func[[1]]$tests), 4L)
expect_equal(colnames(cov_func[[1]]$tests), c("test", "call", "depth", "i"))
})
test_that("covr.record_tests test traces list uses srcref key names", {
expect_match(names(attr(cov_func, "tests")), "\\w+(:\\d+){4,8}")
})
test_that("covr.record_tests=NULL does not record tests", {
expect_null(attr(cov_tests_not_recorded, "tests"))
expect_null(cov_tests_not_recorded[[1]]$tests$tally)
})
test_that("covr.record_tests traces to tests nested within test directory", {
cov_top_level <- withr::with_envvar(
list(COVR_TEST_NESTED = "FALSE"),
package_coverage(test_path("TestNestedTestDirs")))
cov_nested <- withr::with_envvar(
list(COVR_TEST_NESTED = "TRUE"),
cov_nested <- package_coverage(test_path("TestNestedTestDirs")))
# same test file is evaluated twice more in a nested directory
expect_equal(length(attr(cov_top_level, "tests")) * 3L, length(attr(cov_nested, "tests")))
})
test_that("covr.record_tests: merging coverage objects appends tests", {
# recreate some ".counters" objects for testing
.counter_1 <- list(
tests = list(
`./test1:1:2:3:4:5:6:7:8` = list(
quote(test_that("test1", { expect_true(a()) })),
quote(expect_true(a())),
quote(a())
),
`./test2:1:2:3:4:5:6:7:8` = list(
quote(test_that("test2", { expect_true(a()) })),
quote(expect_true(a())),
quote(a())
)
),
`a:1:2:3:4:5:6:7:8` = list(
value = 2L,
tests = as.environment(list(tally = cbind(test = c(1, 2), depth = c(0, 1), i = c(1, 3))))
),
`b:1:2:3:4:5:6:7:8` = list(
value = 1L,
tests = as.environment(list(tally = cbind(test = c(2), depth = c(0), i = c(2))))
)
)
.counter_2 <- list(
tests = list(
`./test1:1:2:3:4:5:6:7:8` = list(
quote(test_that("test1", { expect_true(a()) })),
quote(expect_true(a())),
quote(a())
),
`./test3:1:2:3:4:5:6:7:8` = list(
quote(test_that("test3", { expect_true(a()) })),
quote(expect_true(a())),
quote(a())
)
),
`a:1:2:3:4:5:6:7:8` = list(
value = 1L,
tests = as.environment(list(tally = cbind(test = c(2), depth = c(0), i = c(1))))
),
`c:1:2:3:4:5:6:7:8` = list(
value = 1L,
tests = as.environment(list(tally = cbind(test = c(2), depth = c(0), i = c(2))))
)
)
# store sum total of individual counters. store before merge, as the first
# will be modified in-place during merging.
counter_total <-
nrow(.counter_1$`a:1:2:3:4:5:6:7:8`$tests$tally) +
nrow(.counter_2$`a:1:2:3:4:5:6:7:8`$tests$tally)
expect_silent(cov_merged <- merge_coverage.list(list(.counter_1, .counter_2)))
expect_equal(nrow(cov_merged$`a:1:2:3:4:5:6:7:8`$tests$tally), counter_total)
expect_equal(length(cov_merged$tests), 3L)
expect_equal(cov_merged$`a:1:2:3:4:5:6:7:8`$tests$tally[[3L,1L]], 3L)
})
test_that("covr.record_tests: tests tally is pruned even when no tests are hit", {
# "test" a function, but no code is executed and therefore no tests are logged
fcode <- 'f <- function(x) { if (x) f(!x) else FALSE }'
withr::with_options(c("covr.record_tests" = TRUE), cov <- code_coverage(fcode, "{ }"))
# expect that no tests were recorded, as no expressions evaluated f
expect_null(attr(cov, "tests"))
# expect that a matrix was still produced by a counter and pruned to 0 rows
expect_true(is.matrix(cov[[1L]]$tests))
expect_equal(cov[[1L]]$value, 0L)
expect_equal(nrow(cov[[1L]]$tests), 0L)
})
test_that("covr.record_tests: merging coverage test objects doesn't break default tests", {
# recreate some ".counters" objects for testing
.counter_1 <- list(
`a:1:2:3:4:5:6:7:8` = list(value = 2L),
`b:1:2:3:4:5:6:7:8` = list(value = 2L)
)
.counter_2 <- list(
`a:1:2:3:4:5:6:7:8` = list(value = 2L),
`c:1:2:3:4:5:6:7:8` = list(value = 2L)
)
expect_silent(cov_merged <- merge_coverage(list(.counter_1, .counter_2)))
expect_equal(cov_merged$`a:1:2:3:4:5:6:7:8`$value, 4L)
})
test_that("covr.record_tests: test that coverage objects contain expected test data", {
fcode <- '
f <- function(x) {
if (x)
f(!x)
else
FALSE
}'
withr::with_options(c("covr.record_tests" = TRUE), cov <- code_coverage(fcode, "f(TRUE)"))
# expect 4 covr traces due to test
expect_equal(sum(unlist(lapply(cov, function(i) nrow(i[["tests"]])))), 4L)
# expect that all tests have the same index
expect_equal(unique(unlist(lapply(cov, function(i) i[["tests"]][,"test"]))), 1L)
# expect execution order index to be the same length as the number of traces
expect_equal(length(unique(unlist(lapply(cov, function(i) i[["tests"]][,"i"])))), 4L)
# expect that there are two distinct stack depths (`if (x)` (@1), `TRUE` (@2), `FALSE` (@2))
expect_equal(length(unique(unlist(lapply(cov, function(i) i[["tests"]][,"depth"])))), 2L)
})
test_that("covr.record_tests: safely handles extremely large calls", {
skip_on_cran()
skip_if(is_r_devel())
fcode <- 'f <- function(...) { sum(...) }'
expect_warning(
withr::with_options(c("covr.record_tests" = TRUE), {
cov <- code_coverage(fcode, "do.call('f', as.list(rep_len(1L, 1e6)))")
}),
"large call .* truncated"
)
# expect that all calls in recorded test call stacks are under call length limit
expect_true(all(vapply(attr(cov, "tests")[[1L]], length, numeric(1L)) < 1e5))
# add a canary to test for R updates that handle large call deserialization
# more gracefully
suppressWarnings({
code <- deparse(quote({
x <- as.call(c(list("f"), as.list(rep_len(1L, 1e6))))
f <- tempfile("test_rds", fileext = ".Rds")
saveRDS(x, f)
readRDS(f)
}))
r_script <- tempfile("test_rds_script", fileext = ".R")
writeLines(code, r_script)
res <- system2(file.path(R.home("bin"), "R"), list("-q", "-s", "--vanilla", "-f", r_script), stdout = TRUE, stderr = TRUE)
})
if (identical(attr(res, "status"), 0L)) {
warning(paste0(collapse = "\n", strwrap(paste0(
"Looks like R was updated and the work-around for Rds ",
"deserialization segfaults can now be made to apply conditionally to only ",
"legacy R versions. Search for 'NOTE: r-bugs 18348' in the covr ",
"codebase to find and add necessary R version condition to the affected ",
"code"
))))
}
})
test_that("covr.record_tests: records multiple calls to the same test expr", {
fcode <- 'f1 <- function(...) "hello, world"; f2 <- function() c(1, 2, 3)'
withr::with_options(c("covr.record_tests" = TRUE), {
cov <- code_coverage(fcode, "for (i in 1:3) with(new.env(), { f1(); f2() })")
})
trace_f1 <- which(vapply(cov, `[[`, character(1L), "functions") == "f1")
expect_equal(cov[[trace_f1]]$tests[, "test"], c(1, 1, 1))
expect_equal(cov[[trace_f1]]$tests[, "call"], c(1, 2, 3))
trace_f2 <- which(vapply(cov, `[[`, character(1L), "functions") == "f2")
expect_equal(cov[[trace_f2]]$tests[, "test"], c(2, 2, 2))
expect_equal(cov[[trace_f2]]$tests[, "call"], c(1, 2, 3))
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.