diff --git a/NEWS.md b/NEWS.md index 8d461e04..7ece26ff 100644 --- a/NEWS.md +++ b/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`. diff --git a/R/S4.R b/R/S4.R index b3a39e82..470a7c88 100644 --- a/R/S4.R +++ b/R/S4.R @@ -1,7 +1,19 @@ #' 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. @@ -9,9 +21,24 @@ 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)) } diff --git a/man/S4_register.Rd b/man/S4_register.Rd index 75b51a0e..78746162 100644 --- a/man/S4_register.Rd +++ b/man/S4_register.Rd @@ -12,6 +12,18 @@ S4_register(class, env = parent.frame()) \item{env}{Expert use only. Environment where S4 class will be registered.} } \description{ -If you want to use \link{method<-} to register an method for an S4 generic with -an R7 class, you need to call \code{S4_register()} once. +If you want to use an R7 class with S4 (e.g. to use \link{method<-} to register an +method for an S4 generic with an R7 class) you need to call \code{S4_register()} +once. This generates a full S4 class specification that: +\itemize{ +\item Matches class name and inheritance hierarchy. +\item Uses \code{\link[=validate]{validate()}} as the validity method. +\item 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 \code{class} extends another R7 class or has a property restricted to an +R7 class, you you must register those classes first. } diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index fa02a921..a83767b0 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -5,3 +5,10 @@ Error Unsupported S4 object: must be a class generator or a class definition, not a . +# S4 registration: checks its inputs + + Code + S4_register("x") + Error + `class` must be an R7 class, not a + diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 564e94c0..2f0e7552 100644 --- a/tests/testthat/test-S4.R +++ b/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) + }) +}) diff --git a/tests/testthat/test-class-spec.R b/tests/testthat/test-class-spec.R index 1206c3c4..17b6c223 100644 --- a/tests/testthat/test-class-spec.R +++ b/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()) diff --git a/vignettes/minutes/2022-04-18.Rmd b/vignettes/minutes/2022-04-18.Rmd new file mode 100644 index 00000000..88fd11bc --- /dev/null +++ b/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: --- 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: + + - Base R extension points: + + - 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.