Use explicit class in S4_register()

NEWS.md

@@ -2,6 +2,9 @@
 
 ## Mar 2022
 
+* Now require explicit `S4_register()` in order to use register R7 method
+  for S4 method. `S4_register()` creates full S4 class spec (#182, #214).
+
 * Exported `class_factor`, `class_Date`, `class_POSIXct`, and 
   `class_data.frame`.
 

R/S4.R

@@ -1,17 +1,44 @@
 #' Register an R7 class with S4
 #'
-#' If you want to use [method<-] to register an method for an S4 generic with
-#' an R7 class, you need to call `S4_register()` once.
+#' @description
+#' If you want to use an R7 class with S4 (e.g. to use [method<-] to register an
+#' method for an S4 generic with an R7 class) you need to call `S4_register()`
+#' once. This generates a full S4 class specification that:
+#'
+#' * Matches class name and inheritance hierarchy.
+#' * Uses [validate()] as the validity method.
+#' * Defines formal S4 slots to match R7 properties. The slot types are
+#'   matched to the R7 property types, with the exception of R7 unions,
+#'   which are unchecked (due to the challenges of converting R7 unions to
+#'   S4 unions).
+#'
+#' If `class` extends another R7 class or has a property restricted to an
+#' R7 class, you you must register those classes first.
 #'
 #' @param class An R7 class created with [new_class()].
 #' @param env Expert use only. Environment where S4 class will be registered.
 #' @export
 S4_register <- function(class, env = parent.frame()) {
   if (!is_class(class)) {
     msg <- sprintf("`class` must be an R7 class, not a %s", obj_desc(class))
+    stop(msg)
+  }
+
+  name <- class@name
+  contains <- double_to_numeric(setdiff(class_dispatch(class), "ANY")[-1])
+
+  # S4 classes inherit slots from parent but R7 classes flatten
+  props <- class@properties
+  if (is_class(class@parent) && class@parent@name != "R7_object") {
+    parent_props <- class@parent@properties
+    props <- props[setdiff(names(props), names(parent_props))]
   }
+  slots <- lapply(props, function(x) R7_to_S4_class(x$class))
 
-  methods::setOldClass(class_dispatch(class), where = topenv(env))
+  methods::setClass(name, contains = contains, slots = slots, where = topenv(env))
+  methods::setValidity(name, function(object) validate(object), where = topenv(env))
+  methods::setOldClass(c(name, contains), S4Class = name, where = topenv(env))
+  invisible()
 }
 
 is_S4_class <- function(x) inherits(x, "classRepresentation")
@@ -51,6 +78,25 @@ S4_to_R7_class <- function(x, error_base = "") {
   }
 }
 
