From 87023d88b44f40397503b4605b505682c3f6d8ec Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Thu, 29 Aug 2024 20:56:28 -0700 Subject: [PATCH 1/4] generalize method() to support S3 and S4 generics --- R/generic-spec.R | 26 ++++++++++++++++++++++---- R/method-introspect.R | 42 ++++++++++++++++++++++++++++++++++++------ 2 files changed, 58 insertions(+), 10 deletions(-) diff --git a/R/generic-spec.R b/R/generic-spec.R index 5d82e493..bccf2d85 100644 --- a/R/generic-spec.R +++ b/R/generic-spec.R @@ -61,14 +61,32 @@ 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)) { + names(formals(x$generic))[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..9d8948e8 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 <- 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) + 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 } From ead7b2f661bc22dadd9a2c9d59d16a5f44bc8454 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 30 Aug 2024 04:23:53 -0700 Subject: [PATCH 2/4] support primitives for S3 generics --- R/generic-spec.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/generic-spec.R b/R/generic-spec.R index bccf2d85..5cc704d5 100644 --- a/R/generic-spec.R +++ b/R/generic-spec.R @@ -70,7 +70,10 @@ generic_dispatch_args <- function(x) { } else if (is_external_generic(x)) { x$dispatch_args } else if (is_S3_generic(x)) { - names(formals(x$generic))[1L] + 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 { From daf1af872fd0c6343c451725b9075fe5f5e81d21 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 30 Aug 2024 04:24:11 -0700 Subject: [PATCH 3/4] qualify calls to unimported symbols --- R/method-introspect.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/method-introspect.R b/R/method-introspect.R index 9d8948e8..f1916c5f 100644 --- a/R/method-introspect.R +++ b/R/method-introspect.R @@ -68,7 +68,7 @@ select_S3_method <- function(generic, dispatch) { classes <- c(dispatch[[1L]], "default") for (class in classes) { - method <- getS3method(generic$name, class, optional = TRUE) + method <- utils::getS3method(generic$name, class, optional = TRUE) if (!is.null(method)) return(method) } @@ -78,7 +78,7 @@ select_S3_method <- function(generic, dispatch) { select_S4_method <- function(generic, dispatch) { sig <- vapply(dispatch, `[`, character(1L), 1L) - selectMethod(generic, sig, optional = TRUE) + methods::selectMethod(generic, sig, optional = TRUE) } #' Explain method dispatch From 8c22d16a240c8bac321611474b8374ba434dd5b9 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Fri, 30 Aug 2024 04:39:01 -0700 Subject: [PATCH 4/4] update snap: method(print, 1) fails because signature is not S7 --- tests/testthat/_snaps/method-introspect.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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)