Refactor Ops tests (#360)

NEWS.md

@@ -1,5 +1,7 @@
 # S7 (development version)
 
+* Can create multimethods that dispatch on `NULL`.
+
 # S7 0.1.1
 
 * Classes get a more informative print method (#346).

R/method-register.R

@@ -156,7 +156,7 @@ as_signature <- function(signature, generic) {
   } else {
     check_signature_list(signature, n)
     for (i in seq_along(signature)) {
-      signature[[i]] <- as_class(signature[[i]], arg = sprintf("signature[[%i]]", i))
+      signature[i] <- list(as_class(signature[[i]], arg = sprintf("signature[[%i]]", i)))
     }
     new_signature(signature)
   }

tests/testthat/helper.R

@@ -39,3 +39,26 @@ quick_test_enable <- function() {
 scrub_environment <- function(x) {
   gsub("environment: 0x[0-9a-f]+", "environment: 0x0", x)
 }
+
+local_methods <- function(..., frame = parent.frame()) {
+  generics <- list(...)
+  methods <- lapply(generics, function(x) as.list(x@methods))
+  defer(for(i in seq_along(methods)) {
+    env <- generics[[i]]@methods
+    rm(list = ls(envir = env), envir = env)
+    list2env(methods[[i]], envir = env)
+  }, frame = frame)
+  invisible()
+}
+
+local_S4_class <- function(name, ..., env = parent.frame()) {
+  out <- methods::setClass(name , contains = "character")
+  defer(S4_remove_classes(name, env), env)
+  out
+}
+
+# Lightweight equivalent of withr::defer()
+defer <- function(expr, frame = parent.frame(), after = FALSE) {
+  thunk <- as.call(list(function() expr))
+  do.call(on.exit, list(thunk, TRUE, after), envir = frame)
+}

tests/testthat/test-convert.R

@@ -1,4 +1,5 @@
 test_that("can register convert methods", {
+  local_methods(convert)
   converttest <- new_class("converttest")
   method(convert, list(converttest, class_character)) <- function(from, to, ...) "c"
   method(convert, list(converttest, class_integer)) <- function(from, to, ...) "i"
@@ -12,6 +13,7 @@ test_that("can register convert methods", {
 })
 
 test_that("doesn't convert to subclass", {
+  local_methods(convert)
   converttest1 <- new_class("converttest1")
   converttest2 <- new_class("converttest2", converttest1)
 
@@ -20,6 +22,8 @@ test_that("doesn't convert to subclass", {
 })
 
 describe("fallback convert", {
+  local_methods(convert)
+
   it("can convert to own class", {
     foo1 <- new_class("foo1")
     foo2 <- new_class("foo2", foo1)

tests/testthat/test-method-ops.R

@@ -1,60 +1,91 @@
-test_that("Ops generics dispatch to S7 methods", {
+test_that("Ops generics dispatch to S7 methods for S7 classes", {
+  local_methods(base_ops[["+"]])
+  foo1 <- new_class("foo1")
+  foo2 <- new_class("foo2")
+
+  method(`+`, list(foo1, foo1)) <- function(e1, e2) "foo1-foo1"
+  method(`+`, list(foo1, foo2)) <- function(e1, e2) "foo1-foo2"
+  method(`+`, list(foo2, foo1)) <- function(e1, e2) "foo2-foo1"
+  method(`+`, list(foo2, foo2)) <- function(e1, e2) "foo2-foo2"
+
+  expect_equal(foo1() + foo1(), "foo1-foo1")
+  expect_equal(foo1() + foo2(), "foo1-foo2")
+  expect_equal(foo2() + foo1(), "foo2-foo1")
+  expect_equal(foo2() + foo2(), "foo2-foo2")
+})
+
+test_that("Ops generics dispatch to S3 methods", {
   skip_if(getRversion() < "4.3")
+  local_methods(base_ops[["+"]])
+
+  foo <- new_class("foo")
+  method(`+`, list(class_factor, foo)) <- function(e1, e2) "factor-foo"
+  method(`+`, list(foo, class_factor)) <- function(e1, e2) "foo-factor"
+
+  expect_equal(foo() + factor(), "foo-factor")
+  expect_equal(factor() + foo(), "factor-foo")
+
+  # Even if custom method exists
+  foo_S3 <- structure(list(), class = "foo_S3")
+  assign("+.foo_S3", function(e1, e2) stop("Failure!"), envir = globalenv())
+  defer(rm("+.foo_S3", envir = globalenv()))
+
+  method(`+`, list(new_S3_class("foo_S3"), foo)) <- function(e1, e2) "S3-S7"
+  method(`+`, list(foo, new_S3_class("foo_S3"))) <- function(e1, e2) "S7-S3"
+
+  expect_equal(foo() + foo_S3, "S7-S3")
+  expect_equal(foo_S3 + foo(), "S3-S7")
+})
+
+test_that("Ops generics dispatch to S7 methods for S4 classes", {
+  local_methods(base_ops[["+"]])
+  fooS4 <- local_S4_class("foo", contains = "character")
+  fooS7 <- new_class("foo")
+
+  method(`+`, list(fooS7, fooS4)) <- function(e1, e2) "S7-S4"
+  method(`+`, list(fooS4, fooS7)) <- function(e1, e2) "S4-S7"
+
+  expect_equal(fooS4() + fooS7(), "S4-S7")
+  expect_equal(fooS7() + fooS4(), "S7-S4")
+})
+
+test_that("Ops generics dispatch to S7 methods for POSIXct", {
+  # In R's C sources DispatchGroup() has special cases for POSIXt/Date/difftime
+  # so we need to double check that S7 methods still take precedence:
+  # https://github.com/wch/r-source/blob/5cc4e46fc/src/main/eval.c#L4242C1-L4247C64
+
+  skip_if(getRversion() < "4.3")
+  local_methods(base_ops[["+"]])
+  foo <- new_class("foo")
+
+  method(`+`, list(foo, class_POSIXct)) <- function(e1, e2) "foo-POSIXct"
+  expect_equal(foo() + Sys.time(), "foo-POSIXct")
+
+  method(`+`, list(class_POSIXct, foo)) <- function(e1, e2) "POSIXct-foo"
+  expect_equal(Sys.time() + foo(), "POSIXct-foo")
+})
+
+test_that("Ops generics dispatch to S7 methods for NULL", {
+  local_methods(base_ops[["+"]])
+  foo <- new_class("foo")
+
+  method(`+`, list(foo, NULL)) <- function(e1, e2) "foo-NULL"
+  method(`+`, list(NULL, foo)) <- function(e1, e2) "NULL-foo"
+
+  expect_equal(foo() + NULL, "foo-NULL")
+  expect_equal(NULL + foo(), "NULL-foo")
+})
+
+test_that("`%*%` dispatches to S7 methods", {
+  skip_if(getRversion() < "4.3")
+  local_methods(base_ops[["+"]])
 
-  ## Test Ops
   ClassX <- new_class("ClassX")
-  method(`+`, list(class_any, ClassX))   <- function(e1, e2) "class_any + ClassX"
-  method(`+`, list(ClassX, class_any))   <- function(e1, e2) "ClassX + class_any"
   method(`%*%`, list(ClassX, class_any)) <- function(x, y) "ClassX %*% class_any"
   method(`%*%`, list(class_any, ClassX)) <- function(x, y) "class_any %*% ClassX"
 
-  on.exit(S4_remove_classes(c("an_s4_class")))
-  methods::setClass("an_s4_class", contains = "character", where = globalenv())
-  an_s4_obj <- methods::new(methods::getClass("an_s4_class"))
-
-  test_vals <- list(1, NULL, new_class("ClassA")(), an_s4_obj,
-                    Sys.time(), structure("", class = "foo"))
-
-  val <- 1
-  identical(ClassX() + val,   "ClassX + class_any")
-  identical(val + ClassX(),   "class_any + ClassX")
-  identical(ClassX() %*% val, "ClassX %*% class_any")
-  identical(val %*% ClassX(), "class_any %*% ClassX")
-
-  for (val in test_vals)
-    expect_no_error(stopifnot(exprs = {
-      identical(ClassX() + val,   "ClassX + class_any")
-      identical(val + ClassX(),   "class_any + ClassX")
-      identical(ClassX() %*% val, "ClassX %*% class_any")
-      identical(val %*% ClassX(), "class_any %*% ClassX")
-    }))
-
-  expect_no_error(stopifnot(exprs = {
-    identical(ClassX()  +  ClassX(), "ClassX + class_any")
-    identical(ClassX() %*% ClassX(), "ClassX %*% class_any")
-  }))
-
-  # S3 dispatch still works
-  `+.foo`   <- function(e1, e2) paste(class(e1), "+"     , class(e2))
-  `%*%.foo` <- function(x, y)   paste(class(x) , "%*%"   , class(y))
-  Ops.bar   <- function(e1, e2) paste(class(e1), .Generic, class(e2))
-  matrixOps.bar   <- function(x, y) paste(class(x), .Generic, class(y))
-
-  foo <- structure("", class = "foo")
-  bar <- structure("", class = "bar")
-  expect_no_error(stopifnot(exprs = {
-    identical(foo %*% 1, "foo %*% numeric")
-    identical(1 %*% foo, "numeric %*% foo")
-
-    identical(bar %*% 1, "bar %*% numeric")
-    identical(1 %*% bar, "numeric %*% bar")
-
-    identical(foo + 1, "foo + numeric")
-    identical(1 + foo, "numeric + foo")
-
-    identical(bar + 1, "bar + numeric")
-    identical(1 + bar, "numeric + bar")
-  }))
-
+  expect_equal(ClassX() %*% ClassX(), "ClassX %*% class_any")
+  expect_equal(ClassX() %*% 1, "ClassX %*% class_any")
+  expect_equal(1 %*% ClassX(), "class_any %*% ClassX")
 })
 

tests/testthat/test-method-register.R

@@ -123,6 +123,16 @@ describe("as_signature()", {
       as_signature(list(class_character), foo)
     })
   })
+
+  it("works with NULL", {
+    foo <- new_generic("foo", c("x"))
+    sig <- as_signature(NULL, foo)
+    expect_length(sig, 1)
+
+    foo <- new_generic("foo", c("x", "y", "z"))
+    sig <- as_signature(list(NULL, NULL, class_integer), foo)
+    expect_length(sig, 3)
+  })
 })
 
 test_that("check_method returns TRUE if the functions are compatible", {