generalize method() to support S3 and S4 generics

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)
   }

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
 }

tests/testthat/_snaps/method-introspect.md

@@ -4,7 +4,7 @@
       method(print, 1)
     Condition
       Error:
-      ! `generic` must be a <S7_generic>, not a <closure>
+      ! 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 <double>.
     Code
       foo <- new_generic("foo", "x")
       method(foo)