+R7_to_S4_class <- function(x) {
+  switch(class_type(x),
+    NULL = "NULL",
+    any = "ANY",
+    S4 = S4_class_name(x),
+    R7 = R7_class_name(x),
+    R7_base = double_to_numeric(x$class),
+    R7_S3 = x$class[[1]],
+    R7_union = "ANY",
+    stop("Unsupported")
+  )
+}
+
+# S4 uniformly uses numeric to mean double
+double_to_numeric <- function(x) {
+  x[x == "double"] <- "numeric"
+  x
+}
+
 S4_base_classes <- function() {
   list(
     NULL = NULL,
@@ -106,7 +152,7 @@ S4_class_name <- function(x) {
   }
 }
 
-S4_remove_classes <- function(classes, where = globalenv()) {
+S4_remove_classes <- function(classes, where = parent.frame()) {
   for (class in classes) {
     methods::removeClass(class, topenv(where))
   }

tests/testthat/_snaps/S4.md

@@ -5,3 +5,10 @@
     Error <simpleError>
       Unsupported S4 object: must be a class generator or a class definition, not a <double>.
 
+# S4 registration: checks its inputs
+
+    Code
+      S4_register("x")
+    Error <simpleError>
+      `class` must be an R7 class, not a <character>
+

tests/testthat/test-S4.R

@@ -1,5 +1,5 @@
 test_that("can work with classGenerators", {
-  on.exit(S4_remove_classes("Foo"))
+  on.exit(S4_remove_classes("Foo", where = globalenv()))
   Foo <- setClass("Foo", where = globalenv())
   expect_equal(S4_to_R7_class(Foo), getClass("Foo"))
 })
@@ -10,7 +10,7 @@ test_that("converts S4 base classes to R7 base classes", {
 })
 
 test_that("converts S4 unions to R7 unions", {
-  on.exit(S4_remove_classes(c("Foo1", "Foo2", "Foo3", "Union1", "Union2")))
+  on.exit(S4_remove_classes(c("Foo1", "Foo2", "Foo3", "Union1", "Union2"), where = globalenv()))
 
   setClass("Foo1", slots = "x", where = globalenv())
   setClass("Foo2", slots = "x", where = globalenv())
@@ -40,13 +40,13 @@ test_that("errors on non-S4 classes", {
 
 describe("S4_class_dispatch", {
   it("returns name of base class", {
-    on.exit(S4_remove_classes("Foo1"))
+    on.exit(S4_remove_classes("Foo1", where = globalenv()))
     setClass("Foo1", slots = list("x" = "numeric"), where = globalenv())
     expect_equal(S4_class_dispatch("Foo1"), "S4/Foo1")
   })
 
   it("respects single inheritance hierarchy", {
-    on.exit(S4_remove_classes(c("Foo1", "Foo2","Foo3")))
+    on.exit(S4_remove_classes(c("Foo1", "Foo2","Foo3"), where = globalenv()))
 
     setClass("Foo1", slots = list("x" = "numeric"), where = globalenv())
     setClass("Foo2", contains = "Foo1", where = globalenv())
@@ -55,7 +55,7 @@ describe("S4_class_dispatch", {
   })
 
   it("performs breadth first search for multiple dispatch", {
-    on.exit(S4_remove_classes(c("Foo1a", "Foo1b","Foo2a", "Foo2b", "Foo3")))
+    on.exit(S4_remove_classes(c("Foo1a", "Foo1b","Foo2a", "Foo2b", "Foo3"), where = globalenv()))
     setClass("Foo1a", slots = list("x" = "numeric"), where = globalenv())
     setClass("Foo1b", contains = "Foo1a", where = globalenv())
     setClass("Foo2a", slots = list("x" = "numeric"), where = globalenv())
@@ -68,13 +68,13 @@ describe("S4_class_dispatch", {
   })
 
   it("handles extensions of base classes", {
-    on.exit(S4_remove_classes("Foo1"))
+    on.exit(S4_remove_classes("Foo1", where = globalenv()))
     setClass("Foo1", contains = "character", where = globalenv())
     expect_equal(S4_class_dispatch("Foo1"), c("S4/Foo1", "character"))
   })
 
   it("handles extensions of S3 classes", {
-    on.exit(S4_remove_classes(c("Soo1", "Foo2", "Foo3")))
+    on.exit(S4_remove_classes(c("Soo1", "Foo2", "Foo3"), where = globalenv()))
 
     setOldClass(c("Soo1", "Soo"), where = globalenv())
     setClass("Foo2", contains = "Soo1", where = globalenv())
@@ -83,7 +83,7 @@ describe("S4_class_dispatch", {
   })
 
   it("ignores unions", {
-    on.exit(S4_remove_classes(c("Foo1", "Foo2", "Foo3")))
+    on.exit(S4_remove_classes(c("Foo1", "Foo2", "Foo3"), where = globalenv()))
 
     setClass("Foo1", slots = list("x" = "numeric"), where = globalenv())
     setClass("Foo2", slots = list("x" = "numeric"), where = globalenv())
@@ -94,7 +94,7 @@ describe("S4_class_dispatch", {
   })
 
   it("captures explicit package name", {
-    on.exit(S4_remove_classes("Foo1"))
+    on.exit(S4_remove_classes("Foo1", where = globalenv()))
     setClass("Foo1", package = "pkg", where = globalenv())
     expect_equal(S4_class_dispatch("Foo1"), "S4/pkg::Foo1")
   })
@@ -108,3 +108,68 @@ describe("S4_class_dispatch", {
     expect_equal(S4_class_dispatch("Foo1"), "S4/mypkg::Foo1")
   })
 })
+
+describe("S4 registration", {
+  it("can register simple class hierarchy", {
+    on.exit(S4_remove_classes(c("foo1", "foo2")))
+
+    foo1 <- new_class("foo1")
+    foo2 <- new_class("foo2", foo1)
+
+    S4_register(foo1)
+    S4_register(foo2)
+
+    expect_s4_class(getClass("foo1"), "classRepresentation")
+    expect_s4_class(getClass("foo2"), "classRepresentation")
+  })
+
+  it("ties S4 validation to R7 validation", {
+    on.exit(S4_remove_classes(c("foo1", "Foo2")))
+
+    foo1 <- new_class("foo1",
+      parent = class_integer,
+      validator = function(self) {
+        if (R7_data(self) < 0) "Must be positive"
+      }
+    )
+    # Create invalid object
+    R7_obj <- foo1(1L)
+    R7_obj[[1]] <- -1L
+
+    S4_register(foo1)
+    Foo2 <- setClass("Foo2", slots = list(x = "foo1"))
+    S4_obj <- Foo2(x = R7_obj)
+
+    expect_error(validObject(S4_obj, complete = TRUE), "Must be positive")
+  })
+
+  it("can register slots", {
+    on.exit(S4_remove_classes(c("foo1", "foo2")))
+
+    foo1 <- new_class("foo1", properties = list(x = class_integer))
+    foo2 <- new_class("foo2", foo1, properties = list(y = class_character))
+
+    S4_register(foo1)
+    S4_register(foo2)
+    expect_equal(getClass("foo1")@slots$x, structure("integer", package = "methods"))
+    expect_equal(getClass("foo2")@slots$x, structure("integer", package = "methods"))
+    expect_equal(getClass("foo2")@slots$y, structure("character", package = "methods"))
+  })
+
+  it("translates double to numeric", {
+    on.exit(S4_remove_classes("foo1"))
+    foo1 <- new_class("foo1",
+      parent = class_double,
+      properties = list(x = class_double)
+    )
+    S4_register(foo1)
+
+    obj <- new("foo1")
+    expect_type(obj, "double")
+    expect_type(slot(obj, "x"), "double")
+  })
+
+  it("checks its inputs", {
+    expect_snapshot(S4_register("x"), error = TRUE)
+  })
+})

tests/testthat/test-class-spec.R

@@ -162,7 +162,7 @@ test_that("can work with R7 classes that extend S3 classes", {
 # S4 ----------------------------------------------------------------------
 
 test_that("can work with S4 classes", {
-  on.exit(S4_remove_classes(c("Foo1", "Foo2", "Foo3", "Foo4")))
+  on.exit(S4_remove_classes(c("Foo1", "Foo2", "Foo3", "Foo4"), where = globalenv()))
 
   methods::setClass("Foo1", contains = "character", where = globalenv())
   methods::setClass("Foo2", contains = "Foo1", where = globalenv())

vignettes/minutes/2022-04-18.Rmd

@@ -0,0 +1,33 @@
+---
+title: "Minutes 2022-04-18"
+---
+
+## Changes
+
+-   All base wrappers use common naming scheme, e.g. `class_integer`, `class_numeric`, `class_missing`.
+    Exported wrappers for key S3 classes: `class_factor`, `class_Date`, `class_POSIXct`, and `class_data.frame`.
+
+-   `convert()` allows you to convert an object into another class.
+    \
+    `super()` replaces `next_method()`.
+
+-   Require explicit `S4_register()` in order to use register a method for R7 class on a S4 generic.
+
+-   Can now register methods for double-dispatch base Ops (currently only works if both classes are R7, or the first argument is R7 and the second doesn't have a method for the Ops generic).
+
+## Discussion
+
+-   Lightweight syntax for unions: <https://github.com/RConsortium/OOP-WG/issues/224> --- no strong feelings against.
+
+-   Next steps
+
+    -   Should we aim for a CRAN release of R7?
+        Allow us to get more feedback before it moves into base R and if tidyverse is to use R7, will also need some way to access in older versions of R.
+
+    -   Serialization: <https://github.com/RConsortium/OOP-WG/issues/225>
+
+    -   Base R extension points: <https://github.com/RConsortium/OOP-WG/issues/222>
+
+        -   Will look into creating a patch to implement minimal set of changes.
+
+        -   Will need to tweak package to use if in R devel, otherwise register some shims to make it work in current R.