Use explicit class in S4_register()

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 and 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 inherits 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,

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 it's inputs
+
+    Code
+      S4_register("x")
+    Error <simpleError>
+      `class` must be an R7 class, not a <character>
+

tests/testthat/test-S4.R

@@ -108,3 +108,63 @@ describe("S4_class_dispatch", {
     expect_equal(S4_class_dispatch("Foo1"), "S4/mypkg::Foo1")
   })
 })
+
+describe("S4 registration", {
+  it("can register simple class hierarchy", {
+    foo <- new_class("foo")
+    foo2 <- new_class("foo2", foo)
+
+    S4_register(foo)
+    S4_register(foo2)
+
+    expect_s4_class(getClass("foo"), "classRepresentation")
+    expect_s4_class(getClass("foo2"), "classRepresentation")
+  })
+
+  it("ties S4 validation to R7 validation", {
+    on.exit(S4_remove_classes("Foo"))
+
+    foo3 <- new_class("foo3",
+      parent = class_integer,
+      validator = function(self) {
+        if (R7_data(self) < 0) "Must be positive"
+      }
+    )
+    # Create invalid object
+    R7_obj <- foo3(1L)
+    R7_obj[[1]] <- -1L
+
+    S4_register(foo3)
+    Foo <- setClass("Foo", slots = list(x = "foo3"))
+    S4_obj <- Foo(x = R7_obj)
+
+    expect_error(validObject(S4_obj, complete = TRUE), "Must be positive")
+  })
+
+  it("can register slots", {
+    foo4 <- new_class("foo4", properties = list(x = class_integer))
+    foo5 <- new_class("foo5", foo4, properties = list(y = class_character))
+
+    S4_register(foo4)
+    S4_register(foo5)
+    expect_equal(getClass("foo4")@slots$x, structure("integer", package = "methods"))
+    expect_equal(getClass("foo5")@slots$x, structure("integer", package = "methods"))
+    expect_equal(getClass("foo5")@slots$y, structure("character", package = "methods"))
+  })
+
+  it("translates double to numeric", {
+    foo6 <- new_class("foo6",
+      parent = class_double,
+      properties = list(x = class_double)
+    )
+    S4_register(foo6)
+
+    obj <- new("foo6")
+    expect_type(obj, "double")
+    expect_type(slot(obj, "x"), "double")
+  })
+
+  it("checks it's inputs", {
+    expect_snapshot(S4_register("x"), error = TRUE)
+  })
+})