diff --git a/DESCRIPTION b/DESCRIPTION index 35845bed..d72b1226 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -56,6 +56,7 @@ Imports: yaml Suggests: R6, + S7 (>= 0.2.0), curl, knitr, rmarkdown, diff --git a/R/S7.R b/R/S7.R new file mode 100644 index 00000000..eafa215a --- /dev/null +++ b/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 + ) +} diff --git a/R/covr.R b/R/covr.R index 7510db65..6117ad9b 100644 --- a/R/covr.R +++ b/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))) diff --git a/tests/testthat/TestS7/DESCRIPTION b/tests/testthat/TestS7/DESCRIPTION new file mode 100644 index 00000000..33f0c65f --- /dev/null +++ b/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", , "james.f.hester@gmail.com", 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 diff --git a/tests/testthat/TestS7/NAMESPACE b/tests/testthat/TestS7/NAMESPACE new file mode 100644 index 00000000..3e02b753 --- /dev/null +++ b/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) diff --git a/tests/testthat/TestS7/R/foo.R b/tests/testthat/TestS7/R/foo.R new file mode 100644 index 00000000..13c4a6a6 --- /dev/null +++ b/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 @name in package code +#' @rawNamespace if (getRversion() < "4.3.0") importFrom("S7", "@") +NULL diff --git a/tests/testthat/TestS7/tests/testthat.R b/tests/testthat/TestS7/tests/testthat.R new file mode 100644 index 00000000..e4a3e859 --- /dev/null +++ b/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") diff --git a/tests/testthat/TestS7/tests/testthat/test-foo.R b/tests/testthat/TestS7/tests/testthat/test-foo.R new file mode 100644 index 00000000..0af07179 --- /dev/null +++ b/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 ") + + 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) +}) diff --git a/tests/testthat/test-S7.R b/tests/testthat/test-S7.R new file mode 100644 index 00000000..0ba7a8b5 --- /dev/null +++ b/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)) +})