diff --git a/R/external-generic.R b/R/external-generic.R index 3bc9cdd9..ddcf663f 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -40,6 +40,20 @@ new_external_generic <- function(package, name, dispatch_args, version = NULL) { out } +as_external_generic <- function(x) { + if (is_S7_generic(x)) { + pkg <- package_name(x) + new_external_generic(pkg, x@name, x@dispatch_args) + } else if (is_external_generic(x)) { + x + } else if (is_S3_generic(x)) { + pkg <- package_name(x) + new_external_generic(pkg, x$name, "__S3__") + } else if (is_S4_generic(x)) { + new_external_generic(x@package, as.vector(x@generic), x@signature) + } +} + #' @export print.S7_external_generic <- function(x, ...) { cat( diff --git a/R/generic-spec.R b/R/generic-spec.R index 24348a3f..5d82e493 100644 --- a/R/generic-spec.R +++ b/R/generic-spec.R @@ -1,5 +1,9 @@ +is_generic <- function(x) { + is_S7_generic(x) || is_external_generic(x) || is_S3_generic(x) || is_S4_generic(x) +} + as_generic <- function(x) { - if (is_generic(x) || is_external_generic(x) || is_S4_generic(x)) { + if (is_generic(x)) { x } else if (is.function(x)) { as_S3_generic(x) @@ -57,13 +61,13 @@ package_name <- function(f) { } generic_n_dispatch <- function(x) { - if (is_S3_generic(x)) { - 1 - } else if (is_generic(x)) { + if (is_S7_generic(x)) { length(x@dispatch_args) } else if (is_external_generic(x)) { length(x$dispatch_args) - } else if (methods::is(x, "genericFunction")) { + } else if (is_S3_generic(x)) { + 1 + } else if (is_S4_generic(x)) { length(x@signature) } else { stop(sprintf("Invalid input %", obj_desc(x)), call. = FALSE) diff --git a/R/method-register.R b/R/method-register.R index 2d3548a9..ba0a535c 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -68,7 +68,7 @@ register_method <- function(generic, signature <- as_signature(signature, generic) # Register in current session - if (is_generic(generic)) { + if (is_S7_generic(generic)) { check_method(method, generic, name = method_name(generic, signature)) register_S7_method(generic, signature, method) } else if (is_external_generic(generic)) { @@ -79,29 +79,18 @@ register_method <- function(generic, } } else if (is_S3_generic(generic)) { register_S3_method(generic, signature, method) - } else if (inherits(generic, "genericFunction")) { + } else if (is_S4_generic(generic)) { register_S4_method(generic, signature, method, env) } # if we're inside a package, we also need to be able register methods # when the package is loaded if (!is.null(package) && !is_local_generic(generic, package)) { - if (is_generic(generic)) { - pkg <- package_name(generic) - generic <- new_external_generic(pkg, generic@name, generic@dispatch_args) - } else if (is_external_generic(generic)) { - # already in correct form - } else if (is_S3_generic(generic)) { - pkg <- package_name(generic) - generic <- new_external_generic(pkg, generic$name, NULL) - } else if (is_S4_generic(generic)) { - generic <- new_external_generic(generic@package, generic@generic, NULL) - } - + generic <- as_external_generic(generic) external_methods_add(package, generic, signature, method) } - invisible() + invisible(generic) } register_S3_method <- function(generic, signature, method) { diff --git a/R/zzz.R b/R/zzz.R index a68c29e3..b4f463e5 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -98,7 +98,7 @@ S7_generic <- new_class( parent = class_function ) methods::setOldClass(c("S7_generic", "function", "S7_object")) -is_generic <- function(x) inherits(x, "S7_generic") +is_S7_generic <- function(x) inherits(x, "S7_generic") S7_method <- new_class("S7_method", parent = class_function, diff --git a/tests/testthat/test-external-generic.R b/tests/testthat/test-external-generic.R index 7a832a53..22bcd626 100644 --- a/tests/testthat/test-external-generic.R +++ b/tests/testthat/test-external-generic.R @@ -27,6 +27,32 @@ test_that("displays nicely", { }) }) +test_that("can convert existing generics to external", { + foo_S7 <- new_generic("foo_S7", "x") + env <- new.env() + env$.packageName <- "test" + environment(foo_S7) <- env + + expect_equal( + as_external_generic(foo_S7), + new_external_generic("test", "foo_S7", "x") + ) + + foo_ext <- new_external_generic("pkg", "foo", "x") + expect_equal(as_external_generic(foo_ext), foo_ext) + + expect_equal( + as_external_generic(as_S3_generic(sum)), + new_external_generic("base", "sum", "__S3__") + ) + + methods::setGeneric("foo_S4", function(x) {}) + expect_equal( + as_external_generic(foo_S4), + new_external_generic("S7", "foo_S4", "x") + ) +}) + test_that("new_method works with both hard and soft dependencies", { # NB: Relies on installed S7