Merge branch 'main' into non-API-updates

r-lib · Nov 21, 2024 · d35de1f · d35de1f
2 parents 9a8e0bc + ca4241d
commit d35de1f
Show file tree

Hide file tree

Showing 46 changed files with 222 additions and 96 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -62,7 +62,7 @@ Suggests:
     rmarkdown,
     htmltools,
     DT (>= 0.2),
-    testthat,
+    testthat (>= 3.0.0),
     rlang,
     rstudioapi (>= 0.2),
     xml2 (>= 1.0.0),
@@ -75,3 +75,5 @@ License: MIT + file LICENSE
 VignetteBuilder: knitr
 RoxygenNote: 7.2.3
 Roxygen: list(markdown = TRUE)
+Config/testthat/edition: 3
+Config/testthat/parallel: TRUE
diff --git a/NEWS.md b/NEWS.md
@@ -1,4 +1,8 @@
 # covr (development version)
+* Fix a bug preventing `package_coverage()` from running tests when `install_path` is set to a relative path (@gergness, #517, #548).
+
+* Fixed a performance regression and an error triggered by a change in R
+  4.4.0. (@kyleam, #588)
 
 * Fixed an issue where attempting to generate code coverage on an already-loaded
   package could fail on Windows. (@kevinushey, #574)

diff --git a/R/S7.R b/R/S7.R
@@ -1,12 +1,27 @@
 replacements_S7 <- function(env) {
-  unlist(recursive = FALSE, use.names = FALSE, eapply(env, all.names = TRUE,
+  bindings <- unlist(recursive = FALSE, use.names = FALSE, eapply(env, all.names = TRUE,
     function(obj) {
       if (inherits(obj, "S7_generic")) {
         traverse_S7_generic(obj)
       } else if (inherits(obj, "S7_class")) {
         traverse_S7_class(obj)
       }
     }))
+
+  S7_methods_tbl <- attr(env[[".__S3MethodsTable__."]], "S7methods", exact = TRUE)
+  external_methods <- lapply(seq_along(S7_methods_tbl), function(i) {
+    entry <- S7_methods_tbl[[i]]
+    name <- external_generic_method_signature(entry$generic, entry$signature)
+
+    replacement(
+      # `name` is for informative printouts only.
+      # It is not used by covr, and does not need to be unique,
+      name = name,
+      env = entry,
+      target_value = entry$method)
+  })
+
+  c(bindings, external_methods)
 }
 
 traverse_S7_generic <- function(x) {
@@ -51,3 +66,19 @@ traverse_S7_class <- function(x) {
     prop_fun_replacements
   )
 }
+
+
+external_generic_method_signature <- function(generic, signature) {
+  # This function is a lightly modified copy of S7:::method_signature() for external generics
+  display_generic <- paste0(c(generic$package, generic$name), collapse = "::")
+  class_deparse <- asNamespace("S7")$class_deparse # not exported from S7 :/
+  single <- length(generic$dispatch_args) == 1
+  if (single) {
+    signature <- class_deparse(signature[[1]])
+  } else {
+    classes <- vapply(signature, class_deparse, "", USE.NAMES = FALSE)
+    signature <- paste0("list(", paste0(classes, collapse = ", "), ")")
+  }
+
+  sprintf("method(%s, %s)", display_generic, signature)
+}
diff --git a/R/covr.R b/R/covr.R
@@ -411,6 +411,8 @@ package_coverage <- function(path = ".",
   }
 
   dir.create(install_path)
+  # tools::testInstalledPackage requires normalized install_path (#517)
+  install_path <- normalize_path(install_path)
 
   flags <- getOption("covr.flags")
 
@@ -459,7 +461,12 @@ package_coverage <- function(path = ".",
 
       name <- if (.Platform$OS.type == "windows") "R.exe" else "R"
       path <- file.path(R.home("bin"), name)
-      system2(path, args)
+      system2(
+        path,
+        args,
+        stdout = if (quiet) NULL else "",
+        stderr = if (quiet) NULL else ""
+      )
     })
   )
 

diff --git a/R/parse_data.R b/R/parse_data.R
@@ -122,7 +122,12 @@ package_parse_data <- new.env()
 get_parse_data <- function(srcfile) {
   if (length(package_parse_data) == 0) {
     lines <- getSrcLines(srcfile, 1L, Inf)
-    res <- lapply(split_on_line_directives(lines),
+    lines_split <- split_on_line_directives(lines)
+    if (!length(lines_split)) {
+      return(NULL)
+    }
+
+    res <- lapply(lines_split,
       function(x) getParseData(parse(text = x, keep.source = TRUE), includeText = TRUE))
     for (i in seq_along(res)) {
       package_parse_data[[names(res)[[i]]]] <- res[[i]]
@@ -135,7 +140,16 @@ clean_parse_data <- function() {
   rm(list = ls(package_parse_data), envir = package_parse_data)
 }
 
-# Needed to work around https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=16756
 get_tokens <- function(srcref) {
-  getParseData(srcref) %||% get_parse_data(attr(getSrcref(srcref), "srcfile"))
+  # Before R 4.4.0, covr's custom get_parse_data is necessary because
+  # utils::getParseData returns parse data for only the last file in the
+  # package. That issue (bug#16756) is fixed in R 4.4.0 (r84538).
+  #
+  # On R 4.4.0, continue to use get_parse_data because covr's code expects the
+  # result to be limited to the srcref file. getParseData will return parse data
+  # for all of the package's files.
+  get_parse_data(attr(getSrcref(srcref), "srcfile")) %||%
+    # This covers the non-installed file case where the source file isn't a
+    # concatenated file with "line N" directives.
+    getParseData(srcref)
 }
diff --git a/R/utils.R b/R/utils.R
@@ -90,9 +90,18 @@ split_on_line_directives <- function(lines) {
       capture(name = "line_number", digit), spaces,
       quotes, capture(name = "filename", anything), quotes))
   directive_lines <- which(!is.na(matches$line_number))
+  if (!length(directive_lines)) {
+    return(NULL)
+  }
+
   file_starts <- directive_lines + 1
   file_ends <- c(directive_lines[-1] - 1, length(lines))
-  res <- mapply(function(start, end) lines[start:end], file_starts, file_ends)
+  res <- mapply(
+    function(start, end) lines[start:end],
+    file_starts,
+    file_ends,
+    SIMPLIFY = FALSE
+  )
   names(res) <- na.omit(matches$filename)
   res
 }

diff --git a/tests/testthat.R b/tests/testthat.R
@@ -1,12 +1,12 @@
-ops <- options("crayon.enabled" = FALSE, warn = 1)
-library(testthat)
-library("covr")
+# This file is part of the standard setup for testthat.
+# It is recommended that you do not modify it.
+#
+# Where should you do additional test configuration?
+# Learn more about the roles of various files in:
+# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview
+# * https://testthat.r-lib.org/articles/special-files.html
 
-# Skip tests on Solaris as gcc is not in the PATH and I do not have an easy way
-# to mimic the CRAN build environment
-if (!tolower(Sys.info()[["sysname"]]) == "sunos") {
-  Sys.setenv("R_TESTS" = "")
-  test_check("covr")
-}
+library(testthat)
+library(covr)
 
-options(ops)
+test_check("covr")
diff --git a/tests/testthat/Test+Char/TestCompiled/tests/testthat/test-TestCompiled.R b/tests/testthat/Test+Char/TestCompiled/tests/testthat/test-TestCompiled.R
@@ -1,4 +1,3 @@
-context("Test")
 test_that("compiled function simple works", {
   expect_equal(simple(1), 1)
   expect_equal(simple(2), 1)

diff --git a/tests/testthat/TestCompiled/tests/testthat/test-TestCompiled.R b/tests/testthat/TestCompiled/tests/testthat/test-TestCompiled.R
@@ -1,4 +1,3 @@
-context("Test")
 test_that("compiled function simple works", {
   expect_equal(simple(1), 1)
   expect_equal(simple(2), 1)

diff --git a/tests/testthat/TestS7/R/foo.R b/tests/testthat/TestS7/R/foo.R
@@ -37,3 +37,18 @@ method(inside, Range) <- function(x, y) {
 # enable usage of <S7_object>@name in package code
 #' @rawNamespace if (getRversion() < "4.3.0") importFrom("S7", "@")
 NULL
+
+# test external S3 generics
+method(format, Range) <- function(x) {
+  sprintf("Range(%s, %s)", x@start, x@end)
+}
+
+testthat_print <- new_external_generic("testthat", "testthat_print", "x")
+method(testthat_print, Range) <- function(x, ...) {
+  cat(format(x))
+  invisible(x)
+}
+
+.onLoad <- function(libname, pkgname) {
+  S7::methods_register()
+}
diff --git a/tests/testthat/TestS7/tests/testthat/test-foo.R b/tests/testthat/TestS7/tests/testthat/test-foo.R
@@ -14,3 +14,11 @@ test_that("Range works", {
   expect_equal(x@length, 5)
   expect_equal(x@end, 6)
 })
+
+test_that("Range methods work", {
+  x <- Range(1:10)
+  expect_equal(base::format(x), "Range(1, 10)")
+
+  # Test external generic method for testthat::testthat_print()
+  expect_equal(testthat::capture_output(x, print = TRUE), "Range(1, 10)")
+})
diff --git a/tests/testthat/_snaps/Compiled.md b/tests/testthat/_snaps/Compiled.md
@@ -0,0 +1,16 @@
+# Error thrown for missing gcov
+
+    Code
+      package_coverage("TestCompiled", relative_path = TRUE)
+    Condition
+      Error in `run_gcov()`:
+      ! gcov not found
+
+# Warning thrown for empty gcov output
+
+    Code
+      . <- package_coverage("TestCompiled", relative_path = TRUE)
+    Condition
+      Warning in `run_gcov()`:
+      parsed gcov output was empty
+
diff --git a/tests/testthat/_snaps/S7.md b/tests/testthat/_snaps/S7.md
@@ -0,0 +1,22 @@
+# S7 coverage is reported
+
+    Code
+      cov[, c("functions", "first_line", "last_line", "value")]
+    Output
+                                               functions first_line last_line value
+      1                   Range@properties$length$getter          9         9     1
+      2                   Range@properties$length$setter         11        11     1
+      3                   Range@properties$length$setter         12        12     1
+      4                                            Range         17        17     2
+      5                                  Range@validator         20        20     5
+      6                                  Range@validator         21        21     0
+      7                                  Range@validator         22        22     5
+      8                                  Range@validator         23        23     0
+      9                                  Range@validator         24        24     5
+      10                                 Range@validator         25        25     1
+      11                   method(inside, TestS7::Range)         34        34     1
+      12             method(base::format, TestS7::Range)         43        43     2
+      13 method(testthat::testthat_print, TestS7::Range)         48        48     1
+      14 method(testthat::testthat_print, TestS7::Range)         49        49     1
+      15                                         .onLoad         53        53     0
+
diff --git a/tests/testthat/test-Compiled.R b/tests/testthat/test-Compiled.R
@@ -1,4 +1,3 @@
-context("Compiled")
 test_that("Compiled code coverage is reported including code in headers", {
   skip_on_cran()
   skip_if(is_win_r41())
@@ -79,16 +78,31 @@ test_that("Compiled code coverage is reported under non-standard char's", {
 
 test_that("Error thrown for missing gcov", {
   skip_on_cran()
-  withr::with_options(c(covr.gcov=''),
-    expect_error(package_coverage("TestCompiled", relative_path=TRUE),
-                 "gcov not found")
-  )
+
+  withr::local_options(covr.gcov='')
+  expect_snapshot(package_coverage("TestCompiled", relative_path=TRUE), error = TRUE)
 })
 
 test_that("Warning thrown for empty gcov output", {
   skip_on_cran()
-  withr::with_options(c(covr.gcov_args='-n'),
-    expect_warning(package_coverage("TestCompiled", relative_path=TRUE),
-                   "parsed gcov output was empty")
+
+  withr::local_options(covr.gcov_args='-n')
+  expect_snapshot(
+    . <- package_coverage("TestCompiled", relative_path=TRUE),
+    transform = function(x) gsub(getwd(), "<wd>", x)
   )
 })
+
+test_that("tally_coverage includes compiled code", {
+  skip_on_cran()
+  skip_if(is_win_r41())
+
+  cov <- package_coverage(test_path("TestCompiled"))
+  tall <- tally_coverage(cov)
+
+  expect_named(tall, c("filename", "functions", "line", "value"))
+
+  expect_equal(
+    unique(tall$filename),
+    c("R/TestCompiled.R", "src/simple-header.h", "src/simple.cc", "src/simple4.cc"))
+})
diff --git a/tests/testthat/test-R6.R b/tests/testthat/test-R6.R
@@ -1,5 +1,3 @@
-context("R6")
-
 test_that("R6 methods coverage is reported", {
   # There is some sort of bug that causes this test to fail during R CMD check
   # in R-devel, not sure why, and can't reproduce it interactively

diff --git a/tests/testthat/test-RC.R b/tests/testthat/test-RC.R
@@ -1,4 +1,3 @@
-context("RC")
 test_that("RC methods coverage is reported", {
   cov <- as.data.frame(package_coverage("TestRC"))
 

diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R
@@ -1,4 +1,3 @@
-context("S4")
 test_that("S4 methods coverage is reported", {
   cov <- as.data.frame(package_coverage("TestS4"))
 

diff --git a/tests/testthat/test-S7.R b/tests/testthat/test-S7.R
@@ -1,5 +1,7 @@
 test_that("S7 coverage is reported", {
+  local_edition(3)
   cov <- as.data.frame(package_coverage(test_path("TestS7")))
 
-  expect_equal(cov$value, c(1, 1, 1, 1, 4, 0, 4, 0, 4, 1, 1))
+  expect_equal(cov$value, c(1, 1, 1, 2, 5, 0, 5, 0, 5, 1, 1, 2, 1, 1, 0))
+  expect_snapshot(cov[, c("functions", "first_line", "last_line", "value")])
 })
diff --git a/tests/testthat/test-box-R6.R b/tests/testthat/test-box-R6.R
@@ -1,5 +1,3 @@
-context("box-R6")
-
 loaded_mods <- loadNamespace("box")$loaded_mods
 rm(list = ls(loaded_mods), envir = loaded_mods)
 

diff --git a/tests/testthat/test-box.R b/tests/testthat/test-box.R
@@ -1,5 +1,3 @@
-context("box")
-
 loaded_mods <- loadNamespace("box")$loaded_mods
 rm(list = ls(loaded_mods), envir = loaded_mods)
 

diff --git a/tests/testthat/test-box_attached_modules_functions-R6.R b/tests/testthat/test-box_attached_modules_functions-R6.R
@@ -1,5 +1,3 @@
-context("box-attached-modules-functions-R6")
-
 loaded_mods <- loadNamespace("box")$loaded_mods
 rm(list = ls(loaded_mods), envir = loaded_mods)
 

diff --git a/tests/testthat/test-box_attached_modules_functions.R b/tests/testthat/test-box_attached_modules_functions.R
@@ -1,5 +1,3 @@
-context("box-attached-modules-functions")
-
 loaded_mods <- loadNamespace("box")$loaded_mods
 rm(list = ls(loaded_mods), envir = loaded_mods)
 

diff --git a/tests/testthat/test-braceless.R b/tests/testthat/test-braceless.R
@@ -1,5 +1,3 @@
-context("braceless")
-
 test_that("if", {
   f <-
 'f <- function(x) {

diff --git a/tests/testthat/test-cobertura.R b/tests/testthat/test-cobertura.R
@@ -1,5 +1,3 @@
-context("cobertura_export")
-
 test_that("it works with coverage objects", {
   tmp <- tempfile()
   cov <- package_coverage(test_path("TestSummary"))

diff --git a/tests/testthat/test-codecov.R b/tests/testthat/test-codecov.R
@@ -1,4 +1,3 @@
-context("codecov")
 ci_vars <- c(
   "APPVEYOR" = NA,
   "APPVEYOR_ACCOUNT_NAME" = NA,

diff --git a/tests/testthat/test-corner-cases.R b/tests/testthat/test-corner-cases.R
@@ -1,5 +1,3 @@
-context("corner-cases")
-
 test_that("corner-cases are handled as expected", {
   expect_warning(withr::with_output_sink(tempfile(), {
     cov <- file_coverage("corner-cases.R", "corner-cases-test.R")

diff --git a/tests/testthat/test-coveralls.R b/tests/testthat/test-coveralls.R
@@ -1,5 +1,3 @@
-context("coveralls")
-
 ci_vars <- c(
   "APPVEYOR" = NA,
   "APPVEYOR_BUILD_NUMBER" = NA,

diff --git a/tests/testthat/test-covr.R b/tests/testthat/test-covr.R
@@ -1,4 +1,3 @@
-context("function_coverage")
 test_that("function_coverage", {
 
   withr::with_options(c(keep.source = TRUE), {
@@ -59,7 +58,6 @@ test_that("duplicated first_line", {
   })
 })
 
-context("trace_calls")
 test_that("trace calls handles all possibilities", {
   expr <- expression(y <- x * 10)
 
@@ -68,7 +66,6 @@ test_that("trace calls handles all possibilities", {
   expect_equal(trace_calls(list(expr)), list(expr))
 })
 
-context("show_failures")
 test_that("show_failures shows as much text as it can from the end", {
   withr::with_options(c(warning.length = 300), {
     td <- tempfile()