diff --git a/R/generic-spec.R b/R/generic-spec.R index 5d82e493..5cc704d5 100644 --- a/R/generic-spec.R +++ b/R/generic-spec.R @@ -61,14 +61,35 @@ package_name <- function(f) { } generic_n_dispatch <- function(x) { + length(generic_dispatch_args(x)) +} + +generic_dispatch_args <- function(x) { + if (is_S7_generic(x)) { + x@dispatch_args + } else if (is_external_generic(x)) { + x$dispatch_args + } else if (is_S3_generic(x)) { + fun <- x$generic + if (is.null(formals(fun))) + methods::getGeneric(fun)@signature[1L] + else names(formals(fun))[1L] + } else if (is_S4_generic(x)) { + x@signature + } else { + stop(sprintf("Invalid input %", obj_desc(x)), call. = FALSE) + } +} + +generic_name <- function(x) { if (is_S7_generic(x)) { - length(x@dispatch_args) + x@name } else if (is_external_generic(x)) { - length(x$dispatch_args) + x$name } else if (is_S3_generic(x)) { - 1 + x$name } else if (is_S4_generic(x)) { - length(x@signature) + x@generic } else { stop(sprintf("Invalid input %", obj_desc(x)), call. = FALSE) } diff --git a/R/method-introspect.R b/R/method-introspect.R index 40e073e7..f1916c5f 100644 --- a/R/method-introspect.R +++ b/R/method-introspect.R @@ -36,21 +36,51 @@ #' try(method(bizarro, class = class_data.frame)) #' try(method(bizarro, object = "x")) method <- function(generic, class = NULL, object = NULL) { - check_is_S7(generic, S7_generic) + generic <- as_generic(generic) dispatch <- as_dispatch(generic, class = class, object = object) - method <- .Call(method_, generic, dispatch, environment(), FALSE) - if (!is.null(method)) { - return(method) + if (is_S7_generic(generic)) { + method <- select_S7_method(generic, dispatch) + } else if (is_S3_generic(generic)) { + method <- select_S3_method(generic, dispatch) + } else if (is_S4_generic(generic)) { + method <- select_S4_method(generic, dispatch) } + + if (!is.null(method)) + return(method) # can't rely on usual error mechanism because it involves looking up # argument values in the dispatch environment, which doesn't exist here types <- error_types(generic, class = class, object = object) - msg <- method_lookup_error_message(generic@name, types) + msg <- method_lookup_error_message(generic_name(generic), types) stop(msg, call. = FALSE) } +select_S7_method <- function(generic, dispatch) { + .Call(method_, generic, dispatch, environment(), FALSE) +} + +select_S3_method <- function(generic, dispatch) { + if (length(dispatch) != 1L) { + stop("S3 generics support only single dispatch") + } + + classes <- c(dispatch[[1L]], "default") + for (class in classes) { + method <- utils::getS3method(generic$name, class, optional = TRUE) + if (!is.null(method)) + return(method) + } + + NULL +} + +select_S4_method <- function(generic, dispatch) { + sig <- vapply(dispatch, `[`, character(1L), 1L) + methods::selectMethod(generic, sig, optional = TRUE) +} + #' Explain method dispatch #' #' @description @@ -141,6 +171,6 @@ error_types <- function(generic, class = NULL, object = NULL) { signature <- as_signature(class, generic) types <- vcapply(signature, class_desc) } - names(types) <- generic@dispatch_args + names(types) <- generic_dispatch_args(generic) types } diff --git a/tests/testthat/_snaps/method-introspect.md b/tests/testthat/_snaps/method-introspect.md index dfd43387..559184af 100644 --- a/tests/testthat/_snaps/method-introspect.md +++ b/tests/testthat/_snaps/method-introspect.md @@ -4,7 +4,7 @@ method(print, 1) Condition Error: - ! `generic` must be a , not a + ! Can't convert `signature` to a valid class. Class specification must be an S7 class object, the result of `new_S3_class()`, an S4 class object, or a base class, not a . Code foo <- new_generic("foo", "x") method(foo)