diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index ee65ccb5..5df3051d 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -5,6 +5,7 @@ # check-standard.yaml is likely a better choice. # usethis::use_github_action("check-standard") will install it. on: + workflow_dispatch: push: branches: [main, master] pull_request: diff --git a/R/S7.R b/R/S7.R index eafa215a..80445360 100644 --- a/R/S7.R +++ b/R/S7.R @@ -1,5 +1,5 @@ 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) @@ -7,6 +7,21 @@ replacements_S7 <- function(env) { 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/tests/testthat/TestS7/R/foo.R b/tests/testthat/TestS7/R/foo.R index 13c4a6a6..4d501174 100644 --- 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 @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 index 0af07179..53d1ef91 100644 --- 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/S7.md b/tests/testthat/_snaps/S7.md new file mode 100644 index 00000000..50a3e336 --- /dev/null +++ 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-S7.R b/tests/testthat/test-S7.R index 0ba7a8b5..c5ce0dbc 100644 --- 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")]) })