Initial work on S7 support for covr (#580)

* Initial work on S7 support for covr

* fix prop replacements in `traverse_S7_class`

* handle multi-dispatch generics in `traverse_S7_generic()`

* add missing `test_path()` in tests

* update expected validator run counts in tests: 3 -> 4

* CamelCase S7 class name

* Fix package-name / dir-name mismatch

* revert `test_path()` usage

* one more test pkgname fix

* add S7 to Suggests

* Revert "update expected validator run counts in tests: 3 -> 4"

This reverts commit 8058180.

* Use `S7::prop()` instead of `@` for R oldrel compat

* import backported `@` in TestS7 package

* stray `@` -> `S7::prop()` replacement

* return of `test_path()`

* Class validator runs 4 times, not 3

* Install S7 >= 0.2.0

* better names in coverage report

Give the `cov$functions` columns more informative names, for interactive development. E.g.:

> cov$functions
 [1] "Range@properties$length$getter"
 [2] "Range@properties$length$setter"
 [3] "Range@properties$length$setter"
 [4] "Range@constructor"
 [5] "Range@validator"
 [6] "Range@validator"
 [7] "Range@validator"
 [8] "Range@validator"
 [9] "Range@validator"
[10] "Range@validator"
[11] "method(inside, TestS7::Range)"

* Apply suggestions from code review

Co-authored-by: Jim Hester <[email protected]>

---------

Co-authored-by: Tomasz Kalinowski <[email protected]>
Co-authored-by: Tomasz Kalinowski <[email protected]>

DESCRIPTION

@@ -56,6 +56,7 @@ Imports:
     yaml
 Suggests:
     R6,
+    S7 (>= 0.2.0),
     curl,
     knitr,
     rmarkdown,

R/S7.R

@@ -0,0 +1,53 @@
+replacements_S7 <- function(env) {
+  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)
+      }
+    }))
+}
+
+traverse_S7_generic <- function(x) {
+  # Each binding in the environment at x@methods is either a function or, for
+  # generics that dispatch on multiple arguments, another environment.
+  get_replacements <- function(env) {
+    replacements <- lapply(names(env), function(name) {
+      target_value <- get(name, envir = env)
+      if (is.environment(target_value)) {
+        # Recurse for nested environments
+        get_replacements(target_value)
+      } else {
+        name <- as.character(attr(target_value, "name", exact = TRUE) %||% name)
+        list(replacement(name, env, target_value))
+      }
+    })
+    unlist(replacements, recursive = FALSE, use.names = FALSE)
+  }
+  get_replacements(S7::prop(x, "methods"))
+}
+
+traverse_S7_class <- function(x) {
+  class_name <- S7::prop(x, "name")
+  prop_fun_replacements <-
+    lapply(S7::prop(x, "properties"), function(p) {
+      lapply(c("getter", "setter", "validator"), function(prop_fun) {
+        if (!is.null(p[[prop_fun]])) {
+          replacement(
+            sprintf("%s@properties$%s$%s", class_name, p$name, prop_fun),
+            env = p,
+            target_value = p[[prop_fun]])
+        }
+      })
+  })
+  prop_fun_replacements <- unlist(prop_fun_replacements, recursive = FALSE, use.names = FALSE)
+
+  c(
+    list(
+      replacement(paste0(class_name, "@constructor"), env = x, target_value = S7::prop(x, "constructor")),
+      replacement(paste0(class_name, "@validator")  , env = x, target_value = S7::prop(x, "validator"))
+    ),
+    prop_fun_replacements
+  )
+}

R/covr.R

@@ -93,6 +93,7 @@ trace_environment <- function(env) {
       replacements_S4(env),
       replacements_RC(env),
       replacements_R6(env),
+      replacements_S7(env),
       replacements_box(env),
       lapply(ls(env, all.names = TRUE), replacement, env = env)))
 

tests/testthat/TestS7/DESCRIPTION

@@ -0,0 +1,17 @@
+Package: TestS7
+Title: What the Package Does (One Line, Title Case)
+Version: 0.0.0.9000
+Authors@R: c(
+    person("Jim", "Hester", , "[email protected]", role = c("aut", "cre"),
+           comment = c(ORCID = "0000-0002-2739-7082")),
+    person("RStudio", role = c("cph", "fnd"))
+  )
+Description: What the package does (one paragraph).
+License: MIT + file LICENSE
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.3.2
+Imports: S7
+Suggests: 
+    testthat (>= 3.0.0)
+Config/testthat/edition: 3

tests/testthat/TestS7/NAMESPACE

@@ -0,0 +1,6 @@
+# Generated by roxygen2: do not edit by hand
+
+export(Range)
+export(inside)
+if (getRversion() < "4.3.0") importFrom("S7", "@")
+import(S7)

tests/testthat/TestS7/R/foo.R

@@ -0,0 +1,39 @@
+#' @import S7
+#' @export
+Range <- new_class("Range",
+  properties = list(
+    start = class_double,
+    end = class_double,
+    length = new_property(
+      class = class_double,
+      getter = function(self) self@end - self@start,
+      setter = function(self, value) {
+        self@end <- self@start + value
+        self
+      }
+    )
+  ),
+  constructor = function(x) {
+    new_object(S7_object(), start = as.double(min(x, na.rm = TRUE)), end = as.double(max(x, na.rm = TRUE)))
+  },
+  validator = function(self) {
+    if (length(self@start) != 1) {
+      "@start must be length 1"
+    } else if (length(self@end) != 1) {
+      "@end must be length 1"
+    } else if (self@end < self@start) {
+      "@end must be greater than or equal to @start"
+    }
+  }
+)
+
+#' @export
+inside <- new_generic("inside", "x")
+
+method(inside, Range) <- function(x, y) {
+  y >= x@start & y <= x@end
+}
+
+# enable usage of <S7_object>@name in package code
+#' @rawNamespace if (getRversion() < "4.3.0") importFrom("S7", "@")
+NULL

tests/testthat/TestS7/tests/testthat.R

@@ -0,0 +1,12 @@
+# 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
+
+library(testthat)
+library(TestS7)
+
+test_check("TestS7")

tests/testthat/TestS7/tests/testthat/test-foo.R

@@ -0,0 +1,16 @@
+test_that("Range works", {
+  x <- Range(1:10)
+
+  x@end <- 20
+
+  expect_error(x@end <- "x", "must be <double>")
+
+  expect_error(x@end <- -1, "greater than or equal")
+
+  expect_equal(inside(x, c(0, 5, 10, 15)), c(FALSE, TRUE, TRUE, TRUE))
+
+  x@length <- 5
+
+  expect_equal(x@length, 5)
+  expect_equal(x@end, 6)
+})

tests/testthat/test-S7.R

@@ -0,0 +1,5 @@
+test_that("S7 coverage is reported", {
+  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))
+})