Use recent covrlabs features to fix covr()

r-lib · Jan 17, 2024 · 41b169b · 41b169b
1 parent 47f1f1d
commit 41b169b
Show file tree

Hide file tree

Showing 4 changed files with 14 additions and 2 deletions.
diff --git a/R/dev-mode.R b/R/dev-mode.R
@@ -16,6 +16,11 @@ create_dev_lib <- function() {
   on.exit(setwd(wd), add = TRUE)
   setwd(dirname(inst_script))
 
+  if (Sys.getenv("TEST_COVERAGE_PAK") == "true") {
+    message("Instrumenting pak for test coverage")
+    asNamespace("covrlabs")$trace_package("pak")
+  }
+
   system2(rscript, c("--vanilla", "install-embedded.R", "--load-all", lib))
 
   invisible()

diff --git a/R/load-all-private.R b/R/load-all-private.R
@@ -5,6 +5,8 @@ load_all_private <- function() {
   lib <- private_lib_dir()
   if (Sys.getenv("TEST_COVERAGE_PAK") == "true") {
     deps_path <- file.path(lib, "deps-covr.rds")
+    cnt_path <- file.path(lib, "deps-cnt.rds")
+    asNamespace("covrlabs")$add_counters(readRDS(cnt_path))
   } else {
     deps_path <- file.path(lib, "deps.rds")
   }

diff --git a/src/install-embedded.R b/src/install-embedded.R
@@ -411,14 +411,18 @@ bundle_covr_rds <- function(lib = NULL) {
   lib <- lib %||% get_lib(lib)
   rds <- file.path(lib, "deps.rds")
   covrds <- file.path(lib, "deps-covr.rds")
-  if (!file.exists(covrds) || file.mtime(covrds) < file.mtime(rds)) {
+  cntrds <- file.path(lib, "deps-cnt.rds")
+  if (!file.exists(covrds) || !file.exists(cntrds) ||
+    file.mtime(covrds) < file.mtime(rds) ||
+    file.mtime(cntrds) < file.mtime(rds)) {
     message("Instrumenting dependency code for covr")
     ns <- readRDS(rds)
     ns <- covrlabs::serialize_to_file(
       ns,
       covrds,
       closxp_callback = covrlabs::trace_calls
     )
+    covrlabs::serialize_to_file(covrlabs:::.counters, cntrds)
   } else {
     message("Instruments code bundle is current")
   }

diff --git a/tests/testthat/helper-covr.R b/tests/testthat/helper-covr.R
@@ -7,13 +7,14 @@ covr <- function(filter = NULL, pre_clean = TRUE, quiet = TRUE, ...) {
     gcda <- list.files(pattern = "[.]gcda$", recursive = TRUE)
     gcov <- list.files(pattern = "[.]gcov$", recursive = TRUE)
     unlink(c(gcda, gcov))
+    asNamespace("covrlabs")$reset_counters()
   }
 
   # Run tests -------------------------------------------------------------
   testthat::test_dir("tests/testthat", filter = filter, ...)
 
   # Save R coverage -------------------------------------------------------
-  asNamespace("covr")$save_trace(".")
+  asNamespace("covrlabs")$save_trace()
 
   # Save C coverage -------------------------------------------------------
   # The rest do not have a gcov_flush hook