Make it possible to unregister a method (#639)

I'm now more sceptical about this approach because S3 doesn't provide any way to unregister a method, and S4's `removeMethod()` explicitly advises against using it.

Fixes #613

Author: hadley

NEWS.md

@@ -1,5 +1,7 @@
 # S7 (development version)
 
+* `method<-` now accepts `NULL` to unregister an existing method, e.g. `method(foo, class_character) <- NULL` (#613).
+* `new_object()` no longer materialises ALTREP parent values (e.g. `seq_len()`), so constructing an S7 object that wraps a large compact integer sequence is now O(1) in memory instead of O(n) (@kschaubroeck, #607).
 * Internal changes to support R-devel (4.6) (#592, #593, #598, #600).
 * Method dispatch on `class_missing` now correctly handles missing arguments forwarded through a wrapper functions (#595).
 * `S7_error_method_not_found` now has a correct class vector without a duplicate `"error"` entry (@jjjermiah, #604).

R/external-generic.R

@@ -155,6 +155,19 @@ external_methods_add <- function(package, generic, signature, method) {
   invisible()
 }
 
+external_methods_remove <- function(package, generic, signature) {
+  tbl <- S7_methods_table(package)
+  if (length(tbl) == 0) {
+    return(invisible())
+  }
+
+  keep <- !vlapply(tbl, function(x) {
+    identical(x$generic, generic) && identical(x$signature, signature)
+  })
+  S7_methods_table(package) <- tbl[keep]
+  invisible()
+}
+
 # Store external methods in an attribute of the S3 methods table since
 # this mutable object is present in all packages.
 

R/generic.R

@@ -228,3 +228,22 @@ generic_add_method <- function(generic, signature, method) {
     }
   }
 }
+
+generic_remove_method <- function(generic, signature) {
+  p_tbl <- generic@methods
+  chr_signature <- vcapply(signature, class_register)
+
+  for (i in seq_along(chr_signature)) {
+    class_name <- chr_signature[[i]]
+    if (i != length(chr_signature)) {
+      tbl <- p_tbl[[class_name]]
+      if (is.null(tbl)) {
+        return(invisible())
+      }
+      p_tbl <- tbl
+    } else if (exists(class_name, envir = p_tbl, inherits = FALSE)) {
+      rm(list = class_name, envir = p_tbl)
+    }
+  }
+  invisible()
+}

R/method-register.R

@@ -39,7 +39,7 @@
 #'
 #'   The same rules apply to S4 generics as S7 generics.
 #' @param value A function that implements the generic specification for the
-#'   given `signature`.
+#'   given `signature`, or `NULL` to unregister an existing method.
 #' @returns The `generic`, invisibly.
 #' @export
 #' @examples
@@ -54,8 +54,15 @@
 #'
 #' # Using a generic calls the methods automatically
 #' bizarro(head(mtcars))
+#'
+#' # Unregister a method by assigning `NULL`
+#' method(bizarro, class_numeric) <- NULL
 `method<-` <- function(generic, signature, value) {
-  register_method(generic, signature, value, env = parent.frame())
+  if (is.null(value)) {
+    unregister_method(generic, signature, env = parent.frame())
+  } else {
+    register_method(generic, signature, value, env = parent.frame())
+  }
   invisible(generic)
 }
 
@@ -96,6 +103,38 @@ register_method <- function(
   invisible(generic)
 }
 
+unregister_method <- function(
+  generic,
+  signature,
+  env = parent.frame(),
+  package = packageName(env)
+) {
+  generic <- as_generic(generic)
+  signature <- as_signature(signature, generic)
+
+  if (is_external_generic(generic) && isNamespaceLoaded(generic$package)) {
+    generic <- as_generic(getFromNamespace(generic$name, generic$package))
+  }
+
+  # Unregister in current session
+  if (is_S7_generic(generic)) {
+    unregister_S7_method(generic, signature)
+  } else if (is_S3_generic(generic)) {
+    stop("Can't unregister methods for S3 generics", call. = FALSE)
+  } else if (is_S4_generic(generic)) {
+    stop("Can't unregister methods for S4 generics", call. = FALSE)
+  }
+
+  # If we're inside a package, also remove from the deferred external
+  # methods table so the method isn't re-registered on package load.
+  if (!is.null(package) && !is_local_generic(generic, package)) {
+    generic <- as_external_generic(generic)
+    external_methods_remove(package, generic, signature)
+  }
+
+  invisible(generic)
+}
+
 register_S3_method <- function(
   generic,
   signature,
@@ -134,6 +173,14 @@ register_S7_method <- function(generic, signature, method) {
   invisible()
 }
 
+unregister_S7_method <- function(generic, signature) {
+  signatures <- flatten_signature(signature)
+  for (signature in signatures) {
+    generic_remove_method(generic, signature)
+  }
+  invisible()
+}
+
 flatten_signature <- function(signature) {
   # Unpack unions
   sig_is_union <- vlapply(signature, is_union)
@@ -288,6 +335,7 @@ register_S4_method <- function(
   S4_signature <- lapply(signature, S4_class, S4_env = S4_env)
   methods::setMethod(generic, S4_signature, method, where = S4_env)
 }
+
 S4_class <- function(x, S4_env) {
   switch(
     class_type(x),

man/method-set.Rd

@@ -37,6 +37,48 @@
        * An S4 class object
        * A base class
 
+# method unregistration / removes S7 method via NULL assignment
+
+    Code
+      foo("x")
+    Condition
+      Error:
+      ! Can't find method for `foo(<character>)`.
+
+# method unregistration / removes method with multi-dispatch signature
+
+    Code
+      foo(A(), B())
+    Condition
+      Error:
+      ! Can't find method for generic `foo(x, y)`:
+      - x: <S7::A>
+      - y: <S7::B>
+
+# method unregistration / errors when unregistering from an S3 generic
+
+    Code
+      method(sum, foo) <- NULL
+    Condition
+      Error:
+      ! Can't unregister methods for S3 generics
+
+---
+
+    Code
+      method(base_sum, foo) <- NULL
+    Condition
+      Error:
+      ! Can't unregister methods for S3 generics
+
+# method unregistration / errors when unregistering from an S4 generic
+
+    Code
+      method(removeS4, S4foo) <- NULL
+    Condition
+      Error:
+      ! Can't unregister methods for S4 generics
+
 # as_signature() / accepts a length-1 list for single dispatch (#555)
 
     Code

tests/testthat/_snaps/method-register.md

@@ -18,6 +18,25 @@ test_that("can get and append methods", {
   )
 })
 
+test_that("can remove methods", {
+  external_methods_reset("S7")
+  on.exit(external_methods_reset("S7"), add = TRUE)
+
+  bar <- new_external_generic("foo", "bar", "x")
+  baz <- new_external_generic("foo", "baz", "x")
+  external_methods_add("S7", bar, list("A"), function() "a")
+  external_methods_add("S7", baz, list("B"), function() "b")
+  expect_length(S7_methods_table("S7"), 2)
+
+  external_methods_remove("S7", bar, list("A"))
+  expect_length(S7_methods_table("S7"), 1)
+  expect_equal(S7_methods_table("S7")[[1]]$generic, baz)
+
+  # No-op when entry doesn't exist
+  external_methods_remove("S7", bar, list("A"))
+  expect_length(S7_methods_table("S7"), 1)
+})
+
 test_that("displays nicely", {
   bar <- new_external_generic("foo", "bar", "x")
   on.exit(external_methods_reset("S7"), add = TRUE)

tests/testthat/test-external-generic.R

@@ -125,6 +125,67 @@ describe("method registration", {
   })
 })
 
+describe("method unregistration", {
+  it("removes S7 method via NULL assignment", {
+    foo <- new_generic("foo", "x")
+    method(foo, class_character) <- function(x) "c"
+    method(foo, class_integer) <- function(x) "i"
+    expect_length(methods(foo), 2)
+
+    method(foo, class_character) <- NULL
+    expect_length(methods(foo), 1)
+    expect_equal(foo(1L), "i")
+    expect_snapshot(foo("x"), error = TRUE)
+  })
+
+  it("removes each method in a union signature", {
+    foo <- new_generic("foo", "x")
+    method(foo, class_numeric) <- function(x) "n"
+    expect_length(methods(foo), 2)
+
+    method(foo, class_numeric) <- NULL
+    expect_length(methods(foo), 0)
+  })
+
+  it("removes method with multi-dispatch signature", {
+    foo <- new_generic("foo", c("x", "y"))
+    A <- new_class("A")
+    B <- new_class("B")
+    method(foo, list(A, B)) <- function(x, y) "AB"
+    expect_equal(foo(A(), B()), "AB")
+
+    method(foo, list(A, B)) <- NULL
+    expect_snapshot(foo(A(), B()), error = TRUE)
+  })
+
+  it("is a silent no-op when the method doesn't exist", {
+    foo <- new_generic("foo", "x")
+    expect_silent(method(foo, class_character) <- NULL)
+    expect_length(methods(foo), 0)
+  })
+
+  it("errors when unregistering from an S3 generic", {
+    foo <- new_class("foo")
+    method(sum, foo) <- function(x, ...) "foo"
+    expect_snapshot(method(sum, foo) <- NULL, error = TRUE)
+
+    # External generics that resolve to S3 generics also error
+    base_sum <- new_external_generic("base", "sum", "x")
+    expect_snapshot(method(base_sum, foo) <- NULL, error = TRUE)
+  })
+
+  it("errors when unregistering from an S4 generic", {
+    methods::setGeneric("removeS4", function(x) standardGeneric("removeS4"))
+    on.exit(suppressMessages(methods::removeGeneric("removeS4")), add = TRUE)
+    S4foo <- new_class("S4foo", package = NULL)
+    S4_register(S4foo)
+    on.exit(S4_remove_classes("S4foo"), add = TRUE)
+
+    method(removeS4, S4foo) <- function(x) "foo"
+    expect_snapshot(method(removeS4, S4foo) <- NULL, error = TRUE)
+  })
+})
+
 describe("as_signature()", {
   it("returns a list that matches length of dispatch args", {
     foo1 <- new_generic("foo1", "x")