diff --git a/.Rbuildignore b/.Rbuildignore index 7ee683ae..e1944324 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -23,3 +23,4 @@ ^\.claude$ ^\.git-blame-ignore-revs$ ^AGENTS\.md$ +^\.lintr\.R$ diff --git a/.lintr.R b/.lintr.R new file mode 100644 index 00000000..eac429f6 --- /dev/null +++ b/.lintr.R @@ -0,0 +1 @@ +linters <- lintr::linters_with_defaults() diff --git a/NAMESPACE b/NAMESPACE index 16148e7b..d582093c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -41,6 +41,7 @@ export("S7_data<-") export("method<-") export("prop<-") export("props<-") +export(S4_contains) export(S4_register) export(S7_class) export(S7_class_desc) diff --git a/NEWS.md b/NEWS.md index 11cfd4cc..ca0d8b30 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,7 @@ * New `:=` operator creates and names an object in one step, so `Foo := new_class()` is equivalent to `Foo <- new_class(name = "Foo")` (#658). * The class object that S7 stores on each instance now lives in the `_S7_class` attribute (previously `S7_class`), moving it into the `_`-prefixed namespace reserved for S7 internals so it can't collide with a user-defined property. Objects created by an older version of S7 (e.g. serialised to disk or baked into another package's lazy-load database) continue to work, as S7 falls back to the old attribute name when reading them (#677). +* S7 and S4 now interoperate through inheritance. `new_class()` can use an S4 class as a parent, mapping S4 slots to S7 properties and registering the class with S4 automatically. Conversely, `S4_register()` registers an S7 class with S4, and `S4_contains()` returns an S4 class name suitable for `methods::setClass(contains = )`, exposing stored S7 properties as S4 slots for S4 subclasses. This support includes S4 initialization and validity integration, and S4/internal generic registration where needed; see `vignette("compatibility")` for caveats (#456). * Errors thrown by S7 now report the function where they occurred, making it easier to track down the source of a problem (#646). * `class_POSIXct` uses the `tzone` attribute (not `tz`), and allows it to be absent (#401). * Base type wrappers like `class_integer` now define their constructor and validator in the S7 namespace. (#553). diff --git a/R/S4.R b/R/S4.R index a1814e78..fae116f3 100644 --- a/R/S4.R +++ b/R/S4.R @@ -1,13 +1,34 @@ -#' Register an S7 or S3 class with S4 +#' Register an S7, S3, or union class with S4 #' #' If you want to use [method<-] to register a method for an S4 generic with -#' an S7 class or an S3 class (created by [new_S3_class()]), you need to call -#' `S4_register()` once. +#' an S7 class that does not extend an S4 class, or an S3 class created by +#' [new_S3_class()], you need to call `S4_register()` once. Classes created by +#' [new_class()] with an S4 parent are registered automatically. #' -#' @param class An S7 class created with [new_class()], or an S3 class created -#' with [new_S3_class()]. +#' @section Details: +#' `S4_register()` registers an S7 class, S3 class, or S7 union with S4 and +#' invisibly returns the registered S4 class name. +#' For S7 classes, this creates a virtual S4 old class that exposes stored S7 +#' properties as S4 slots and carries the `_S7_class` slot needed for S7 dispatch +#' and validation. +#' +#' After registration, `S4_contains()` returns the virtual S4 class name to use +#' when an S4 class should extend an S7 class with +#' `methods::setClass(contains = )`. It asserts that the S7 properties can +#' safely cross the S4 inheritance boundary. +#' +#' Register S7 unions with `S4_register()` before using them in S4 slots or +#' method signatures unless an equivalent S4 union already exists. +#' +#' See `vignette("compatibility")` for examples and caveats. +#' +#' @param class An S7 class created with [new_class()], or, for +#' `S4_register()` only, an S3 class created with [new_S3_class()] or an S7 +#' union created with [new_union()]. #' @param env Expert use only. Environment where S4 class will be registered. -#' @returns Nothing; the function is called for its side-effect. +#' @returns +#' Called for its side effects and invisibly returns the registered S4 class +#' name. #' @export #' @examples #' methods::setGeneric("S4_generic", function(x) { @@ -19,23 +40,1140 @@ #' method(S4_generic, Foo) <- function(x) "Hello" #' #' S4_generic(Foo()) +#' +#' S4Foo := new_class(properties = list(x = class_numeric), package = "S7") +#' S4_register(S4Foo) +#' methods::setClass("S4Child", contains = S4_contains(S4Foo)) S4_register <- function(class, env = parent.frame()) { - if (is_class(class)) { - classes <- class_dispatch(class) + where <- topenv(env) + if (is_union(class)) { + return(invisible(S4_register_union(class, where))) + } else if (is_class(class)) { + return(invisible(S4_register_class(class, where))) } else if (is_S3_class(class)) { classes <- class$class + methods::setOldClass(classes, where = where) + return(invisible(classes[1L])) } else { msg <- sprintf( - "`class` must be an S7 class or an S3 class, not a %s.", + "`class` must be an S7 class, S3 class, or S7 union, not a %s.", obj_desc(class) ) stop2(msg) } +} + +#' @rdname S4_register +#' @export +S4_contains <- function(class, env = parent.frame()) { + where <- topenv(env) + if (!is_class(class)) { + msg <- sprintf("`class` must be an S7 class, not a %s.", obj_desc(class)) + stop2(msg) + } + if (class@abstract) { + stop2("S4 classes can not extend abstract S7 classes.", call = sys.call()) + } + + registered <- S4_registered_class(class, where, call = sys.call()) + if (!S4_registered_S7_class_matches(registered, class)) { + msg <- sprintf( + paste0( + "Class has not been registered as a reified S7 class; ", + "please call S4_register(%s)." + ), + class_deparse(class) + ) + stop2(msg, call = sys.call()) + } + class_name <- as.character(registered@className) + S4_check_contains(class) + class_name +} + +S4_register_union <- function(class, env) { + members <- S4_union_member_classes(class, env, register = TRUE) + name <- S4_union_name(class, env) + methods::setClassUnion( + name, + members, + where = env + ) + S4_register_union_member_extensions(class$classes, members, name, env) + name +} + +S4_class <- function(x, S4_env, call = sys.call(-1L)) { + switch( + class_type(x), + `NULL` = "NULL", + missing = "missing", + any = "ANY", + S7_base = base_to_S4(x$class), + S4 = x@className, + S7 = S4_registered_class(x, S4_env, call = call)@className, + S7_S3 = S4_registered_class(x, S4_env, call = call)@className, + S7_union = S4_union_class(x, S4_env) + ) +} + +# S4 dispatch uses `class()` to find a method, but `class(1.5)` is "numeric", +# not "double", so registering under "double" silently misses real doubles. +# Mapping to "numeric" catches doubles but also matches integers too. There's +# no clean S4 way to say "doubles only" and this seems likely to be what +# people want. +base_to_S4 <- function(class) { + switch(class, double = "numeric", class) +} + +S4_registered_class <- function(x, S4_env, call = sys.call(-1L)) { + class <- S4_registered_class_or_null(x, S4_env) + if (!is.null(class)) { + return(class) + } + + msg <- sprintf( + "Class has not been registered with S4; please call S4_register(%s).", + class_deparse(x) + ) + stop2(msg, call = call) +} + +S4_registered_class_or_null <- function(x, S4_env) { + class <- tryCatch( + methods::getClass(class_register(x), where = S4_env), + error = function(err) NULL + ) + if (is.null(class) || !S4_registered_class_matches(class, x)) { + return(NULL) + } + class +} + +S4_registered_class_matches <- function(class, x) { + if (S4_registered_S7_class_matches(class, x)) { + TRUE + } else if (!"_S7_class" %in% names(class@slots)) { + S4_registered_old_class_matches(class, x) + } else { + FALSE + } +} + +S4_registered_S7_class_matches <- function(class, x) { + if (!"_S7_class" %in% names(class@slots)) { + return(FALSE) + } + registered <- methods::slot(class@prototype, "_S7_class") + is_class(registered) && + (identical(registered, x) || isTRUE(all.equal(registered, x))) +} + +S4_registered_old_class_matches <- function(class, x) { + if (!".S3Class" %in% names(class@slots)) { + return(FALSE) + } + classes <- if (is_S3_class(x)) x$class else S4_reified_old_classes(x) + identical( + methods::slot(class@prototype, ".S3Class"), + classes + ) +} + +S4_union_class <- function(x, S4_env) { + if (identical(x, class_numeric)) { + return("numeric") + } + + name <- S4_union_name(x, S4_env) + members <- S4_union_member_classes(x, S4_env) + if ( + methods::isClass(name, where = S4_env) && + S4_union_matches(name, members, S4_env) + ) { + return(name) + } + + name <- S4_find_union(members, S4_env) + if (!is.null(name)) { + return(name) + } + + msg <- sprintf( + "Class union has not been registered with S4; please call S4_register(%s).", + class_deparse(x) + ) + stop(msg, call. = FALSE) +} + +S4_union_name <- function(x, S4_env) { + paste0( + vcapply(x$classes, S4_union_name_member, S4_env = S4_env), + collapse = "_OR_" + ) +} + +S4_union_name_member <- function(x, S4_env) { + if (is_S4_class(x)) { + return(S4_class_key(x@className)) + } + + S4_class(x, S4_env) +} + +S4_union_member_classes <- function(x, S4_env, register = FALSE) { + lapply( + x$classes, + S4_union_member_class, + S4_env = S4_env, + register = register + ) +} + +S4_union_member_class <- function(x, S4_env, register = FALSE) { + if (!is_S4_class(x)) { + if (register && class_type(x) %in% c("S7", "S7_S3")) { + registered <- S4_registered_class_or_null(x, S4_env) + if (!is.null(registered)) { + return(registered@className) + } + return(S4_register(x, S4_env)) + } + return(S4_class(x, S4_env)) + } + + if (!S4_union_member_needs_identity(x@className)) { + return(x@className) + } + + name <- S4_class_name(x) + if (register) { + if (!methods::isClass(name, where = S4_env)) { + methods::setClass(name, contains = "VIRTUAL", where = S4_env) + } + return(name) + } + if (methods::isClass(name, where = S4_env)) { + return(name) + } + + x@className +} + +S4_register_union_member_extensions <- function( + classes, + members, + union, + S4_env +) { + for (i in seq_along(classes)) { + S4_register_union_member_extension( + classes[[i]], + members[[i]], + union, + S4_env + ) + } + invisible() +} + +S4_register_union_member_extension <- function(class, member, union, S4_env) { + if (!is_S4_class(class) || !S4_union_member_needs_identity(class@className)) { + return(invisible()) + } + + member_def <- methods::getClass(member, where = S4_env) + subclasses <- base::Filter(function(x) x@distance == 1, member_def@subclasses) + if ( + S4_class_key(class@className) %in% + S4_class_keys(S4_subclasses(subclasses)) + ) { + return(invisible()) + } + + setIs_args <- list( + class@className, + member, + where = S4_env, + classDef = class + ) + if (!S4_union_member_same_package(class@className, S4_env)) { + setIs_args$test <- S4_class_identity_test(class@className) + } + suppressWarnings(do.call(methods::setIs, setIs_args)) + S4_prune_union_subclass(union, class@className, S4_env) + S4_register_union_member_subclasses(class@className, member, union, S4_env) + invisible() +} + +S4_register_union_member_subclasses <- function(class, member, union, S4_env) { + member_def <- methods::getClass(member, where = S4_env) + subclasses <- member_def@subclasses + subclasses <- base::Filter( + function(x) !identical(S4_class_key(x@subClass), S4_class_key(class)), + subclasses + ) + union_def <- methods::getClass(union, where = S4_env) + union_subclass_keys <- S4_class_keys( + S4_subclasses(union_def@subclasses) + ) + + for (subclass in subclasses) { + if (S4_class_key(subclass@subClass) %in% union_subclass_keys) { + next + } + + subclass_def <- S4_get_class(subclass@subClass, S4_env) + suppressWarnings(methods::setIs( + subclass_def@className, + union, + where = S4_class_env(subclass_def@className, S4_env), + classDef = subclass_def + )) + } + invisible() +} + +S4_get_class <- function(class, S4_env) { + methods::getClass(as.character(class), where = S4_class_env(class, S4_env)) +} + +S4_class_env <- function(class, S4_env) { + package <- S4_class_package(class, methods = FALSE) + if (is.null(package) || identical(package, ".GlobalEnv")) { + return(S4_env) + } + + asNamespace(package) +} + +S4_union_member_needs_identity <- function(class) { + package <- S4_class_package(class, methods = FALSE) + !is.null(package) && + !(identical(package, "methods") && class %in% S4_methods_class_names()) +} + +S4_union_member_same_package <- function(class, S4_env) { + package <- S4_class_package(class, methods = FALSE) + !is.null(package) && identical(package, methods::getPackageName(S4_env)) +} + +# setIs() adds a transitive bare-class subclass entry to the union. Class +# unions match those names without respecting package identity, so remove it +# and let objects reach the union through the package-qualified shim. +S4_prune_union_subclass <- function(union, class, S4_env) { + class <- as.character(class) + union_def <- methods::getClass(union, where = S4_env) + if (!class %in% names(union_def@subclasses)) { + return(invisible()) + } + + union_def@subclasses[[class]] <- NULL + methods::setClass(Class = union, representation = union_def, where = S4_env) + invisible() +} + +S4_class_identity_test <- function(target) { + target <- S4_class_identity_expr(target) + new_function( + alist(object = ), + bquote({ + S7_namespace <- base::asNamespace("S7") + class <- base::get( + "S4_object_class_def", + envir = S7_namespace + )(base::class(object)) + if (is.null(class)) { + return(FALSE) + } + + base::get( + "S4_class_extends_identity", + envir = S7_namespace + )(class, .(target)) + }) + ) +} + +S4_class_identity_expr <- function(class) { + package <- attr(class, "package", exact = TRUE) + class <- as.character(class) + if (is.null(package)) { + return(class) + } + + bquote(structure(.(class), package = .(package))) +} + +S4_object_class_def <- function(class) { + name <- class[[1L]] + package <- attr(class, "package", exact = TRUE) + if (!is.null(package)) { + where <- if (identical(package, ".GlobalEnv")) { + .GlobalEnv + } else { + asNamespace(package) + } + return(methods::getClass(name, where = where)) + } + + methods::getClassDef(name, inherits = FALSE) +} + +S4_class_extends_identity <- function(class, target) { + if (S4_same_class_identity(class@className, target)) { + return(TRUE) + } + + any(vlapply( + class@contains, + function(extension) S4_same_class_identity(extension@superClass, target) + )) +} + +S4_same_class_identity <- function(x, y) { + identical(S4_class_identity_key(x), S4_class_identity_key(y)) +} + +S4_class_identity_key <- function(class) { + S4_class_key(class, bare_missing = FALSE, bare_global = FALSE) +} + +S4_find_union <- function(members, S4_env) { + if (!all(vlapply(members, methods::isClass, where = S4_env))) { + return(NULL) + } + + supers <- lapply(members, S4_direct_superclasses, S4_env = S4_env) + super_keys <- lapply(supers, S4_class_keys) + candidate_keys <- base::Reduce(base::intersect, super_keys) + candidates <- supers[[1L]][match(candidate_keys, super_keys[[1L]])] + matches <- base::Filter( + function(candidate) S4_union_matches(candidate, members, S4_env), + candidates + ) + if (length(matches) == 0) { + return(NULL) + } + + matches[[1L]] +} + +S4_direct_superclasses <- function(class, S4_env) { + class <- methods::getClass(class, where = S4_env) + contains <- class@contains + contains <- base::Filter(function(x) x@distance == 1, contains) + lapply(contains, function(x) x@superClass) +} + +S4_union_matches <- function(class, members, S4_env) { + class <- methods::getClass(class, where = S4_env) + if (!methods::isClassUnion(class)) { + return(FALSE) + } + + setequal(S4_class_keys(S4_union_members(class)), S4_class_keys(members)) +} + +S4_union_members <- function(class) { + subclasses <- base::Filter(function(x) x@distance == 1, class@subclasses) + S4_subclasses(subclasses) +} + +S4_subclasses <- function(x) { + lapply(x, methods::slot, "subClass") +} + +S4_class_keys <- function(classes) { + vcapply(classes, S4_class_key) +} + +S4_class_key <- function( + class, + bare_missing = TRUE, + bare_global = TRUE +) { + package <- S4_class_package(class) + class <- as.character(class) + if ( + (is.null(package) && bare_missing) || + (identical(package, ".GlobalEnv") && bare_global) + ) { + class + } else { + paste0(package %||% "", "::", class) + } +} + +S4_class_package <- function(class, methods = TRUE) { + package <- attr(class, "package", exact = TRUE) + if (methods && is.null(package) && class %in% S4_methods_class_names()) { + package <- "methods" + } + package +} + +S4_methods_class_names <- function() { + c("NULL", "missing", "ANY", names(S4_basic_classes())) +} + +S4_ancestor <- function(class) { + parent_class <- attr(class, "parent", exact = TRUE) + while (is_class(parent_class)) { + parent_class <- attr(parent_class, "parent", exact = TRUE) + } + if (is_S4_class(parent_class)) parent_class +} - methods::setOldClass(classes, where = topenv(env)) +S7_extends_S4 <- function(class) { + !is.null(S4_ancestor(class)) +} + +inherits_S4 <- function(x) { + isS4(x) || + { + klass <- S7_class(x) + !is.null(klass) && S7_extends_S4(klass) + } +} + +S4_register_subclass <- function(class, env) { + S4_register(class, env) invisible() } +S4_set_S3_class_prototype <- function(class, S3_class, env) { + class_def <- methods::getClass(class, where = env) + attr(class_def@prototype, ".S3Class") <- S3_class + methods::setClass(Class = class, representation = class_def, where = env) + invisible(class) +} + +S4_slot_names <- function(class, S4_env) { + names(methods::getClass(class, where = S4_env)@slots) +} + +S4_internal_slot_names <- function() { + c("_S7_class", ".S3Class") +} + +S4_property_class <- function(prop, S4_env) { + S4_register_property_class(prop$class, S4_env) + S4_class(prop$class, S4_env) +} + +S4_register_property_class <- function(class, S4_env) { + if (is_class(class) && is.null(S4_registered_class_or_null(class, S4_env))) { + S4_register(class, S4_env) + } + invisible() +} + +S4_check_contains <- function(class, call = sys.call(-1L)) { + if (!is_class(class)) { + return(invisible()) + } + + for (prop in class@properties) { + if (prop_is_dynamic(prop) || prop_has_setter(prop)) { + msg <- sprintf( + paste0( + "Can't extend S7 class %s with S4 because property %s has a ", + "custom %s." + ), + class_desc(class), + prop$name, + if (prop_is_dynamic(prop)) "getter" else "setter" + ) + stop2(msg, call = call) + } + } + + invisible() +} + +S4_properties_prototype <- function( + properties, + class, + env, + include_S7_class = FALSE +) { + args <- list() + for (name in names(properties)) { + value <- S4_property_default_value(properties[[name]], env, class@package) + if (length(value) != 0L) { + slot_name <- prop_storage_rename(name) + args[slot_name] <- value + } + } + if (include_S7_class) { + args$`_S7_class` <- class + } + do.call(methods::prototype, args) +} + +S4_property_default_value <- function( + prop, + env, + package, + deferred = FALSE, + allow_simple = FALSE +) { + tryCatch( + { + value <- prop_default(prop, env, package) + value <- S4_decode_pseudo_null(value) + is_deferred <- is.call(value) || is.symbol(value) + if (!is_deferred) { + return(if (!deferred || allow_simple) list(value) else list()) + } + if (!deferred) { + return(list()) + } + + value <- eval(value, env) + value <- S4_decode_pseudo_null(value) + list(value) + }, + error = function(cnd) { + if (!is.null(prop$default)) { + stop(cnd) + } + list() + } + ) +} + +S4_decode_pseudo_null <- function(value) { + if (identical(value, as.name("\001NULL\001"))) NULL else value +} + +S4_old_classes <- function(class) { + subclasses <- character() + while (is_class(class)) { + if (class@abstract) { + return(subclasses) + } + subclasses <- c(subclasses, S7_class_name(class)) + class <- class@parent + if (is_S4_class(class)) { + return(subclasses) + } + } + character() +} + +S4_register_class <- function(class, env = parent.frame()) { + where <- topenv(env) + class_name <- S7_class_name(class) + parent_class_name <- S4_reified_parent_class(class, where) + old_classes <- S4_reified_old_classes(class) + parent_slot_names <- character() + if (!is.null(parent_class_name)) { + parent_slot_names <- S4_slot_names(parent_class_name, where) + } + parent_needs_identity <- S4_class_needs_identity(parent_class_name, where) + + properties <- class@properties + stored_properties <- properties[!vlapply(properties, prop_is_dynamic)] + prototype_properties <- stored_properties[setdiff( + names(stored_properties), + ".Data" + )] + slot_properties <- stored_properties + if (!".Data" %in% parent_slot_names) { + slot_properties <- slot_properties[setdiff(names(slot_properties), ".Data")] + } + if (!parent_needs_identity) { + slot_properties <- slot_properties[ + !prop_storage_rename(names(slot_properties)) %in% parent_slot_names + ] + } + slots <- lapply(slot_properties, S4_property_class, S4_env = where) + names(slots) <- prop_storage_rename(names(slot_properties)) + needs_S7_class_slot <- !"_S7_class" %in% parent_slot_names + if (needs_S7_class_slot) { + slots$`_S7_class` <- "S7_class" + } + if (S4_needs_S3_class_slot(class, parent_slot_names, old_classes, where)) { + slots$.S3Class <- "character" + } + contains <- S4_contains_classes(parent_class_name, where) + + methods::setClass( + Class = class_name, + slots = slots, + contains = contains, + prototype = S4_properties_prototype( + prototype_properties, + class, + where, + include_S7_class = TRUE + ), + where = where + ) + + if (class@abstract) { + if (!S7_extends_S4(class)) { + methods::setOldClass(old_classes, S4Class = class_name, where = where) + S4_set_S7_object_extension(class_name, old_classes, where) + S4_set_S3_class_prototype(class_name, old_classes, where) + } + return(class_name) + } + + methods::setOldClass(old_classes, S4Class = class_name, where = where) + S4_set_S7_object_extension(class_name, old_classes, where) + S4_set_S3_class_prototype(class_name, old_classes, where) + methods::setValidity(class_name, S4_validate_class, where = where) + methods::setMethod( + "initialize", + class_name, + S4_initialize_method(where), + where = where + ) + + class_name +} + +S4_needs_S3_class_slot <- function( + class, + parent_slot_names, + old_classes, + where +) { + if (!"S7_object" %in% old_classes || ".S3Class" %in% parent_slot_names) { + return(FALSE) + } + + is_base_class(base_parent(class)) || + S4_has_S3_data_parent(class, where) || + ".Data" %in% parent_slot_names +} + +S4_has_S3_data_parent <- function(class, where) { + parent <- base_parent(class) + if (!is_S3_class(parent)) { + return(FALSE) + } + + any(vlapply(parent$class, S4_class_has_data_part, where = where)) +} + +S4_class_has_data_part <- function(class, where) { + if (class %in% S4_old_class_data_part_names()) { + return(TRUE) + } + + class_def <- methods::getClassDef(class, where = where) + !is.null(class_def) && ".Data" %in% names(class_def@slots) +} + +S4_old_class_data_part_names <- function() { + c( + "logical", + "integer", + "numeric", + "complex", + "character", + "raw", + "list", + "expression", + "name", + "call", + "function", + "environment" + ) +} + +S4_set_S7_object_extension <- function(class_name, old_classes, where) { + if (!"S7_object" %in% old_classes) { + return(invisible()) + } + + class <- methods::getClass(class_name, where = where) + if (methods::extends(class, "S7_object")) { + return(invisible()) + } + + methods::setIs( + class_name, + "S7_object", + where = where, + classDef = class + ) + invisible() +} + +S4_class_needs_identity <- function(class, where) { + if (is.null(class)) { + return(FALSE) + } + + package <- attr(class, "package", exact = TRUE) + !is.null(package) && !identical(package, methods::getPackageName(where)) +} + +S4_contains_classes <- function(parent_class_name, where) { + if (S4_class_needs_identity(parent_class_name, where)) { + list(parent_class_name, "VIRTUAL") + } else { + c(parent_class_name, "VIRTUAL") + } +} + +S4_check_slot_storage <- function(class, call = sys.call(-1L)) { + if (S4_has_implicit_data_part(class)) { + msg <- c( + sprintf( + "Can't extend S4 class %s because it has an implicit data part.", + class_desc(class) + ), + "Only S4 classes with data parts stored in an explicit `.Data` slot are supported." + ) + stop2(msg, call = call) + } + + nms <- names(class@slots) + renamed <- nms[prop_storage_rename(nms) != nms & nms != ".Data"] + if (length(renamed) == 0L) { + return(invisible()) + } + + renamed_label <- paste(dQuote(renamed), collapse = ", ") + slot_label <- if (length(renamed) == 1L) "slot" else "slots" + msg <- c( + sprintf( + "Can't extend S4 class %s because %s %s would need renamed S7 storage.", + class_desc(class), + slot_label, + renamed_label + ), + "These S4 slots can not be represented safely on direct S7 child objects." + ) + stop2(msg, call = call) +} + +S4_has_implicit_data_part <- function(class) { + if (".Data" %in% names(class@slots)) { + return(FALSE) + } + + identical(as.character(class@className), "vector") || + "vector" %in% names(class@contains) +} + +S4_reified_parent_class <- function(class, env) { + parent_class <- class@parent + if (is_class(parent_class)) { + if (parent_class@name == "S7_object") { + return(NULL) + } + return(S4_register(parent_class, env)) + } else if (is_base_class(parent_class)) { + return(S4_class(parent_class, env)) + } else if (is_S4_class(parent_class)) { + return(S4_class(parent_class, env)) + } + + NULL +} + +S4_reified_old_classes <- function(class) { + if (S7_extends_S4(class)) { + return(c(S4_old_classes(class), "S7_object")) + } + + class_dispatch(class) +} + +S4_validate_class <- function(object) { + class_name <- class(object)[1L] + class <- S7_class(object) + + if (identical(S7_class_name(class), class_name)) { + return(S4_validate(object)) + } + while (is_class(class@parent)) { + class <- class@parent + if (identical(S7_class_name(class), class_name)) { + return(TRUE) + } + } + + sprintf( + "object with S7 class %s does not match S4 class %s", + dQuote(S7_class_name(S7_class(object))), + dQuote(class_name) + ) +} + +S4_validate <- function(object) { + if (!S7_inherits(object)) { + return(sprintf( + "object with S4 class %s is not an S7 object", + dQuote(class(object)[1L]) + )) + } + + tryCatch( + { + validate(object) + TRUE + }, + error = function(cnd) conditionMessage(cnd) + ) +} + +S4_initialize_method <- function(env) { + force(env) + function(.Object, ...) { + S4_initialize(.Object, ..., .S4_default_env = env) + } +} + +S4_initialize <- function(.Object, ..., .S4_default_env = parent.frame()) { + if (isS4(.Object) && has_S7_class(.Object)) { + S4_check_contains(S7_class(.Object)) + } + + args <- list(...) + nms <- names2(args) + prop_nms <- prop_names(.Object) + vals <- list() + s4_vals <- list() + s4_slot_nms <- character() + if (isS4(.Object)) { + prop_storage_nms <- prop_storage_rename(prop_nms) + s4_slot_nms <- setdiff( + methods::slotNames(.Object), + c(prop_nms, prop_storage_nms, S4_internal_slot_names()) + ) + } + data_part <- NULL + for (arg in args[nms == ""]) { + arg_vals <- S4_initialize_values(arg) + if (".Data" %in% names(arg_vals)) { + data_part <- if (isS4(arg)) arg_vals$.Data else arg + } + if (isS4(arg)) { + arg_s4_vals <- arg_vals[names(arg_vals) %in% s4_slot_nms] + s4_vals <- modify_list(s4_vals, arg_s4_vals) + } + arg_vals <- S4_initialize_prop_values( + arg_vals, + prop_nms, + storage = isS4(arg) + ) + vals <- modify_list(vals, arg_vals) + } + named_args <- args[nms != ""] + internal_arg_nms <- intersect(names2(named_args), S4_internal_slot_names()) + if (length(internal_arg_nms) > 0L) { + slot_label <- if (length(internal_arg_nms) == 1L) "slot" else "slots" + msg <- sprintf( + "Can't initialize internal S4 %s %s.", + slot_label, + paste(dQuote(internal_arg_nms), collapse = ", ") + ) + stop2(msg, call = sys.call(-1L)) + } + if (length(s4_slot_nms) > 0L) { + s4_vals <- modify_list( + s4_vals, + named_args[names(named_args) %in% s4_slot_nms] + ) + named_args <- named_args[!names(named_args) %in% s4_slot_nms] + } + prop_storage_idx <- match(names(named_args), prop_storage_rename(prop_nms)) + names(named_args)[!is.na(prop_storage_idx)] <- + prop_nms[prop_storage_idx[!is.na(prop_storage_idx)]] + vals <- modify_list(vals, named_args) + if (".Data" %in% names(named_args)) { + data_part <- vals$.Data + } + + if (!is.null(data_part)) { + .Object <- S4_initialize_data_part(data_part, .Object) + } + + vals <- modify_list( + S4_initialize_default_values(.Object, names(vals), .S4_default_env), + vals + ) + if (".Data" %in% names(vals)) { + .Object <- S4_initialize_data_part(vals$.Data, .Object) + vals$.Data <- NULL + } + props(.Object, check = FALSE) <- vals + for (name in names(s4_vals)) { + methods::slot(.Object, name) <- s4_vals[[name]] + } + validate(.Object) + .Object +} + +S4_initialize_prop_values <- function(values, properties, storage = FALSE) { + if (!storage) { + return(values[names(values) %in% properties]) + } + + storage_nms <- prop_storage_rename(properties) + idx <- match(names(values), storage_nms) + values <- values[!is.na(idx)] + names(values) <- properties[idx[!is.na(idx)]] + values +} + +S4_initialize_default_values <- function(object, supplied, S4_env) { + class <- S7_class(object) + env <- environment(class) + properties <- class@properties + properties <- properties[!vlapply(properties, prop_is_dynamic)] + property_slot_nms <- prop_storage_rename(names(properties)) + properties <- properties[property_slot_nms %in% methods::slotNames(object)] + properties <- properties[setdiff(names(properties), supplied)] + + values <- list() + for (name in names(properties)) { + slot_name <- prop_storage_rename(name) + if (!S4_slot_has_prototype_value(object, slot_name, S4_env)) { + next + } + + prop <- properties[[name]] + value <- S4_property_default_value( + prop, + env, + class@package, + deferred = TRUE, + allow_simple = identical(name, ".Data") + ) + if (length(value) != 0L) { + values[name] <- value + } + } + values +} + +S4_slot_has_prototype_value <- function(object, name, S4_env) { + prototype <- S4_registered_class(S7_class(object), S4_env)@prototype + value <- methods::slot(object, name) + prototype_value <- methods::slot(prototype, name) + if (identical(value, prototype_value)) { + return(TRUE) + } + if (!identical(name, ".Data")) { + return(FALSE) + } + + identical( + S4_strip_data_part_identity(value), + S4_strip_data_part_identity(prototype_value) + ) +} + +S4_strip_data_part_identity <- function(x) { + attrs <- attributes(x) + attrs[S4_internal_slot_names()] <- NULL + attributes(x) <- attrs + x +} + +S4_initialize_values <- function(object) { + if (isS4(object)) { + slots <- methods::slotNames(object) + values <- stats::setNames( + lapply(slots, methods::slot, object = object), + slots + ) + if (is_S4_data_part_object(object)) { + values$.Data <- S4_data_part(object) + } + values + } else if (S7_inherits(object)) { + props(object) + } else { + attrs <- attributes(object) %||% list() + attrs$class <- NULL + if (is.object(object)) { + attrs$.S3Class <- class(object) + } + c(list(.Data = unclass(object)), attrs) + } +} + +S4_initialize_data_part <- function(value, object) { + if (is_S4_data_part_object(value)) { + value <- S4_data_part(value) + } + protected <- S4_data_part_protected_attributes(object) + incoming <- attributes(value) %||% list() + incoming[protected] <- NULL + if (isS4(object)) { + data <- zap_attr(unclass(value), protected) + methods::slot(object, ".Data") <- data + attributes(object) <- modify_list(attributes(object), incoming) + return(object) + } + + value <- zap_attr(value, protected) + attributes(value) <- modify_list(attributes(object), incoming) + value +} + +S4_data_part_protected_attributes <- function(object) { + attribute_names <- S4_data_part_attribute_names(object) + + c( + setdiff(methods::slotNames(object), attribute_names), + if (has_S7_class(object)) { + setdiff(prop_storage_names(object), attribute_names) + }, + "class", + "_S7_class", + "S7_class" + ) +} + +S4_data_part_attribute_names <- function(object) { + S3_class <- S4_data_part_S3_class(object) + if (is.null(S3_class)) { + return(character()) + } + + unique(unlist( + lapply(S3_class, S4_old_class_data_attribute_names), + use.names = FALSE + )) +} + +S4_old_class_data_attribute_names <- function(class) { + class <- tryCatch( + methods::getClass(class), + error = function(cnd) NULL + ) + if (is.null(class) || !methods::extends(class, "oldClass")) { + return(character()) + } + + setdiff(names(class@slots), c(".Data", ".S3Class")) +} + +S4_data_part_S3_class <- function(object) { + if (has_S7_class(object)) { + base <- base_parent(S7_class(object)) + if (is_S3_class(base)) { + return(base$class) + } + if (!is_S4_class(base) || !".S3Class" %in% names(base@slots)) { + return(NULL) + } + } + + attr(object, ".S3Class", exact = TRUE) +} + is_S4_class <- function(x) inherits(x, "classRepresentation") S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { @@ -45,13 +1183,13 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { # Convert generator function to class if (methods::is(x, "classGeneratorFunction")) { return(S4_to_S7_class( - methods::getClass(as.character(x@className)), + methods::getClass(x@className), error_base, call = call )) } - if (methods::is(x, "ClassUnionRepresentation")) { + if (methods::isClassUnion(x)) { subclasses <- Filter(function(y) y@distance == 1, x@subclasses) subclasses <- lapply(subclasses, function(x) methods::getClass(x@subClass)) do.call("new_union", subclasses) @@ -62,8 +1200,12 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { return(basic_classes[[x@className]]) } } - if (methods::extends(x, "oldClass")) { - new_S3_class(as.character(x@className)) + if (S4_is_reified_S7_class(x)) { + class <- methods::slot(x@prototype, "_S7_class") + return(class) + } + if (is_S3_oldClass(x)) { + new_S3_class(S3_oldClass_classes(x)) } else { x } @@ -76,9 +1218,92 @@ S4_to_S7_class <- function(x, error_base = "", call = sys.call(-1L)) { } } +S4_slot_properties <- function(class) { + slots <- class@slots + slots <- slots[!names(slots) %in% S4_slot_property_internal_names(class)] + slot_names <- names(slots) + property_names <- S4_slot_property_names(class, slot_names) + properties <- Map( + S4_slot_property, + slots, + slot_names, + property_names, + MoreArgs = list(owner = class) + ) + names(properties) <- property_names + properties +} + +S4_slot_property_internal_names <- function(class) { + if (S4_has_reified_S7_old_class_slot(class)) { + S4_internal_slot_names() + } else { + "_S7_class" + } +} + +S4_has_reified_S7_old_class_slot <- function(class) { + S4_is_reified_S7_class(class) || + any(vlapply(class@contains, function(extension) { + super <- methods::getClass(extension@superClass) + S4_is_reified_S7_class(super) + })) +} + +S4_slot_property_names <- function(class, slot_names) { + property_names <- slot_names + inherited <- S4_inherited_S7_property_names(class) + idx <- match(slot_names, names(inherited)) + property_names[!is.na(idx)] <- inherited[idx[!is.na(idx)]] + property_names +} + +S4_inherited_S7_property_names <- function(class) { + properties <- character() + for (extension in class@contains) { + super <- methods::getClass(extension@superClass) + if (!S4_is_reified_S7_class(super)) { + next + } + + s7_class <- methods::slot(super@prototype, "_S7_class") + property_names <- names(s7_class@properties) + storage_names <- prop_storage_rename(property_names) + names(property_names) <- storage_names + properties <- c(properties, property_names) + } + + properties[!duplicated(names(properties))] +} + +S4_slot_property <- function(class, slot_name, property_name, owner) { + new_property( + class = S4_to_S7_class(methods::getClass(class)), + default = S4_slot_prototype_default(owner, slot_name), + name = property_name + ) +} + +S4_slot_prototype_default <- function(class, name) { + if (identical(name, ".Data")) { + return(bquote( + methods::getClass(.(class@className))@prototype@.Data + )) + } + + bquote( + attr( + methods::getClass(.(class@className))@prototype, + .(name), + exact = TRUE + ) + ) +} + S4_basic_classes <- function() { list( NULL = NULL, + ANY = class_any, logical = class_logical, integer = class_integer, double = class_double, @@ -129,13 +1354,37 @@ S4_class_dispatch <- function(x) { } is_oldClass <- function(x) { - x@virtual && methods::extends(x, "oldClass") && x@className != "oldClass" + methods::extends(x, "oldClass") && + x@className %in% attr(x@prototype, ".S3Class") +} + +is_S3_oldClass <- function(x) { + methods::extends(x, "oldClass") && + !"_S7_class" %in% names(x@slots) && + (is_oldClass(x) || is_ordered_oldClass(x)) +} + +is_ordered_oldClass <- function(x) { + identical(as.character(x@className), "ordered") && + identical(attr(x@prototype, ".S3Class"), "factor") +} + +S3_oldClass_classes <- function(x) { + class <- attr(x@prototype, ".S3Class") + if (!x@className %in% class) { + class <- c(as.character(x@className), class) + } + class } S4_class_name <- function(x) { if (is_oldClass(x)) { return(x@className) } + S7_class <- S4_reified_S7_class(x) + if (!is.null(S7_class)) { + return(S7_class_name(S7_class)) + } class <- x@className package <- x@package %||% attr(class, "package") @@ -149,6 +1398,24 @@ S4_class_name <- function(x) { } } +S4_reified_S7_class <- function(x) { + if (!"_S7_class" %in% names(x@slots)) { + return(NULL) + } + + class <- methods::slot(x@prototype, "_S7_class") + if (is_class(class) && class@abstract) class +} + +S4_is_reified_S7_class <- function(x) { + if (!"_S7_class" %in% names(x@slots)) { + return(FALSE) + } + + class <- methods::slot(x@prototype, "_S7_class") + is_class(class) && identical(as.character(x@className), S7_class_name(class)) +} + S4_package_name <- function(f, env) { if (methods::getPackageName(topenv(env), create = FALSE) == f@package) { ## current ns might not be loaded yet, catch here @@ -189,9 +1456,23 @@ find_package_with_symbol <- function(name, env, exclude = NULL) { } S4_remove_classes <- function(classes, where = parent.frame()) { + where <- topenv(where) for (class in classes) { - suppressWarnings(methods::removeClass(class, topenv(where))) + if (methods::isClass(class, where = where)) { + methods::removeClass(class, where) + } } } -globalVariables(c("superClass", "virtual")) +globalVariables(c( + ".Data", + "className", + "distance", + "package", + "prototype", + "slots", + "subclasses", + "subClass", + "superClass", + "virtual" +)) diff --git a/R/class-spec.R b/R/class-spec.R index 59741cae..ca7a5793 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -79,6 +79,15 @@ class_type <- function(x) { } } +class_properties <- function(x) { + switch( + class_type(x), + S7 = attr(x, "properties", exact = TRUE) %||% list(), + S4 = S4_slot_properties(x), + list() + ) +} + class_friendly <- function(x) { switch( class_type(x), @@ -190,12 +199,17 @@ class_constructor <- function(.x) { } class_validate <- function(class, object) { + if (is_S4_class(class)) { + if (has_S7_class(object)) { + return(S4_validate_old_class(class, object)) + } + + check <- methods::validObject(object, test = TRUE) + return(if (isTRUE(check)) NULL else check) + } + validator <- switch( class_type(class), - S4 = function(object) { - check <- methods::validObject(object, test = TRUE) - if (isTRUE(check)) NULL else check - }, S7 = class@validator, S7_base = class$validator, S7_S3 = class$validator, @@ -209,6 +223,246 @@ class_validate <- function(class, object) { } } +S4_validate_old_class <- function( + class, + object, + skip = character(), + skip_slots = character() +) { + any_strings <- function(x) { + if (isTRUE(x)) character() else x + } + + errors <- S4_validate_single_reified_S7_contains(class) + if (length(errors) > 0L) { + return(errors) + } + + errors <- S4_validate_slots(class, object, skip = skip_slots) + extends <- rev(class@contains) + for (ext in extends) { + super_class <- ext@superClass + if (S4_class_key(super_class) %in% skip) { + next + } + if (!ext@simple && !methods::is(object, super_class)) { + next + } + + super_def <- methods::getClassDef(super_class) + if (is.null(super_def)) { + errors <- c( + errors, + sprintf( + "superclass %s not defined in the environment of the object's class", + dQuote(super_class) + ) + ) + break + } + if (S4_is_reified_S7_class(super_def)) { + super_S7 <- methods::slot(super_def@prototype, "_S7_class") + if (!S7_extends_via_S7_parent(S7_class(object), super_S7)) { + errors <- c(errors, S4_validate_reified_S7_class(super_S7, object)) + if (length(errors)) { + break + } + } + next + } + + validity <- methods::getValidity(super_def) + if (is.function(validity)) { + errors <- c( + errors, + any_strings(validity(S4_as_validity_class(object, super_def))) + ) + if (length(errors)) { + break + } + } + } + + if (!S4_class_key(class@className) %in% skip) { + validity <- methods::getValidity(class) + if (length(errors) == 0L && is.function(validity)) { + errors <- c( + errors, + any_strings(validity(S4_as_validity_class(object, class))) + ) + } + } + + if (length(errors) == 0L) { + NULL + } else { + errors + } +} + +S4_validate_single_reified_S7_contains <- function(class) { + classes <- S4_direct_reified_S7_contains(class) + if (length(classes) <= 1L) { + return(character()) + } + + class_names <- vcapply(classes, class_desc) + sprintf( + "%s directly contains multiple S7 classes via S4_contains(): %s", + class_desc(class), + paste(class_names, collapse = ", ") + ) +} + +S4_direct_reified_S7_contains <- function(class) { + contains <- base::Filter(function(x) x@distance == 1, class@contains) + supers <- lapply(contains, function(x) methods::getClassDef(x@superClass)) + supers <- base::Filter( + function(x) !is.null(x) && S4_is_reified_S7_class(x), + supers + ) + lapply(supers, function(x) methods::slot(x@prototype, "_S7_class")) +} + +S4_validate_slots <- function(class, object, skip = character()) { + errors <- character() + slot_types <- class@slots + slot_types <- slot_types[!names(slot_types) %in% skip] + slot_names <- names(slot_types) + attr_names <- c(".Data", ".S3Class", names(attributes(object))) + + missing <- is.na(match(slot_names, attr_names)) + if (any(missing)) { + errors <- c( + errors, + paste( + "slots in class definition but not in object:", + paste0("\"", slot_names[missing], "\"", collapse = ", ") + ) + ) + slot_types <- slot_types[!missing] + slot_names <- slot_names[!missing] + } + + where <- get(".classEnv", envir = asNamespace("methods"))(class) + S3Class <- get("S3Class", envir = asNamespace("methods")) + for (i in seq_along(slot_types)) { + slot_class <- slot_types[[i]] + slot_class_def <- methods::getClassDef(slot_class, where = where) + if (is.null(slot_class_def)) { + errors <- c( + errors, + paste0( + "undefined class for slot \"", + slot_names[[i]], + "\" (\"", + slot_class, + "\")" + ) + ) + next + } + + slot_name <- slot_names[[i]] + value <- tryCatch( + switch( + slot_name, + .S3Class = S3Class(object), + methods::slot(object, slot_name) + ), + error = function(cnd) cnd + ) + if (inherits(value, "error")) { + errors <- c(errors, conditionMessage(value)) + next + } + + ok <- methods::possibleExtends( + class(value), + slot_class, + ClassDef2 = slot_class_def + ) + if (isFALSE(ok)) { + errors <- c( + errors, + paste0( + "invalid object for slot \"", + slot_name, + "\" in class \"", + class(object)[[1L]], + "\": got class \"", + class(value)[[1L]], + "\", should be or extend class \"", + slot_class, + "\"" + ) + ) + } + } + + errors +} + +S4_validate_reified_S7_class <- function(class, object) { + errors <- validate_properties(object, class, parent_class = class@parent) + if (length(errors) > 0L) { + return(errors) + } + + error <- class_validate(class, object) + if (is.null(error)) { + character() + } else if (is.character(error)) { + error + } else { + stop2( + sprintf( + "%s validator must return NULL or a character, not <%s>.", + obj_desc(class), + typeof(error) + ), + call = NULL + ) + } +} + +S7_extends_via_S7_parent <- function(child, parent) { + while (is_class(child)) { + if (identical(child, parent) || isTRUE(all.equal(child, parent))) { + return(TRUE) + } + child <- child@parent + } + + FALSE +} + +S4_as_validity_class <- function(object, class) { + if (isS4(object) || !has_S7_class(object) || class@virtual) { + return(methods::as(object, S4_class_coerce_name(class))) + } + + value <- S4_new_object(class) + values <- S4_initialize_values(object) + slots <- intersect(names(values), methods::slotNames(value)) + for (name in slots) { + methods::slot(value, name) <- values[[name]] + } + value +} + +S4_new_object <- function(class) { + value <- class@prototype + attr(value, "class") <- S4_class_coerce_name(class) + base::asS4(value, TRUE) +} + +S4_class_coerce_name <- function(class) { + name <- class@className + attr(name, "package") <- class@package + name +} + #' Format a class specification as a string #' #' `S7_class_desc()` turns any [class specification][as_class] into a short, @@ -252,8 +506,20 @@ class_dispatch <- function(x) { NULL = "NULL", missing = "MISSING", any = character(), - S4 = S4_class_dispatch(methods::extends(x)), - S7 = c(S7_class_name(x), class_dispatch(x@parent)), + S4 = S4_class_dispatch(x), + S7 = { + parent <- class_dispatch(x@parent) + c( + S7_class_name(x), + parent, + if ( + is_S4_class(x@parent) && + !identical(utils::tail(parent, 1), "S7_object") + ) { + "S7_object" + } + ) + }, S7_base = c(x$class, "S7_object"), S7_S3 = c(x$class, "S7_object"), stop2("Unsupported class type.", call = NULL) @@ -299,8 +565,8 @@ class_inherits <- function(x, what) { "NULL" = is.null(x), missing = FALSE, any = TRUE, - S4 = isS4(x) && methods::is(x, what), - S7 = inherits(x, "S7_object") && inherits(x, S7_class_name(what)), + S4 = inherits_S4_class(x, what), + S7 = has_S7_class(x) && inherits(x, S7_class_name(what)), S7_base = what$class == base_class(x), S7_union = any(vlapply(what$classes, class_inherits, x = x)), S7_S3 = !isS4(x) && class_dispatch_extends(what$class, class(x)), @@ -328,10 +594,18 @@ class_extends <- function(child, parent) { } else if (is.null(parent)) { # as a parent, NULL only accepts NULL is.null(child) + } else if (is_S4_class(child) && is_class(parent)) { + parent_class <- S4_registered_class_or_null(parent, environment(parent)) + !is.null(parent_class) && + methods::extends(child@className, parent_class@className) } else if (is_S4_class(child) || is_S4_class(parent)) { - is_S4_class(child) && - is_S4_class(parent) && - methods::extends(child@className, parent@className) + if (!is_S4_class(parent)) { + FALSE + } else { + child <- if (is_S4_class(child)) child else S4_ancestor(child) + !is.null(child) && + methods::extends(child@className, parent@className) + } } else if (is_class(parent) && parent@name == "S7_object") { is_class(child) } else { @@ -343,10 +617,10 @@ class_extends <- function(child, parent) { obj_type <- function(x) { if (identical(x, quote(expr = ))) { "missing" - } else if (inherits(x, "S7_object")) { - "S7" } else if (isS4(x)) { "S4" + } else if (has_S7_class(x)) { + "S7" } else if (is.object(x)) { "S3" } else { @@ -395,5 +669,22 @@ union_contains_any <- function(x) { is_union(x) && any(vlapply(x$classes, is_class_any)) } -# Suppress @className false positive -globalVariables("className") +inherits_S4_class <- function(x, what) { + if (identical(as.character(what@className), "ANY")) { + return(TRUE) + } + if (has_S7_class(x)) { + class <- S7_class(x) + if (is_class(class) && class_extends(class, what)) { + return(TRUE) + } + } + if (!inherits_S4(x) && is.object(x)) { + return(FALSE) + } + + methods::is(x, what) +} + +# Suppress direct S4 representation slot false positives +globalVariables(c("className", "contains", "simple")) diff --git a/R/class.R b/R/class.R index 4cbf99bf..53bcec36 100644 --- a/R/class.R +++ b/R/class.R @@ -15,9 +15,10 @@ #' `Foo := new_class(...)`. This object both represents the class and is used #' to construct new instances of the class. #' @param parent The parent class to inherit behavior from. -#' There are three options: +#' There are four options: #' #' * An S7 class, like [S7_object]. +#' * An S4 class, like the result of [methods::getClass()]. #' * An S3 class wrapped by [new_S3_class()]. #' * A base type, like [class_logical], [class_integer], etc. #' @param package Package name. This is automatically resolved if the class is @@ -55,6 +56,17 @@ #' belong to each instance of the class. Each element of the list can #' either be a type specification (processed by [as_class()]) or a #' full property specification created [new_property()]. +#' @section S4 compatibility: +#' `new_class()` can use an S4 class definition or class generator as its +#' `parent`. S4 parent slots become S7 properties, the class is registered with +#' S4 automatically, and S4 generics can dispatch through the S4 parent. +#' +#' S7 objects that directly extend S4 are represented as S3 old-class objects, +#' so `isS4()` is `FALSE` even though [methods::is()] and S4 dispatch see the +#' S4 parent. S4 classes can extend S7 classes by calling +#' [S4_contains()] in `methods::setClass(contains = )`. +#' +#' See `vignette("compatibility")` for examples and caveats. #' @return A object constructor, a function that can be used to create objects #' of the given class. #' @export @@ -125,18 +137,28 @@ new_class <- function( } if ( abstract && - (!is_class(parent) || !(parent@abstract || parent@name == "S7_object")) + !((is_class(parent) && + (parent@abstract || parent@name == "S7_object")) || + (is_S4_class(parent) && parent@virtual)) ) { stop2("Abstract classes must have abstract parents.") } } - # Combine properties from parent, overriding as needed - parent_props <- attr(parent, "properties", exact = TRUE) %||% list() + if (is_S4_class(parent)) { + S4_check_slot_storage(parent, call = sys.call()) + } + + parent_props <- class_properties(parent) new_props <- as_properties(properties) check_prop_names(new_props) check_prop_overrides(new_props, parent_props, name, parent) + # Combine properties from parent, overriding as needed + all_props <- parent_props + all_props[names(new_props)] <- new_props + check_prop_storage_names(all_props) + if (is.null(constructor)) { constructor <- new_constructor( parent, @@ -151,13 +173,17 @@ new_class <- function( attr(object, "name") <- name attr(object, "parent") <- parent attr(object, "package") <- package - attr(object, "properties") <- modify_list(parent_props, new_props) + attr(object, "properties") <- all_props attr(object, "abstract") <- abstract attr(object, "constructor") <- constructor attr(object, "validator") <- validator class(object) <- c("S7_class", "S7_object") - global_variables(names(new_props)) + if (S7_extends_S4(object)) { + S4_register_subclass(object, env = parent.frame()) + } + + global_variables(names(all_props)) object } globalVariables(c( @@ -249,7 +275,9 @@ c.S7_class <- function(...) { stop2("Can not combine S7 class objects.") } -can_inherit <- function(x) is_base_class(x) || is_S3_class(x) || is_class(x) +can_inherit <- function(x) { + is_base_class(x) || is_S3_class(x) || is_class(x) || is_S4_class(x) +} check_can_inherit <- function( x, @@ -258,7 +286,7 @@ check_can_inherit <- function( ) { if (!can_inherit(x)) { msg <- sprintf( - "`%s` must be an S7 class, S3 class, or base type, not %s.", + "`%s` must be an S7 class, S4 class, S3 class, or base type, not %s.", arg, class_friendly(x) ) @@ -294,6 +322,28 @@ check_parent <- function(parent, class, call = sys.call(-1L)) { return() } + # S4 parent compatibility is checked after new_object() installs the S7 + # class attributes, at which point methods::validObject() can see the + # registered oldClass structure. + if (is_S4_class(parent_class)) { + if (isS4(parent)) { + stop2( + "`_parent` must not be an S4 object when class has an S4 parent.", + call = call + ) + } + if ( + !".Data" %in% names(parent_class@slots) && + !is_S7_type(parent) + ) { + stop2( + "`_parent` must be an when class has an S4 parent without a data part.", + call = call + ) + } + return() + } + if (class_inherits(parent, parent_class)) { return() } @@ -335,7 +385,7 @@ new_object <- function(`_parent`, ...) { args <- collect_dots(...) has_setter <- vlapply(class@properties[names(args)], prop_has_setter) - self_attrs <- args[!has_setter] + self_attrs <- lapply(args[!has_setter], prop_encode_pseudo_null) names(self_attrs) <- prop_storage_rename(names(self_attrs)) # We must awkwardly operate on `_parent` rather than binding to a local @@ -426,7 +476,11 @@ S7_class <- function(object) { obj_type(object), missing = class_missing, S7 = .Call(S7_class_, object), - S4 = methods::getClass(class(object)), + S4 = if (has_S7_class(object)) { + .Call(S7_class_, object) + } else { + methods::getClass(class(object)) + }, S3 = new_S3_class(class(object)), base = base_S7_class(object) ) @@ -442,6 +496,27 @@ check_prop_names <- function(properties, call = sys.call(-1L)) { } } +check_prop_storage_names <- function(properties, call = sys.call(-1L)) { + nms <- names2(properties) + if (length(nms) == 0L) { + return(invisible()) + } + + storage_nms <- prop_storage_rename(nms) + if (!anyDuplicated(storage_nms)) { + return(invisible()) + } + + storage_name <- storage_nms[duplicated(storage_nms)][[1L]] + prop_nms <- nms[storage_nms == storage_name] + msg <- sprintf( + "Properties %s must not use the same storage name %s.", + paste(dQuote(prop_nms), collapse = ", "), + dQuote(storage_name) + ) + stop2(msg, call = call) +} + check_prop_overrides <- function( child_props, parent_props, @@ -450,10 +525,26 @@ check_prop_overrides <- function( call = sys.call(-1L) ) { overridden <- intersect(names(child_props), names(parent_props)) + s4_parent <- if (is_S4_class(parent)) parent else S4_ancestor(parent) + s4_slots <- if (is.null(s4_parent)) character() else names(s4_parent@slots) for (prop in overridden) { child_prop <- child_props[[prop]] + if ( + prop %in% + s4_slots && + (prop_is_dynamic(child_prop) || prop_has_setter(child_prop)) + ) { + msg <- sprintf( + "Can't override inherited S4 slot %s@%s with a custom %s.", + class_desc(s4_parent), + prop, + if (prop_is_dynamic(child_prop)) "getter" else "setter" + ) + stop2(msg, call = call) + } + # Dynamic properties are computed, not stored, so they're never validated # against the parent's type if (prop_is_dynamic(child_prop)) { diff --git a/R/compatibility.R b/R/compatibility.R index b7421ee9..0f98fec5 100644 --- a/R/compatibility.R +++ b/R/compatibility.R @@ -14,7 +14,7 @@ activate_backward_compatiblility <- function() { `@` <- function(object, name) { if (inherits(object, "S7_object")) { name <- as.character(substitute(name)) - prop(object, name) + prop_or_slot(object, name) } else { name <- substitute(name) do.call(base::`@`, list(object, name)) diff --git a/R/constructor.R b/R/constructor.R index 528ae371..f84a3b9c 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -6,22 +6,39 @@ new_constructor <- function( ) { properties <- as_properties(properties) + if (is_S4_class(parent)) { + return(new_S4_constructor(parent, properties, envir, package)) + } + if (identical(parent, S7_object) || (is_class(parent) && parent@abstract)) { # There's no parent constructor to delegate to, so the constructor must # handle all properties: inherited and newly declared (which win). + parent_props <- attr(parent, "properties", exact = TRUE) all_props <- modify_list( - attr(parent, "properties", exact = TRUE), + parent_props, properties ) arg_info <- constructor_args(parent, all_props, envir, package) - self_args <- as_names(names(arg_info$self)) + force_args <- as_names(names(arg_info$self)) + s4_parent <- S4_ancestor(parent) + s4_data_part <- !is.null(s4_parent) && ".Data" %in% names(s4_parent@slots) + self_arg_names <- names(arg_info$self) + parent_call <- if (s4_data_part) { + self_arg_names <- setdiff(self_arg_names, ".Data") + quote(.Data) + } else if (has_S7_symbols(envir, "S7_object")) { + quote(S7_object()) + } else { + quote(S7::S7_object()) + } + self_args <- as_names(self_arg_names) new_object_call <- - if (has_S7_symbols(envir, "new_object", "S7_object")) { - bquote(new_object(S7_object(), ..(self_args)), splice = TRUE) + if (has_S7_symbols(envir, "new_object")) { + bquote(new_object(.(parent_call), ..(self_args)), splice = TRUE) } else { - bquote(S7::new_object(S7::S7_object(), ..(self_args)), splice = TRUE) + bquote(S7::new_object(.(parent_call), ..(self_args)), splice = TRUE) } return(new_function( @@ -30,7 +47,7 @@ new_constructor <- function( quote(`{`), # Force all promises here so that any errors are signaled from # the constructor() call instead of the new_object() call. - unname(self_args), + unname(force_args), new_object_call )), env = envir @@ -97,6 +114,126 @@ new_constructor <- function( new_function(constr_args[constr_nms], child_call, env) } +new_S4_constructor <- function(parent, properties, envir, package) { + parent_props <- class_properties(parent) + parent_nms <- names2(parent_props) + override_nms <- intersect(names2(properties), parent_nms) + self_props <- properties[setdiff(names2(properties), parent_nms)] + + parent_args <- as.pairlist(lapply( + setNames(, parent_nms), + function(name) { + if (name %in% override_nms) { + prop_default(properties[[name]], envir, package) + } else if (parent@virtual) { + prop_default(parent_props[[name]], envir, package) + } else { + quote(expr = ) + } + } + )) + self_args <- constructor_args(S7_object, self_props, envir, package)$self + constr_args <- modify_list(parent_args, self_args) + + parent_arg_exprs <- lapply(parent_nms, function(name) { + value <- as.name(name) + if (name %in% override_nms) { + bquote(.parent_args[.(name)] <- list(.(value))) + } else { + bquote(if (!missing(.(value))) .parent_args[.(name)] <- list(.(value))) + } + }) + + parent_value_nms <- setdiff(parent_nms, ".Data") + parent_value_storage_nms <- prop_storage_rename(parent_value_nms) + parent_value_args <- if (parent@virtual) { + as_names(parent_value_nms) + } else { + lapply(parent_value_storage_nms, function(name) { + bquote(.parent_values[[.(name)]]) + }) + } + names(parent_value_args) <- parent_value_nms + + self_value_args <- as_names(names2(self_args)) + parent_seed <- if (parent@virtual) { + quote(.parent_seed) + } else if (".Data" %in% parent_nms) { + quote(.parent_values[[".Data"]]) + } else { + quote(.S7_object()) + } + virtual_parent_seed <- if (".Data" %in% parent_nms) { + quote(.Data) + } else { + quote(.S7_object()) + } + new_object_call <- as.call(c( + list(quote(.S7_new_object), parent_seed), + parent_value_args, + self_value_args + )) + + env <- new.env(parent = envir) + env$.S4_parent <- class_constructor(parent) + env$.S4_initialize_parent <- S4_initialize_parent(parent@className) + env$.S4_initialize_values <- S4_initialize_values + env$.S7_new_object <- new_object + env$.S7_object <- S7_object + + body <- if (parent@virtual) { + as.call(c( + quote(`{`), + quote(.parent_args <- list()), + parent_arg_exprs, + list( + bquote(.parent_seed <- .(virtual_parent_seed)), + quote(attr(.parent_seed, ".should_validate") <- FALSE), + bquote(.object <- .(new_object_call)), + quote(attr(.object, ".should_validate") <- NULL), + quote(do.call(.S4_initialize_parent, c(list(.object), .parent_args))) + ) + )) + } else { + as.call(c( + quote(`{`), + quote(.parent_args <- list()), + parent_arg_exprs, + list( + quote(.parent <- do.call(.S4_parent, .parent_args)), + quote(.parent_values <- .S4_initialize_values(.parent)), + new_object_call + ) + )) + } + + new_function( + constr_args, + body, + env + ) +} + +S4_initialize_parent <- function(class) { + force(class) + function(.Object, ...) { + method <- methods::selectMethod("initialize", class) + if (methods::is(method, "derivedDefaultMethod")) { + attr(.Object, ".should_validate") <- NULL + validate(.Object) + return(.Object) + } + + object_class <- class(.Object) + class(.Object) <- class + out <- method(.Object, ...) + class(out) <- object_class + attr(out, ".should_validate") <- NULL + validate(out) + out + } +} + constructor_args <- function( parent, properties = list(), diff --git a/R/convert.R b/R/convert.R index 97d81324..01471785 100644 --- a/R/convert.R +++ b/R/convert.R @@ -128,6 +128,8 @@ convert <- function(from, to, ...) { convert_down(from, to, dots) } else if (is_base_class(to)) { base_coerce(from, to, ...) + } else if (is_S4_coerce(from, to)) { + convert_S4(from, to, ...) } else { msg <- paste_c( "Can't find method with dispatch classes:\n", @@ -179,15 +181,38 @@ convert_up <- function(from, to, call = sys.call(-1L)) { from <- zap_attr(from, c(from_props, "_S7_class", "S7_class")) class(from) <- to$class } else if (is_class(to)) { - to_props <- prop_storage_rename(names(to@properties)) + to_prop_nms <- names(to@properties) + to_props <- prop_storage_rename(to_prop_nms) if (to@abstract) { msg <- sprintf("Can't convert to abstract class <%s>.", to@name) stop2(msg, call = call) } - from <- zap_attr(from, c(setdiff(from_props, to_props), "S7_class")) + is_s4_subclass <- isS4(from) && + is_class(from_class) && + !identical(class(from)[[1L]], S7_class_name(from_class)) + s4_slot_attrs <- if (is_s4_subclass) { + setdiff(methods::slotNames(from), c(to_props, ".Data")) + } else { + character() + } + class_attrs <- c("_S7_class", setdiff("S7_class", to_props)) + from <- zap_attr( + from, + c(setdiff(from_props, to_props), s4_slot_attrs, class_attrs) + ) attr(from, "_S7_class") <- to - class(from) <- class_dispatch(to) + if (is_s4_subclass) { + from <- suppressWarnings(`class<-`(from, class_dispatch(to))) + } else { + class(from) <- class_dispatch(to) + } + } else if ( + is_S4_class(to) && is_class(from_class) && class_extends(from_class, to) + ) { + from <- S4_as_validity_class(from, to) + } else if (is_S4_coerce(from, to)) { + from <- convert_S4(from, to) } else { stop2("Unreachable.") } @@ -202,6 +227,20 @@ convert_down <- function(from, to, user_args = list()) { from_class <- S7_class(from) if (!is_class(from_class)) { + if (isS4(from)) { + from_slot_values <- S4_initialize_values(from) + from_slot_names <- names(from_slot_values) + + to_constructor_arg_names <- names(formals(to)) + if (!"..." %in% to_constructor_arg_names) { + from_slot_names <- intersect(from_slot_names, to_constructor_arg_names) + } + + from_slot_names <- setdiff(from_slot_names, names(user_args)) + constructor_args <- c(from_slot_values[from_slot_names], user_args) + return(do.call(to, constructor_args)) + } + # `from` is a base or S3 object; pass it as `.data` to the constructor user_args$.data <- from return(do.call(to, user_args)) @@ -229,6 +268,33 @@ convert_down <- function(from, to, user_args = list()) { do.call(to, constructor_args) } +s4_to_name <- function(x) { + if (is_S4_class(x)) { + return(x@className) + } + + class <- S4_registered_class_or_null(x, environment(x)) + if (is.null(class)) { + NULL + } else { + class@className + } +} + +is_S4_coerce <- function(from, to) { + # can loosen this restriction once convert() has default base targets + if (!inherits_S4(from) && !is_S4_class(to)) { + return(FALSE) + } + + to_name <- s4_to_name(to) + !is.null(to_name) && methods::canCoerce(from, to_name) +} + +convert_S4 <- function(from, to, ...) { + methods::as(from, s4_to_name(to), ...) +} + # Converted to S7_generic onLoad in order to avoid dependency between files on_load_make_convert_generic <- function() { convert <<- S7_generic( diff --git a/R/data.R b/R/data.R index 59945feb..6fa784f2 100644 --- a/R/data.R +++ b/R/data.R @@ -28,6 +28,10 @@ S7_data <- function(object) { check_is_S7(object) check_not_environment(object, "S7_data()") + if (is_S4_data_part_object(object)) { + return(S4_data_part(object)) + } + out <- zap_attr( object, c(prop_storage_names(object), "class", "_S7_class", "S7_class") @@ -54,6 +58,14 @@ base_parent <- function(class) { check_is_S7(object) check_not_environment(object, "S7_data<-") + if (is_S4_data_part_object(object)) { + object <- S4_initialize_data_part(value, object) + if (isTRUE(check)) { + validate(object) + } + return(invisible(object)) + } + s7_attrs <- c(prop_storage_names(object), "class", "_S7_class", "S7_class") for (name in s7_attrs) { attr(value, name) <- attr(object, name, exact = TRUE) @@ -64,6 +76,32 @@ base_parent <- function(class) { return(invisible(value)) } +is_S4_data_part_object <- function(object) { + if (isS4(object)) { + return(".Data" %in% methods::slotNames(object)) + } + + if (!S7_inherits(object)) { + return(FALSE) + } + + class <- S7_class(object) + parent <- if (is_class(class)) S4_ancestor(class) + !is.null(parent) && ".Data" %in% names(parent@slots) +} + +S4_data_part <- function(object) { + data <- methods::slot(object, ".Data") + attrs <- attributes(object) %||% list() + S3_class <- S4_data_part_S3_class(object) + attrs[c(S4_data_part_protected_attributes(object), ".S3Class")] <- NULL + attributes(data) <- modify_list(attributes(data), attrs) + if (!is.null(S3_class)) { + class(data) <- S3_class + } + data +} + zap_attr <- function(x, names) { for (name in names) { attr(x, name) <- NULL diff --git a/R/inherits.R b/R/inherits.R index adb55887..d7c57a92 100644 --- a/R/inherits.R +++ b/R/inherits.R @@ -40,12 +40,19 @@ S7_inherits <- function(x, class = NULL) { class <- as_class(class) if (is.null(class)) { - inherits(x, "S7_object") + has_S7_class(x) } else { class_inherits(x, class) } } +has_S7_class <- function(x) { + inherits(x, "S7_object") && + (identical(class(x), "S7_object") || + inherits(x, "S7_class") || + !is.null(.Call(S7_class_, x))) +} + #' @export #' @rdname S7_inherits # called from src/prop.c diff --git a/R/method-register-S3.R b/R/method-register-S3.R index 42e7e614..c9d81dfe 100644 --- a/R/method-register-S3.R +++ b/R/method-register-S3.R @@ -5,6 +5,7 @@ register_S3_method <- function( envir = parent.frame(), call = sys.call(-1L) ) { + S4_envir <- envir sig <- signature[[1]] class <- switch( @@ -29,6 +30,10 @@ register_S3_method <- function( envir <- environment(generic$generic) %||% envir registerS3method(generic$name, class, method, envir) } + + if (should_register_S4_method(generic, signature)) { + register_S4_method(generic$name, signature, method, S4_envir, call = call) + } } # `registerS3method()` registers into the S3 methods table of diff --git a/R/method-register-S4.R b/R/method-register-S4.R index 1e083cb2..2417eaef 100644 --- a/R/method-register-S4.R +++ b/R/method-register-S4.R @@ -10,47 +10,50 @@ register_S4_method <- function( methods::setMethod(generic, S4_signature, method, where = S4_env) } -S4_class <- function(x, S4_env, call = sys.call(-1L)) { +should_register_S4_method <- function(generic, signature) { + is_internal_S3_generic(generic) && signature_has_S4_ancestor(signature) +} + +signature_has_S4_ancestor <- function(signature) { + any(vlapply(signature, class_has_S4_ancestor)) +} + +class_has_S4_ancestor <- function(class) { switch( - class_type(x), - `NULL` = "NULL", - missing = "missing", - any = "ANY", - S7_base = base_to_S4(x$class), - S4 = x, - S7 = S4_registered_class(x, S4_env = S4_env, call = call), - S7_S3 = S4_registered_class(x, S4_env = S4_env, call = call), - S7_union = stop2( - "Internal error: union should be flattened upstream.", - call = NULL - ) + class_type(class), + S4 = TRUE, + S7 = S7_extends_S4(class), + FALSE ) } -# S4 dispatch uses `class()` to find a method, but `class(1.5)` is "numeric", -# not "double", so registering under "double" silently misses real doubles. -# Mapping to "numeric" catches doubles but also matches integers too. There's -# no clean S4 way to say "doubles only" and this seems likely to be what -# people want. -base_to_S4 <- function(class) { - switch(class, double = "numeric", class) +S3_generic_S4_signature <- function(generic) { + if (!is_internal_S3_generic(generic)) { + return(NULL) + } + + generic <- methods::getGeneric(generic$name) + if (is.null(generic) || !is_S4_generic(generic)) { + return(NULL) + } + + generic@signature } -S4_registered_class <- function( - x, - S4_env, - call = sys.call(-1L) -) { - class <- tryCatch( - methods::getClass(class_register(x), where = S4_env), - error = function(err) NULL - ) - if (is.null(class)) { - msg <- sprintf( - "Class has not been registered with S4; please call S4_register(%s).", - class_deparse(x) +is_external_S3_generic <- function(generic) { + is_external_generic(generic) && + identical(generic$dispatch_args, "__S3__") +} + +is_internal_S3_generic <- function(generic) { + if (is_S3_generic(generic)) { + return( + is_internal_generic(generic$name) && + identical(find_base_name(generic$generic), generic$name) ) - stop2(msg, call = call) } - class + + is_external_S3_generic(generic) && + identical(generic$package, "base") && + is_internal_generic(generic$name) } diff --git a/R/method-register.R b/R/method-register.R index 2afd6ea3..1ae0fb28 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -231,10 +231,18 @@ as_signature <- function(signature, generic, call = sys.call(-1L)) { } n <- generic_n_dispatch(generic) + + if (is_plain_list(signature)) { + S4_signature <- S3_generic_S4_signature(generic) + if (!is.null(S4_signature) && length(signature) == length(S4_signature)) { + n <- length(S4_signature) + } + } + if (n == 1) { # Accept a bare list of length 1 too, for symmetry with multi-dispatch # generics where a list is required (#555). - if (is.list(signature) && !is.object(signature) && length(signature) == 1) { + if (is_plain_list(signature) && length(signature) == 1) { signature <- signature[[1]] } new_signature(list(as_class(signature, arg = "signature"))) diff --git a/R/property.R b/R/property.R index dc3d62ba..eda65b04 100644 --- a/R/property.R +++ b/R/property.R @@ -277,6 +277,10 @@ class_default_desc <- function(class, package = NULL) { #' lexington@height <- 14 #' prop(lexington, "height") <- 15 prop <- function(object, name) { + if (prop_is_S4_data_part(object, name)) { + return(S7_data(object)) + } + .Call(prop_, object, name) } @@ -285,9 +289,31 @@ prop <- function(object, name) { #' [validate()] on the object before returning. #' @export `prop<-` <- function(object, name, check = TRUE, value) { + if (prop_is_S4_data_part(object, name)) { + property <- S7_class(object)@properties[[name]] + if (isTRUE(check)) { + error <- prop_validate(property, value, object) + if (!is.null(error)) { + signal_prop_error(error, object, name) + } + } + + object <- `S7_data<-`(object, check = FALSE, value = value) + if (isTRUE(check)) { + validate(object) + } + return(object) + } + .Call(prop_set_, object, name, check, value) } +prop_is_S4_data_part <- function(object, name) { + identical(name, ".Data") && + !isS4(object) && + is_S4_data_part_object(object) +} + # called from src/prop.c signal_prop_error <- function(msg, object, name) { stop2(msg, call = prop_call(object, name)) @@ -361,10 +387,26 @@ prop_call <- function(object, name) { #' @usage object@name #' @rawNamespace if (getRversion() >= "4.3.0") S3method(base::`@`, S7_object) #' @name prop -`@.S7_object` <- prop +prop_or_slot <- function(object, name) { + if (isS4(object) && !name %in% names(S7_class(object)@properties)) { + return(methods::slot(object, name)) + } + + prop(object, name) +} + +`@.S7_object` <- prop_or_slot #' @rawNamespace S3method("@<-",S7_object) -`@<-.S7_object` <- `prop<-` +`@<-.S7_object` <- function(object, name, value) { + if (isS4(object) && !name %in% names(S7_class(object)@properties)) { + methods::slot(object, name) <- value + return(object) + } + + prop(object, name) <- value + object +} #' Property introspection @@ -589,6 +631,10 @@ prop_storage_rename <- function(names) { .Call(prop_storage_rename_, names) } +prop_encode_pseudo_null <- function(value) { + if (is.null(value)) as.name("\001NULL\001") else value +} + prop_storage_names <- function(object) { prop_storage_rename(prop_names(object)) } diff --git a/R/utils.R b/R/utils.R index 59f7e648..5dbd0717 100644 --- a/R/utils.R +++ b/R/utils.R @@ -227,6 +227,9 @@ deparse_trunc <- function(x, width, collapse = "\n") { x } +is_plain_list <- function(x) { + is.list(x) && !is.object(x) +} # For older versions of R ---------------------------------------------------- deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) { diff --git a/R/valid.R b/R/valid.R index 86dbf7ef..f7caaa77 100644 --- a/R/valid.R +++ b/R/valid.R @@ -66,7 +66,7 @@ validate <- function(object, recursive = TRUE, properties = TRUE) { check_is_S7(object) - parent <- if (!recursive) S7_class(object)@parent + parent <- validate_parent(object, recursive) validate_from( object, parent = parent, @@ -75,6 +75,20 @@ validate <- function(object, recursive = TRUE, properties = TRUE) { ) } +validate_parent <- function(object, recursive) { + if (!recursive) { + return(S7_class(object)@parent) + } + + if ( + isS4(object) && has_S7_class(object) && !S7_extends_S4(S7_class(object)) + ) { + return(S7_object) + } + + NULL +} + # validates `object` assuming `parent` (if supplied) has been validated validate_from <- function( object, @@ -125,6 +139,8 @@ validate_from <- function( class <- class@parent } + errors <- c(errors, validate_S4_subclass(object)) + # If needed, report errors if (length(errors) > 0) { bullets <- paste0("- ", errors, collapse = "\n") @@ -135,6 +151,30 @@ validate_from <- function( invisible(object) } +validate_S4_subclass <- function(object) { + if (!isS4(object) || !has_S7_class(object)) { + return(NULL) + } + + class <- methods::getClass(class(object)) + if (S4_is_reified_S7_class(class)) { + return(NULL) + } + + ancestor <- S4_ancestor(S7_class(object)) + skip <- if (is.null(ancestor)) character() else S4_validity_classes(ancestor) + skip_slots <- if (is.null(ancestor)) character() else names(ancestor@slots) + S4_validate_old_class(class, object, skip = skip, skip_slots = skip_slots) +} + +S4_validity_classes <- function(class) { + classes <- c( + lapply(class@contains, methods::slot, "superClass"), + list(class@className) + ) + S4_class_keys(classes) +} + validate_properties <- function(object, class, parent_class = NULL) { errors <- character() parent_props <- if (is_class(parent_class)) parent_class@properties diff --git a/R/zzz.R b/R/zzz.R index 5b9bc2fe..a9794809 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -22,6 +22,7 @@ S7_object <- new_class( } ) methods::setOldClass("S7_object") +methods::setOldClass(c("S7_class", "S7_object")) .S7_type <- NULL # Defined onLoad because it depends on R version diff --git a/man/S4_register.Rd b/man/S4_register.Rd index 14766a99..6b641b79 100644 --- a/man/S4_register.Rd +++ b/man/S4_register.Rd @@ -2,24 +2,49 @@ % Please edit documentation in R/S4.R \name{S4_register} \alias{S4_register} -\title{Register an S7 or S3 class with S4} +\alias{S4_contains} +\title{Register an S7, S3, or union class with S4} \usage{ S4_register(class, env = parent.frame()) + +S4_contains(class, env = parent.frame()) } \arguments{ -\item{class}{An S7 class created with \code{\link[=new_class]{new_class()}}, or an S3 class created -with \code{\link[=new_S3_class]{new_S3_class()}}.} +\item{class}{An S7 class created with \code{\link[=new_class]{new_class()}}, or, for +\code{S4_register()} only, an S3 class created with \code{\link[=new_S3_class]{new_S3_class()}} or an S7 +union created with \code{\link[=new_union]{new_union()}}.} \item{env}{Expert use only. Environment where S4 class will be registered.} } \value{ -Nothing; the function is called for its side-effect. +Called for its side effects and invisibly returns the registered S4 class +name. } \description{ If you want to use \link{method<-} to register a method for an S4 generic with -an S7 class or an S3 class (created by \code{\link[=new_S3_class]{new_S3_class()}}), you need to call -\code{S4_register()} once. +an S7 class that does not extend an S4 class, or an S3 class created by +\code{\link[=new_S3_class]{new_S3_class()}}, you need to call \code{S4_register()} once. Classes created by +\code{\link[=new_class]{new_class()}} with an S4 parent are registered automatically. +} +\section{Details}{ + +\code{S4_register()} registers an S7 class, S3 class, or S7 union with S4 and +invisibly returns the registered S4 class name. +For S7 classes, this creates a virtual S4 old class that exposes stored S7 +properties as S4 slots and carries the \code{_S7_class} slot needed for S7 dispatch +and validation. + +After registration, \code{S4_contains()} returns the virtual S4 class name to use +when an S4 class should extend an S7 class with +\code{methods::setClass(contains = )}. It asserts that the S7 properties can +safely cross the S4 inheritance boundary. + +Register S7 unions with \code{S4_register()} before using them in S4 slots or +method signatures unless an equivalent S4 union already exists. + +See \code{vignette("compatibility")} for examples and caveats. } + \examples{ methods::setGeneric("S4_generic", function(x) { standardGeneric("S4_generic") @@ -30,4 +55,9 @@ S4_register(Foo) method(S4_generic, Foo) <- function(x) "Hello" S4_generic(Foo()) + +S4Foo := new_class(properties = list(x = class_numeric), package = "S7") +S4_register(S4Foo) +S4Foo_S4 <- S4_contains(S4Foo) +methods::setClass("S4Child", contains = S4Foo_S4) } diff --git a/man/new_class.Rd b/man/new_class.Rd index b5a3251b..304cbda7 100644 --- a/man/new_class.Rd +++ b/man/new_class.Rd @@ -27,9 +27,10 @@ with this name, i.e. \code{Foo <- new_class("Foo", ...)} or to construct new instances of the class.} \item{parent}{The parent class to inherit behavior from. -There are three options: +There are four options: \itemize{ \item An S7 class, like \link{S7_object}. +\item An S4 class, like the result of \code{\link[methods:getClass]{methods::getClass()}}. \item An S3 class wrapped by \code{\link[=new_S3_class]{new_S3_class()}}. \item A base type, like \link{class_logical}, \link{class_integer}, etc. }} @@ -92,6 +93,20 @@ when an object is passed to a generic. Learn more in \code{vignette("classes-objects")} } +\section{S4 compatibility}{ + +\code{new_class()} can use an S4 class definition or class generator as its +\code{parent}. S4 parent slots become S7 properties, the class is registered with +S4 automatically, and S4 generics can dispatch through the S4 parent. + +S7 objects that directly extend S4 are represented as S3 old-class objects, +so \code{isS4()} is \code{FALSE} even though \code{\link[methods:is]{methods::is()}} and S4 dispatch see the +S4 parent. S4 classes can extend S7 classes by calling +\code{\link[=S4_contains]{S4_contains()}} in \code{methods::setClass(contains = )}. + +See \code{vignette("compatibility")} for examples and caveats. +} + \examples{ # Create an class that represents a range using a numeric start and end Range := new_class( diff --git a/src/prop.c b/src/prop.c index 0cd4751f..fff38e7b 100644 --- a/src/prop.c +++ b/src/prop.c @@ -165,11 +165,26 @@ SEXP prop_storage_rename_(SEXP names) { } +static inline +SEXP object_class(SEXP object) { + if (Rf_isS4(object)) { + static SEXP sym_dot_S3Class = NULL; + if (sym_dot_S3Class == NULL) + sym_dot_S3Class = Rf_install(".S3Class"); + + return R_has_slot(object, sym_dot_S3Class) ? + R_do_slot(object, sym_dot_S3Class) : + R_NilValue; + } + + return Rf_getAttrib(object, R_ClassSymbol); +} + static inline Rboolean inherits2(SEXP object, const char* name) { // like inherits in R, but iterates over the class STRSXP vector // in reverse, since S7_* is typically at the tail. - SEXP klass = Rf_getAttrib(object, R_ClassSymbol); + SEXP klass = object_class(object); if (TYPEOF(klass) == STRSXP) { for (int i = Rf_length(klass)-1; i >= 0; i--) { if (strcmp(CHAR(STRING_ELT(klass, i)), name) == 0) @@ -196,6 +211,40 @@ void check_is_S7(SEXP object) { signal_is_not_S7(object); } +static inline +SEXP pseudo_null(void) { + static SEXP pseudo_NULL = NULL; + if (pseudo_NULL == NULL) + pseudo_NULL = Rf_install("\001NULL\001"); + return pseudo_NULL; +} + +static inline +Rboolean prop_has_storage_slot(SEXP object, SEXP storage_sym) { + return Rf_isS4(object) && R_has_slot(object, storage_sym); +} + +static inline +SEXP prop_get_storage(SEXP object, SEXP name_sym) { + SEXP storage_sym = prop_storage_sym(name_sym); + SEXP value = prop_has_storage_slot(object, storage_sym) ? + R_do_slot(object, storage_sym) : + Rf_getAttrib(object, storage_sym); + return value == pseudo_null() ? R_NilValue : value; +} + +static inline +SEXP prop_set_storage(SEXP object, SEXP name_sym, SEXP value) { + SEXP storage_sym = prop_storage_sym(name_sym); + if (value == R_NilValue) + value = pseudo_null(); + if (prop_has_storage_slot(object, storage_sym)) + R_do_slot_assign(object, storage_sym, value); + else + Rf_setAttrib(object, storage_sym, value); + return object; +} + static inline Rboolean pairlist_contains(SEXP list, SEXP elem) { @@ -488,7 +537,7 @@ SEXP prop_(SEXP object, SEXP name) { } // try to resolve property from the object attributes - SEXP value = Rf_getAttrib(object, prop_storage_sym(name_sym)); + SEXP value = prop_get_storage(object, name_sym); // This is commented out because we currently have no way to distinguish between // a prop with a value of NULL, and a prop value that is unset/missing. @@ -573,7 +622,8 @@ SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value) { // don't use setter() if (should_validate_prop) prop_validate(property, value, object, name); - Rf_setAttrib(object, prop_storage_sym(name_sym), value); + object = PROTECT(prop_set_storage(object, name_sym, value)); + n_protected++; } if (should_validate_obj) diff --git a/tests/testthat/_snaps/S4.md b/tests/testthat/_snaps/S4.md index e082b338..0e0e8760 100644 --- a/tests/testthat/_snaps/S4.md +++ b/tests/testthat/_snaps/S4.md @@ -1,15 +1,72 @@ +# S4_contains rejects old-style S7 registrations + + Code + S4_contains(S4regContainsOldStyle) + Condition + Error in `S4_contains()`: + ! Class has not been registered as a reified S7 class; please call S4_register(S4regContainsOldStyle). + +# S4_contains rejects unrelated S4 classes with the same name + + Code + S4_contains(S4regContainsCollision) + Condition + Error in `S4_contains()`: + ! Class has not been registered with S4; please call S4_register(S4regContainsCollision). + +# S4_contains rejects stale S4 registrations + + Code + S4_contains(S4regStale) + Condition + Error in `S4_contains()`: + ! Class has not been registered with S4; please call S4_register(S4regStale). + +# S4 union matching preserves package-qualified class keys + + Code + S4_register(S4regUnionKeyHolder, env = pkg_env) + Condition + Error: + ! Class union has not been registered with S4; please call S4_register(new_union(S4regUnionKeyFoo, class_character)). + +# S4 subclasses reject internal S7/S4 slots during initialization + + Code + methods::new("S4regInternalSlotChild", x = 1, `_S7_class` = S4regInternalOther) + Condition + Error in `initialize()`: + ! Can't initialize internal S4 slot "_S7_class". + +--- + + Code + methods::new("S4regInternalSlotChild", x = 1, .S3Class = "bogus") + Condition + Error in `initialize()`: + ! Can't initialize internal S4 slot ".S3Class". + +# S4_register validates deferred NULL defaults + + Code + methods::new("S4regNullDefaultChild") + Condition + Error in `validate()`: + ! S4 object properties are invalid: + - @x must be or , not + # S4_register errors on unsupported inputs Code S4_register(1) Condition Error in `S4_register()`: - ! `class` must be an S7 class or an S3 class, not a . + ! `class` must be an S7 class, S3 class, or S7 union, not a . Code S4_register("foo") Condition Error in `S4_register()`: - ! `class` must be an S7 class or an S3 class, not a . + ! `class` must be an S7 class, S3 class, or S7 union, not a . # errors on non-S4 classes @@ -19,6 +76,192 @@ Error: ! Unsupported S4 object: must be a class generator or a class definition, not a . +# S4 subclasses of S7-over-S4 classes run S4 parent validity + + Code + prop(object, "x") <- numeric() + Condition + Error: + ! S4 object is invalid: + - x must have length 1 + +--- + + Code + props(object) <- list(x = numeric()) + Condition + Error in `validate()`: + ! S4 object is invalid: + - x must have length 1 + +--- + + Code + methods::initialize(object, x = numeric()) + Condition + Error in `validate()`: + ! S4 object is invalid: + - x must have length 1 + +# S7-over-S4 classes run S7 validators inherited through S4 + + Code + prop(object, "x") <- numeric() + Condition + Error: + ! object is invalid: + - x must have length 1 + +# S4 subclasses of S7 classes run concrete S4 validity + + Code + prop(object, "x") <- numeric() + Condition + Error: + ! S4 object is invalid: + - x must have length 1 + +--- + + Code + props(object) <- list(x = numeric()) + Condition + Error in `validate()`: + ! S4 object is invalid: + - x must have length 1 + +# S4 subclasses of S7 classes check concrete slot types + + Code + methods::new("S4regConcreteSlotChild", x = 1) + Condition + Error in `validate()`: + ! S4 object is invalid: + - invalid object for slot "x" in class "S4regConcreteSlotChild": got class "numeric", should be or extend class "integer" + +# S4 subclasses reject multiple S4_contains() parents + + Code + methods::new("S4regMultipleS7ContainsBoth", x = 1, y = 2) + Condition + Error in `validate()`: + ! S4 object is invalid: + - S4 directly contains multiple S7 classes via S4_contains(): , + +# S4 subclass validation preserves concrete class package + + Code + validate(object) + Condition + Error in `validate()`: + ! S4 object is invalid: + - x must have length 1 + +# S4 subclass validation preserves skipped superclass packages + + Code + validate(object) + Condition + Error in `validate()`: + ! S4 object is invalid: + - package B x must have length 1 + +# S4 initialization validates after S4-only slots are set + + Code + methods::new("S4regInitValidityChild", z = -1) + Condition + Error in `validate()`: + ! S4 object is invalid: + - z must be non-negative + +# S4 subclasses of S7 classes run inherited S4 validity + + Code + prop(object, "x") <- "b" + Condition + Error: + ! S4 object is invalid: + - y must be non-negative + +--- + + Code + props(object) <- list(x = "b") + Condition + Error in `validate()`: + ! S4 object is invalid: + - y must be non-negative + +--- + + Code + methods::initialize(object, x = "b") + Condition + Error in `validate()`: + ! S4 object is invalid: + - y must be non-negative + +# S4 parents reject slots that need renamed S7 storage + + Code + new_class("S4regRenamedSlotChild", parent = getClass("S4regRenamedSlotParent"), + package = NULL) + Condition + Error in `new_class()`: + ! Can't extend S4 class S4 because slot "names" would need renamed S7 storage. + These S4 slots can not be represented safely on direct S7 child objects. + +# S4 parents reject accessor overrides of inherited slots + + Code + new_class("S4regAccessorSlotGetterChild", parent = getClass( + "S4regAccessorSlotParent"), properties = list(x = new_property(class_numeric, + getter = function(self) 1)), package = NULL) + Condition + Error in `new_class()`: + ! Can't override inherited S4 slot S4@x with a custom getter. + +--- + + Code + new_class("S4regAccessorSlotSetterChild", parent = getClass( + "S4regAccessorSlotParent"), properties = list(x = new_property(class_numeric, + setter = function(self, value) self)), package = NULL) + Condition + Error in `new_class()`: + ! Can't override inherited S4 slot S4@x with a custom setter. + +# S7 subclasses reject accessor overrides of inherited S4 slots + + Code + new_class("S4regS7AccessorSlotGetterChild", parent = Parent, properties = list( + x = new_property(class_numeric, getter = function(self) 1)), package = NULL) + Condition + Error in `new_class()`: + ! Can't override inherited S4 slot S4@x with a custom getter. + +--- + + Code + new_class("S4regS7AccessorSlotSetterChild", parent = Parent, properties = list( + x = new_property(class_numeric, setter = function(self, value) self)), + package = NULL) + Condition + Error in `new_class()`: + ! Can't override inherited S4 slot S4@x with a custom setter. + +# S7 property narrowing rejects unrelated S4 name matches + + Code + new_class("S4regPropertyNameCollisionOverride", parent = Parent, properties = list( + x = getClass("S4regPropertyNameCollisionChild")), package = NULL) + Condition + Error in `new_class()`: + ! @x must narrow @x. + - @x is . + - @x is S4. + # S4_package_name errors if originating package can't be found Code diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 941c207a..b1e55521 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -107,23 +107,23 @@ Error in `new_class()`: ! `validator` must be function(self), not function(). -# S7 classes can't inherit from S4 or class unions +# S7 classes reject S4 parents with implicit data parts Code - new_class("test", parent = parentS4) + new_class("Child", parent = methods::getClass("matrix"), package = NULL) Condition Error in `new_class()`: - ! `parent` must be an S7 class, S3 class, or base type, not an S4 class. + ! Can't extend S4 class S4 because it has an implicit data part. + Only S4 classes with data parts stored in an explicit `.Data` slot are supported. + +# S7 classes reject duplicate property storage names + Code - new_class("test", parent = new_union("character")) + new_class("StorageNameChild", parent = getClass("StorageNameParent"), + properties = list(names = class_character), package = NULL) Condition - Error in `as_class()`: - ! Can't convert `..1` to a valid class. - Class specification must be one of the following, not a : - * An S7 class object - * An S3 class object (from `new_S3_class()`) - * An S4 class object - * A base class + Error in `new_class()`: + ! Properties "_names", "names" must not use the same storage name "_names". # inheritance doesn't let child properties widen or change the parent's type @@ -197,6 +197,22 @@ Error in `new_object()`: ! `_parent` must be an instance of , not . +# new_object() rejects S4 parent objects in custom constructors + + Code + Child() + Condition + Error in `new_object()`: + ! `_parent` must not be an S4 object when class has an S4 parent. + +# new_object() rejects non-S7 seeds for S4 parents without data parts + + Code + Child() + Condition + Error in `new_object()`: + ! `_parent` must be an when class has an S4 parent without a data part. + # new_object() errors if `_parent` is supplied but class has no parent Code @@ -314,4 +330,3 @@ Condition Error: ! No S7 class for base type . - diff --git a/tests/testthat/_snaps/convert.md b/tests/testthat/_snaps/convert.md index 20714db1..20d2bb39 100644 --- a/tests/testthat/_snaps/convert.md +++ b/tests/testthat/_snaps/convert.md @@ -6,6 +6,16 @@ Error in `as.double()`: ! cannot coerce type 'object' to vector of type 'double' +# fallback convert rejects unrelated S4 name matches for S7 targets + + Code + convert(from, to = ConvertS4NameCollisionTo) + Condition + Error in `convert()`: + ! Can't find method with dispatch classes: + - from: S4 + - to : + # convert() errors when upcasting to an abstract class (#680) Code diff --git a/tests/testthat/_snaps/inherits.md b/tests/testthat/_snaps/inherits.md index 354d4fd8..2f9c0dd9 100644 --- a/tests/testthat/_snaps/inherits.md +++ b/tests/testthat/_snaps/inherits.md @@ -1,3 +1,12 @@ +# S4 class checks reject spoofed S3 objects + + Code + holder(x = spoof) + Condition + Error in `holder()`: + ! object properties are invalid: + - @x must be S4, not S3 + # checks that input is a class Code diff --git a/tests/testthat/_snaps/method-register.md b/tests/testthat/_snaps/method-register.md index 3873f0ea..6f937767 100644 --- a/tests/testthat/_snaps/method-register.md +++ b/tests/testthat/_snaps/method-register.md @@ -24,6 +24,16 @@ * An S3 class object (from `new_S3_class()`) * An S4 class object * A base class + Code + method(foo, list()) <- (function(x) ...) + Condition + Error in `as_class()`: + ! Can't convert `signature` to a valid class. + Class specification must be one of the following, not a : + * An S7 class object + * An S3 class object (from `new_S3_class()`) + * An S4 class object + * A base class # method unregistration removes an S7 method via NULL assignment diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index 912c657d..5b49642e 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -1,4 +1,4 @@ -quick_install <- function(package, lib, quiet = TRUE) { +quick_install <- function(package, lib, quiet = TRUE, libs = FALSE) { opts <- c( "--data-compress=none", "--no-byte-compile", @@ -7,7 +7,7 @@ quick_install <- function(package, lib, quiet = TRUE) { "--no-docs", "--no-help", "--no-html", - "--no-libs", + if (!libs) "--no-libs", "--use-vanilla", NULL ) @@ -93,13 +93,13 @@ local_S4_class <- function( where = topenv(env) ) { out <- methods::setClass(name, ..., where = where) - defer(S4_remove_classes(name, env), env) + defer(S4_remove_classes(name, where), env) out } local_S4_union <- function(name, members, env = parent.frame()) { out <- methods::setClassUnion(name, members, where = topenv(env)) - defer(S4_remove_classes(name, env), env) + defer(S4_remove_classes(name, topenv(env)), env) out } diff --git a/tests/testthat/t5parent/DESCRIPTION b/tests/testthat/t5parent/DESCRIPTION new file mode 100644 index 00000000..7400e3d4 --- /dev/null +++ b/tests/testthat/t5parent/DESCRIPTION @@ -0,0 +1,9 @@ +Package: t5parent +Title: Test Provider Of A Foreign S4 Class +Version: 0.0.0.9000 +Authors@R: + person("Jim", "Hester", , "james.f.hester@gmail.com", role = c("aut", "cre")) +Description: Provides an S4 class used by installed-package S7 compatibility tests. +Imports: methods +License: MIT + file LICENSE +Encoding: UTF-8 diff --git a/tests/testthat/t5parent/NAMESPACE b/tests/testthat/t5parent/NAMESPACE new file mode 100644 index 00000000..39ab4867 --- /dev/null +++ b/tests/testthat/t5parent/NAMESPACE @@ -0,0 +1,4 @@ +# Generated by roxygen2: do not edit by hand + +export(identity_parent_class) +export(new_identity_parent) diff --git a/tests/testthat/t5parent/R/t5parent.R b/tests/testthat/t5parent/R/t5parent.R new file mode 100644 index 00000000..c832022b --- /dev/null +++ b/tests/testthat/t5parent/R/t5parent.R @@ -0,0 +1,12 @@ +T5IdentityParent <- methods::setClass( + "T5IdentityParent", + slots = list(x = "numeric") +) + +identity_parent_class <- function() { + methods::getClass("T5IdentityParent", where = topenv()) +} + +new_identity_parent <- function(x) { + methods::new(identity_parent_class(), x = x) +} diff --git a/tests/testthat/test-S4.R b/tests/testthat/test-S4.R index 094ddf73..4bdf607f 100644 --- a/tests/testthat/test-S4.R +++ b/tests/testthat/test-S4.R @@ -6,13 +6,324 @@ test_that("can work with classGenerators", { test_that("S4_register registers an S7 class so it can be used with S4 methods", { on.exit(S4_remove_classes("S4regS7")) S4regS7 := new_class(package = NULL) - S4_register(S4regS7) + S4regS7_S4 <- S4_register(S4regS7) + expect_equal(S4regS7_S4, "S4regS7") expect_contains(methods::extends("S4regS7"), c("S4regS7", "S7_object")) }) +test_that("S4_register registers S7 classes with base parents", { + defer(S4_remove_classes(c("S4regS7IntegerChild", "S4regS7Integer"))) + + S4regS7Integer := new_class(parent = class_integer, package = NULL) + + expect_equal(S4_register(S4regS7Integer), "S4regS7Integer") + expect_contains(methods::extends("S4regS7Integer"), "integer") + + object <- S4regS7Integer(.data = 1L) + expect_equal(class(object), c("S4regS7Integer", "integer", "S7_object")) + expect_true(methods::is(object, "integer")) + expect_true(methods::is(object, "S7_object")) + expect_true(methods::validObject(object)) + + methods::setClass( + "S4regS7IntegerChild", + contains = S4_contains(S4regS7Integer), + slots = list(y = "character") + ) + child <- methods::new("S4regS7IntegerChild", .Data = 2L, y = "child") + + expect_equal(S7_class(child), S4regS7Integer) + expect_equal(S7_inherits(child, S4regS7Integer), TRUE) + expect_equal(methods::is(child, "S7_object"), TRUE) + expect_equal(S7_data(child), 2L) + expect_equal(methods::slot(child, "y"), "child") + expect_equal(methods::validObject(child), TRUE) +}) + +test_that("S4_register constructs S4 subclasses with S3 data-part parents", { + defer(S4_remove_classes(c("S4regS7FactorChild", "S4regS7Factor"))) + + S4regS7Factor := new_class(parent = class_factor, package = NULL) + S4_register(S4regS7Factor) + methods::setClass( + "S4regS7FactorChild", + contains = S4_contains(S4regS7Factor), + slots = list(y = "character") + ) + child <- methods::new( + "S4regS7FactorChild", + .Data = 1L, + levels = "a", + y = "child" + ) + + expect_equal(S7_class(child), S4regS7Factor) + expect_equal(S7_inherits(child, S4regS7Factor), TRUE) + expect_equal(methods::is(child, "S7_object"), TRUE) + expect_equal(methods::slot(child, ".Data"), 1L) + expect_equal(methods::slot(child, "levels"), "a") + expect_equal(methods::slot(child, "y"), "child") +}) + +test_that("S4_register preserves S3 data attributes for S4 subclasses", { + defer(S4_remove_classes(c( + "S4regS7DataFrameChild", + "S4regS7DataFrame", + "S4regS7FactorAttrsChild", + "S4regS7FactorAttrs" + ))) + + S4regS7FactorAttrs := new_class(parent = class_factor, package = NULL) + S4_register(S4regS7FactorAttrs) + methods::setClass( + "S4regS7FactorAttrsChild", + contains = S4_contains(S4regS7FactorAttrs), + slots = list(y = "character") + ) + factor_child <- methods::new( + "S4regS7FactorAttrsChild", + .Data = 1L, + levels = "a", + y = "child" + ) + + expect_equal(S7_data(factor_child), factor("a")) + + S7_data(factor_child) <- factor("b") + + expect_equal(S7_data(factor_child), factor("b")) + expect_equal(methods::slot(factor_child, "y"), "child") + + S4regS7DataFrame := new_class(parent = class_data.frame, package = NULL) + S4_register(S4regS7DataFrame) + methods::setClass( + "S4regS7DataFrameChild", + contains = S4_contains(S4regS7DataFrame), + slots = list(y = "character") + ) + df_child <- methods::new( + "S4regS7DataFrameChild", + .Data = list(a = 1), + names = "a", + row.names = 1L, + y = "child" + ) + + expect_equal(S7_data(df_child), data.frame(a = 1)) + + S7_data(df_child) <- data.frame(b = 2) + + expect_equal(S7_data(df_child), data.frame(b = 2)) + expect_equal(methods::slot(df_child, "y"), "child") +}) + +test_that("S4_register registers S7 classes with custom S3 data parents", { + defer(S4_remove_classes("S4regS7S3Integer")) + + S4regS3Integer <- new_S3_class( + c("S4regS3Integer", "integer"), + constructor = function(.data = integer()) { + structure(.data, class = c("S4regS3Integer", "integer")) + } + ) + S4regS7S3Integer := new_class(parent = S4regS3Integer, package = NULL) + + expect_equal(S4_register(S4regS7S3Integer), "S4regS7S3Integer") + expect_contains(methods::slotNames("S4regS7S3Integer"), ".S3Class") +}) + +test_that("S4_register registers S7 property classes", { + defer(S4_remove_classes(c( + "S4regS7PropParent", + "S4regS7PropChild", + "S4regS7PropOther2", + "S4regS7PropFoo", + "S4regS7PropOther1" + ))) + + S4regS7PropOther1 := new_class(package = NULL) + S4regS7PropFoo := new_class( + properties = list(other = S4regS7PropOther1), + package = NULL + ) + + expect_false(methods::isClass("S4regS7PropOther1")) + expect_equal(S4_register(S4regS7PropFoo), "S4regS7PropFoo") + expect_true(methods::isClass("S4regS7PropOther1")) + expect_equal( + as.character(methods::getClass("S4regS7PropFoo")@slots$other), + "S4regS7PropOther1" + ) + expect_true(methods::validObject(S4regS7PropFoo( + other = S4regS7PropOther1() + ))) + + setClass("S4regS7PropParent", slots = list(x = "numeric")) + S4regS7PropOther2 := new_class(package = NULL) + S4regS7PropChild := new_class( + parent = getClass("S4regS7PropParent"), + properties = list(other = S4regS7PropOther2), + package = NULL + ) + object <- S4regS7PropChild( + x = 1, + other = S4regS7PropOther2() + ) + + expect_true(methods::isClass("S4regS7PropOther2")) + expect_true(methods::validObject(object)) +}) + +test_that("S4_register refreshes stale S7 property classes", { + defer(S4_remove_classes(c( + "S4regS7PropStaleHolder", + "S4regS7PropStale" + ))) + + S4regS7PropStale := new_class(package = NULL) + S4_register(S4regS7PropStale) + + S4regS7PropStale := new_class( + properties = list(x = new_property(class_numeric, default = 1)), + package = NULL + ) + S4regS7PropStaleHolder := new_class( + properties = list(prop = S4regS7PropStale), + package = NULL + ) + + expect_no_error(S4_register(S4regS7PropStaleHolder)) + expect_identical( + methods::validObject(S4regS7PropStaleHolder( + prop = S4regS7PropStale() + )), + TRUE + ) +}) + +test_that("S4 parent slots declared as registered S7 classes use S7 classes", { + defer(S4_remove_classes(c( + "S4regSlotS7Child", + "S4regSlotS7Holder", + "S4regSlotS7Foo" + ))) + + S4regSlotS7Foo := new_class(package = NULL) + S4_register(S4regSlotS7Foo) + methods::setClass( + Class = "S4regSlotS7Holder", + slots = list(foo = "S4regSlotS7Foo") + ) + S4regSlotS7Child := new_class( + parent = methods::getClass("S4regSlotS7Holder"), + package = NULL + ) + + object <- S4regSlotS7Child(foo = S4regSlotS7Foo()) + + expect_equal(S4regSlotS7Child@properties$foo$class, S4regSlotS7Foo) + expect_equal(S7_inherits(prop(object, "foo"), S4regSlotS7Foo), TRUE) + expect_equal(methods::validObject(object), TRUE) +}) + +test_that("S4_contains requires prior S4 registration", { + on.exit(S4_remove_classes("S4regContainsUnregistered")) + S4regContainsUnregistered := new_class(package = NULL) + + expect_error( + S4_contains(S4regContainsUnregistered), + "has not been registered" + ) + expect_false(methods::isClass("S4regContainsUnregistered")) + + S4_register(S4regContainsUnregistered) + expect_equal( + S4_contains(S4regContainsUnregistered), + "S4regContainsUnregistered" + ) +}) + +test_that("S4_contains rejects old-style S7 registrations", { + defer(S4_remove_classes("S4regContainsOldStyle")) + + S4regContainsOldStyle := new_class( + properties = list(x = class_numeric), + package = NULL + ) + methods::setOldClass(c("S4regContainsOldStyle", "S7_object")) + + expect_snapshot(error = TRUE, { + S4_contains(S4regContainsOldStyle) + }) +}) + +test_that("S4_contains rejects unrelated S4 classes with the same name", { + defer(S4_remove_classes("S4regContainsCollision")) + setClass("S4regContainsCollision", slots = list(x = "numeric")) + S4regContainsCollision := new_class(package = NULL) + + expect_snapshot( + S4_contains(S4regContainsCollision), + error = TRUE + ) +}) + +test_that("S4_contains rejects stale S4 registrations", { + defer(S4_remove_classes(c( + "S4regStaleChild", + "S4regStale" + ))) + + S4regStale := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(S4regStale) + + S4regStale := new_class( + properties = list(y = class_character), + package = NULL + ) + expect_snapshot(error = TRUE, { + S4_contains(S4regStale) + }) + + S4_register(S4regStale) + methods::setClass( + Class = "S4regStaleChild", + contains = S4_contains(S4regStale) + ) + object <- methods::new("S4regStaleChild", y = "new") + + expect_equal(prop(object, "y"), "new") + expect_equal( + intersect("x", methods::slotNames("S4regStaleChild")), + character() + ) +}) + +test_that("S4_register registers S4 old classes as virtual S7_object descendants", { + on.exit(S4_remove_classes(c("S4regParent", "S4regS7New"))) + setClass("S4regParent", slots = list(x = "numeric")) + S4regS7New <- new_class( + "S4regS7New", + parent = getClass("S4regParent"), + properties = list(x = class_numeric), + package = NULL + ) + + expect_error( + methods::new("S4regS7New"), + "trying to generate an object from a virtual class" + ) + expect_true(methods::extends("S4regS7New", "S7_object")) + expect_true("_S7_class" %in% methods::slotNames("S4regS7New")) +}) + test_that("S4_register registers an S3 class so it can be used with S4 methods", { on.exit(S4_remove_classes(c("S4regS3a", "S4regS3b"))) - S4_register(new_S3_class(c("S4regS3a", "S4regS3b"))) + S4regS3_S4 <- S4_register(new_S3_class(c("S4regS3a", "S4regS3b"))) + expect_equal(S4regS3_S4, "S4regS3a") # Must not extend S7_object — that was a silent bug pre-fix expect_equal( methods::extends("S4regS3a"), @@ -20,46 +331,2948 @@ test_that("S4_register registers an S3 class so it can be used with S4 methods", ) }) -test_that("S4_register errors on unsupported inputs", { +test_that("S4_register registers an S7 union so it can be used with S4 methods", { + on.exit({ + if (methods::isGeneric("S4regUnionGeneric")) { + methods::removeGeneric("S4regUnionGeneric") + } + S4_remove_classes(c( + "S4regUnionFoo", + "S4regUnionFoo_OR_character" + )) + }) + + S4regUnionFoo <- new_class("S4regUnionFoo", package = NULL) + S4_register(S4regUnionFoo) + S4regUnion <- S4regUnionFoo | class_character + S4regUnion_S4 <- S4_register(S4regUnion) + expect_equal(S4regUnion_S4, "S4regUnionFoo_OR_character") + + methods::setGeneric( + "S4regUnionGeneric", + function(x) standardGeneric("S4regUnionGeneric") + ) + method(S4regUnionGeneric, S4regUnion) <- function(x) "union" + + expect_equal(S4regUnionGeneric(S4regUnionFoo()), "union") + expect_equal(S4regUnionGeneric("x"), "union") +}) + +test_that("S4_register registers unregistered S7 and S3 union members", { + defer(S4_remove_classes(c( + "S4regUnionAutoS7", + "S4regUnionAutoS7_OR_character", + "S4regUnionAutoS3", + "S4regUnionAutoS3_OR_character" + ))) + + S4regUnionAutoS7 := new_class( + package = NULL + ) + S4regUnionAutoS3 <- new_S3_class(class = "S4regUnionAutoS3") + + expect_false(methods::isClass("S4regUnionAutoS7")) + expect_false(methods::isClass("S4regUnionAutoS3")) + + expect_equal( + S4_register(S4regUnionAutoS7 | class_character), + "S4regUnionAutoS7_OR_character" + ) + expect_equal( + S4_register(S4regUnionAutoS3 | class_character), + "S4regUnionAutoS3_OR_character" + ) + expect_true(methods::isClass("S4regUnionAutoS7")) + expect_true(methods::isClass("S4regUnionAutoS3")) +}) + +test_that("S4_register preserves package-qualified S4 classes", { + pkg_env <- local_package("s4regpkgclasses") + defer({ + if (methods::isGeneric("S4regPackageClassGeneric")) { + methods::removeGeneric("S4regPackageClassGeneric") + } + suppressMessages({ + S4_remove_classes(c( + "S4regPackageClassHolder", + "S4/s4regpkgclasses::S4regPackageClassFoo", + "S4regPackageClassFoo_OR_character", + "S4regPackageClassFoo" + )) + S4_remove_classes("S4regPackageClassFoo", pkg_env) + }) + }) + + setClass("S4regPackageClassFoo", slots = list(x = "character")) + pkg_foo <- methods::setClass( + "S4regPackageClassFoo", + slots = list(x = "numeric"), + where = pkg_env + ) + S4regPackageClassHolder := new_class( + properties = list(x = pkg_foo), + package = NULL + ) + + S4_register(S4regPackageClassHolder) + expect_identical( + methods::getClass("S4regPackageClassHolder")@slots$x, + pkg_foo@className + ) + + union_name <- S4_register(pkg_foo | class_character) + pkg_object <- methods::new(pkg_foo@className, x = 1) + global_object <- methods::new( + methods::getClass("S4regPackageClassFoo"), + x = "wrong" + ) + expect_equal(methods::is(pkg_object, union_name), TRUE) + expect_equal(methods::is(global_object, union_name), FALSE) + + methods::setGeneric( + "S4regPackageClassGeneric", + function(x) standardGeneric("S4regPackageClassGeneric") + ) + method(S4regPackageClassGeneric, pkg_foo) <- function(x) "package" + + expect_equal(S4regPackageClassGeneric(pkg_object), "package") +}) + +test_that("S4_register allows S4 subclasses of package union members", { + parent_env <- local_package("s4regunionparentpkg") + child_env <- local_package("s4regunionchildpkg") + defer({ + suppressMessages({ + S4_remove_classes(c( + "s4regunionparentpkg::S4regUnionParent_OR_character", + "S4/s4regunionparentpkg::S4regUnionParent" + )) + S4_remove_classes("S4regUnionParent", parent_env) + S4_remove_classes("S4regUnionChild", child_env) + }) + }) + + parent <- methods::setClass( + "S4regUnionParent", + slots = list(x = "numeric"), + where = parent_env + ) + parent_def <- methods::getClass(parent@className, where = parent_env) + union_name <- S4_register(parent_def | class_character) + child <- methods::setClass( + "S4regUnionChild", + contains = parent_def@className, + where = child_env + ) + + parent_object <- parent(x = 1) + child_object <- child(x = 2) + + expect_equal(methods::is(parent_object, union_name), TRUE) + expect_equal(methods::is(child_object, union_name), TRUE) +}) + +test_that("S4 compatibility works from an installed S7 namespace", { + skip_if(getRversion() < "4.1" && Sys.info()[["sysname"]] == "Windows") + skip_if(quick_test()) + + tmp_lib <- local_libpath() + quick_install(normalizePath(test_path("../..")), tmp_lib, libs = TRUE) + quick_install(test_path("t5parent"), tmp_lib) + + expect_no_error(callr::r( + function(lib) { + .libPaths(c(lib, .libPaths())) + library(S7) + + methods::setClass("T5ValidityParent", slots = list(x = "numeric")) + methods::setValidity("T5ValidityParent", function(object) { + if (identical(as.character(class(object)), "T5ValidityParent")) { + TRUE + } else { + "parent validity must see parent class" + } + }) + T5ValidityChild <- S7::new_class( + name = "T5ValidityChild", + parent = methods::getClass("T5ValidityParent"), + package = NULL + ) + stopifnot(methods::validObject(T5ValidityChild(x = 1))) + + union <- S7::S4_register( + t5parent::identity_parent_class() | S7::class_character + ) + stopifnot(methods::is(t5parent::new_identity_parent(x = 1), union)) + + NULL + }, + args = list(lib = tmp_lib) + )) +}) + +test_that("S4_register keeps global S4 union members distinct", { + pkg_env <- local_package("s4regglobalunionpkg") + defer({ + suppressMessages({ + S4_remove_classes(c( + "S4regGlobalUnionFoo_OR_character", + "S4/S4regGlobalUnionFoo", + "S4regGlobalUnionFoo" + )) + S4_remove_classes("S4regGlobalUnionFoo", pkg_env) + }) + }) + + global_foo <- methods::setClass( + "S4regGlobalUnionFoo", + slots = list(x = "character") + ) + pkg_foo <- methods::setClass( + "S4regGlobalUnionFoo", + slots = list(x = "numeric"), + where = pkg_env + ) + global_def <- methods::getClass(global_foo@className) + + union_name <- S4_register(global_def | class_character) + global_object <- global_foo(x = "x") + pkg_object <- pkg_foo(x = 1) + + expect_equal(methods::is(global_object, union_name), TRUE) + expect_equal(methods::is(pkg_object, union_name), FALSE) +}) + +test_that("S4_register gives package S4 unions distinct names", { + pkg_a_env <- local_package("s4regunionnamea") + pkg_b_env <- local_package("s4regunionnameb") + defer({ + suppressMessages({ + S4_remove_classes(c( + "s4regunionnamea::S4regUnionNameFoo_OR_character", + "s4regunionnameb::S4regUnionNameFoo_OR_character", + "S4/s4regunionnamea::S4regUnionNameFoo", + "S4/s4regunionnameb::S4regUnionNameFoo", + "S4regUnionNameFoo_OR_character" + )) + S4_remove_classes("S4regUnionNameFoo", pkg_a_env) + S4_remove_classes("S4regUnionNameFoo", pkg_b_env) + }) + }) + + pkg_a_foo <- methods::setClass( + "S4regUnionNameFoo", + slots = list(x = "numeric"), + where = pkg_a_env + ) + pkg_b_foo <- methods::setClass( + "S4regUnionNameFoo", + slots = list(x = "character"), + where = pkg_b_env + ) + + union_a <- S4_register(pkg_a_foo | class_character) + union_b <- S4_register(pkg_b_foo | class_character) + pkg_a_object <- pkg_a_foo(x = 1) + pkg_b_object <- pkg_b_foo(x = "x") + + expect_equal( + union_a, + "s4regunionnamea::S4regUnionNameFoo_OR_character" + ) + expect_equal( + union_b, + "s4regunionnameb::S4regUnionNameFoo_OR_character" + ) + expect_equal(methods::is(pkg_a_object, union_a), TRUE) + expect_equal(methods::is(pkg_b_object, union_a), FALSE) + expect_equal(methods::is(pkg_b_object, union_b), TRUE) + expect_equal(methods::is(pkg_a_object, union_b), FALSE) +}) + +test_that("S4_register keeps package-local S4 union members distinct", { + pkg_env <- local_package("s4regunionlocalpkg") + defer({ + suppressMessages({ + S4_remove_classes("S4regUnionLocalFoo") + S4_remove_classes( + c( + "s4regunionlocalpkg::S4regUnionLocalFoo_OR_character", + "S4/s4regunionlocalpkg::S4regUnionLocalFoo", + "S4regUnionLocalFoo_OR_character" + ), + pkg_env + ) + S4_remove_classes("S4regUnionLocalFoo", pkg_env) + }) + }) + + global_foo <- methods::setClass( + "S4regUnionLocalFoo", + slots = list(x = "character") + ) + pkg_foo <- methods::setClass( + "S4regUnionLocalFoo", + slots = list(x = "numeric"), + where = pkg_env + ) + + union_name <- S4_register(pkg_foo | class_character, env = pkg_env) + pkg_object <- pkg_foo(x = 1) + global_object <- global_foo(x = "x") + + expect_equal( + union_name, + "s4regunionlocalpkg::S4regUnionLocalFoo_OR_character" + ) + expect_equal(methods::is(pkg_object, union_name), TRUE) + expect_equal(methods::is(global_object, union_name), FALSE) +}) + +test_that("S4_register dispatches union methods for same-package S4 subclasses", { + pkg_env <- local_package("s4regunionlocalsubpkg") + defer({ + if (methods::isGeneric("S4regUnionLocalSubGeneric", where = pkg_env)) { + methods::removeGeneric("S4regUnionLocalSubGeneric", where = pkg_env) + } + suppressMessages({ + S4_remove_classes("S4regUnionLocalSubFoo") + S4_remove_classes( + c( + "s4regunionlocalsubpkg::S4regUnionLocalSubFoo_OR_character", + "S4/s4regunionlocalsubpkg::S4regUnionLocalSubFoo", + "S4regUnionLocalSubChild", + "S4regUnionLocalSubFoo_OR_character" + ), + pkg_env + ) + S4_remove_classes("S4regUnionLocalSubFoo", pkg_env) + }) + }) + + global_foo <- methods::setClass( + "S4regUnionLocalSubFoo", + slots = list(x = "character") + ) + pkg_foo <- methods::setClass( + "S4regUnionLocalSubFoo", + slots = list(x = "numeric"), + where = pkg_env + ) + + union_name <- S4_register(pkg_foo | class_character, env = pkg_env) + child <- methods::setClass( + "S4regUnionLocalSubChild", + contains = "S4regUnionLocalSubFoo", + where = pkg_env + ) + methods::setGeneric( + "S4regUnionLocalSubGeneric", + function(x) standardGeneric("S4regUnionLocalSubGeneric"), + where = pkg_env + ) + methods::setMethod( + "S4regUnionLocalSubGeneric", + union_name, + function(x) "union", + where = pkg_env + ) + + generic <- get("S4regUnionLocalSubGeneric", envir = pkg_env) + pkg_object <- child(x = 1) + global_object <- global_foo(x = "x") + + expect_equal(generic(pkg_object), "union") + expect_equal(methods::is(global_object, union_name), FALSE) +}) + +test_that("S4_register dispatches union methods for existing S4 subclasses", { + pkg_env <- local_package("s4regunionexistingsubpkg") + defer({ + if (methods::isGeneric("S4regUnionExistingSubGeneric", where = pkg_env)) { + methods::removeGeneric("S4regUnionExistingSubGeneric", where = pkg_env) + } + suppressMessages({ + S4_remove_classes( + c( + "s4regunionexistingsubpkg::S4regUnionExistingSubFoo_OR_character", + "S4/s4regunionexistingsubpkg::S4regUnionExistingSubFoo", + "S4regUnionExistingSubChild", + "S4regUnionExistingSubFoo_OR_character" + ), + pkg_env + ) + S4_remove_classes("S4regUnionExistingSubFoo", pkg_env) + }) + }) + + pkg_foo <- methods::setClass( + "S4regUnionExistingSubFoo", + slots = list(x = "numeric"), + where = pkg_env + ) + child <- methods::setClass( + "S4regUnionExistingSubChild", + contains = "S4regUnionExistingSubFoo", + where = pkg_env + ) + + union_name <- S4_register(pkg_foo | class_character, env = pkg_env) + methods::setGeneric( + "S4regUnionExistingSubGeneric", + function(x) standardGeneric("S4regUnionExistingSubGeneric"), + where = pkg_env + ) + methods::setMethod( + "S4regUnionExistingSubGeneric", + union_name, + function(x) "union", + where = pkg_env + ) + + generic <- get("S4regUnionExistingSubGeneric", envir = pkg_env) + child_object <- child(x = 1) + + expect_equal(methods::is(child_object, union_name), TRUE) + expect_equal(generic(child_object), "union") +}) + +test_that("S7 dispatch preserves package-qualified S4 parents", { + pkg_env <- local_package("s4regdispatchpkg") + defer({ + S4_remove_classes(c( + "S4regDispatchChild", + "S4regDispatchParent" + )) + S4_remove_classes("S4regDispatchParent", pkg_env) + }) + + methods::setClass("S4regDispatchParent", slots = list(x = "character")) + pkg_parent <- methods::setClass( + "S4regDispatchParent", + slots = list(x = "numeric"), + where = pkg_env + ) + S4regDispatchChild := new_class( + parent = pkg_parent, + properties = list(y = class_character), + package = NULL + ) + S4regDispatchGeneric := new_generic("x") + method(S4regDispatchGeneric, methods::getClass("S4regDispatchParent")) <- + function(x) "global" + method(S4regDispatchGeneric, pkg_parent) <- function(x) "package" + + object <- S4regDispatchChild(x = 1, y = "child") + + expect_contains( + class(object), + "S4/s4regdispatchpkg::S4regDispatchParent" + ) + expect_equal(S4regDispatchGeneric(object), "package") +}) + +test_that("S4 union matching preserves package-qualified class keys", { + pkg_env <- local_package("s4regunionkeypkg") + defer({ + S4_remove_classes( + c( + "S4regUnionKeyHolder", + "S4regUnionKeyFoo_OR_character" + ), + pkg_env + ) + S4_remove_classes("S4regUnionKeyFoo") + S4_remove_classes("S4regUnionKeyFoo", pkg_env) + }) + + methods::setClass( + "S4regUnionKeyFoo", + slots = list(x = "character") + ) + pkg_foo <- methods::setClass( + "S4regUnionKeyFoo", + slots = list(x = "numeric"), + where = pkg_env + ) + global_foo <- methods::getClass("S4regUnionKeyFoo") + suppressWarnings(methods::setClassUnion( + "S4regUnionKeyFoo_OR_character", + list(global_foo@className, "character"), + where = pkg_env + )) + S4regUnionKeyHolder := new_class( + properties = list(x = pkg_foo | class_character), + package = NULL + ) + + expect_snapshot(error = TRUE, { + S4_register(S4regUnionKeyHolder, env = pkg_env) + }) +}) + +test_that("S4_register can reify S7 properties as slots for S4 subclasses", { + on.exit({ + if (methods::isGeneric("S4regContainsGeneric")) { + methods::removeGeneric("S4regContainsGeneric") + } + S4_remove_classes(c( + "S4regContainsS4Child", + "S7::S4regContains", + "S7::S4regContainsChild" + )) + }) + + S4regContains <- new_class( + "S4regContains", + properties = list(x = class_numeric), + package = "S7" + ) + S4regContainsChild <- new_class( + "S4regContainsChild", + parent = S4regContains, + properties = list(y = class_character), + validator = function(self) { + if (identical(self@y, "bad")) "bad y" + }, + package = "S7" + ) + + S4regContainsChild_old <- S4_register(S4regContainsChild) + S4regContainsChild_S4 <- S4_contains(S4regContainsChild) + expect_equal(S4regContainsChild_S4, "S7::S4regContainsChild") + expect_equal( + methods::slotNames(S4regContainsChild_S4), + c("y", "x", "_S7_class", ".S3Class") + ) + expect_contains( + methods::extends(S4regContainsChild_S4), + S4regContainsChild_old + ) + + methods::setClass( + "S4regContainsS4Child", + contains = S4regContainsChild_S4, + slots = list(z = "logical") + ) + object <- methods::new( + "S4regContainsS4Child", + x = 1, + y = "a", + z = TRUE + ) + + expect_equal(methods::slot(object, "x"), 1) + expect_equal(methods::slot(object, "y"), "a") + expect_equal(methods::slot(object, "z"), TRUE) + expect_equal(methods::slot(object, "_S7_class"), S4regContainsChild) + expect_equal(prop_names(object), c("x", "y")) + expect_equal(prop(object, "x"), 1) + expect_equal(prop(object, "y"), "a") + expect_true(methods::validObject(object)) + expect_equal(S7_class(object), S4regContainsChild) + expect_match(obj_desc(object), "^S4<") + + expect_equal( + S4_to_S7_class(getClass("S4regContainsS4Child")), + getClass("S4regContainsS4Child") + ) + expect_contains( + obj_dispatch(object), + c( + S4_class_name(getClass("S4regContainsS4Child")), + S4regContainsChild_old + ) + ) + + S4regContainsDispatch <- new_generic("S4regContainsDispatch", "x") + method(S4regContainsDispatch, S4regContainsChild) <- function(x) { + "S7" + } + method( + S4regContainsDispatch, + getClass("S4regContainsS4Child") + ) <- function(x) { + "S4" + } + expect_equal(S4regContainsDispatch(object), "S4") + + invalid <- object + methods::slot(invalid, "y") <- "bad" + expect_error(methods::validObject(invalid), "bad y") + + methods::setGeneric( + "S4regContainsGeneric", + function(x) standardGeneric("S4regContainsGeneric") + ) + method(S4regContainsGeneric, S4regContainsChild) <- function(x) { + methods::slot(x, "x") + } + expect_equal(S4regContainsGeneric(object), 1) +}) + +test_that("S4 subclasses reject internal S7/S4 slots during initialization", { + defer(S4_remove_classes(c( + "S4regInternalSlotChild", + "S4regInternalSlots" + ))) + + S4regInternalSlots := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(S4regInternalSlots) + S4regInternalSlots_S4 <- S4_contains(S4regInternalSlots) + methods::setClass( + "S4regInternalSlotChild", + contains = S4regInternalSlots_S4 + ) + + S4regInternalOther := new_class(package = NULL) + + expect_snapshot(error = TRUE, { + methods::new( + "S4regInternalSlotChild", + x = 1, + `_S7_class` = S4regInternalOther + ) + }) + expect_snapshot(error = TRUE, { + methods::new( + "S4regInternalSlotChild", + x = 1, + .S3Class = "bogus" + ) + }) +}) + +test_that("S4_register constructs S4 subclasses of S7 classes that extend S4 classes", { + on.exit(S4_remove_classes(c( + "S4regNewParent", + "S4regNewMiddle", + "S4regNewChild", + "S4regNewGrandChild" + ))) + setClass( + "S4regNewParent", + slots = list(assays = "list", rowData = "character") + ) + methods::setValidity("S4regNewParent", function(object) { + if (!identical(methods::slot(object, "assays"), list())) { + "assays slot was stripped during parent coercion" + } else { + TRUE + } + }) + + S4regNewMiddle <- new_class( + "S4regNewMiddle", + parent = getClass("S4regNewParent"), + properties = list(metadata = class_character), + validator = function(self) { + if (identical(self@metadata, "bad")) "bad metadata" + }, + package = NULL + ) + S4regNewChild <- new_class( + "S4regNewChild", + parent = S4regNewMiddle, + properties = list(status = class_character), + validator = function(self) { + if (identical(self@status, "bad")) "bad status" + }, + package = NULL + ) + S4regNewChild_S4 <- S4_contains(S4regNewChild) + expect_equal( + methods::slotNames("S4regNewChild"), + c("status", "metadata", "_S7_class", "assays", "rowData", ".S3Class") + ) + expect_contains( + methods::slotNames(S4regNewChild_S4), + c("assays", "rowData", "metadata", "status", "_S7_class") + ) + setClass( + "S4regNewGrandChild", + contains = S4regNewChild_S4 + ) + + object <- methods::new("S4regNewGrandChild") + + expect_true(isS4(object)) + expect_true(methods::is(object, "S7_object")) + expect_true(methods::is(object, "S4regNewParent")) + expect_true(methods::is(object, S4regNewChild_S4)) + expect_true(S7_inherits(object, S4regNewChild)) + expect_equal(methods::slot(object, "_S7_class"), S4regNewChild) + expect_equal(methods::slot(object, "assays"), list()) + expect_equal(methods::slot(object, "rowData"), character()) + expect_equal(methods::slot(object, "metadata"), character()) + expect_equal(methods::slot(object, "status"), character()) + object_reified <- methods::as(object, S4regNewChild_S4) + object_old <- methods::as(object_reified, "S4regNewChild") + expect_equal(methods::slot(object_old, "metadata"), character()) + expect_equal(methods::slot(object_old, "status"), character()) + object_old <- methods::as(object, "S4regNewChild") + expect_equal(methods::slot(object_old, "metadata"), character()) + expect_equal(methods::slot(object_old, "status"), character()) + expect_equal( + prop_names(object), + c("assays", "rowData", "metadata", "status") + ) + expect_equal(prop(object, "assays"), list()) + expect_equal(prop(object, "rowData"), character()) + expect_equal(prop(object, "metadata"), character()) + expect_equal(prop(object, "status"), character()) + expect_true(methods::validObject(object)) + + object <- methods::new( + "S4regNewGrandChild", + metadata = "m", + status = "s" + ) + expect_equal(methods::slot(object, "metadata"), "m") + expect_equal(methods::slot(object, "status"), "s") + expect_true(methods::validObject(object)) + + invalid <- object + methods::slot(invalid, "metadata") <- "bad" + expect_error(methods::validObject(invalid), "bad metadata") + + invalid <- object + methods::slot(invalid, "status") <- "bad" + expect_error(methods::validObject(invalid), "bad status") +}) + +test_that("S4_validate_class validates only matching S7 classes for S4 upcasts", { + on.exit(S4_remove_classes(c( + "S4regShimRoot", + "S4regShimParent", + "S4regShimChild", + "S4regShimGrandChild", + "S7::S4regShimParent", + "S7::S4regShimChild" + ))) + + setClass("S4regShimRoot", slots = list(root = "numeric")) + S4regShimParent <- new_class( + "S4regShimParent", + parent = getClass("S4regShimRoot"), + properties = list(x = class_numeric), + package = "S7" + ) + S4regShimChild <- new_class( + "S4regShimChild", + parent = S4regShimParent, + properties = list(y = class_character), + package = "S7" + ) + + S4regShimParent_S4 <- S4_contains(S4regShimParent) + S4regShimChild_S4 <- S4_contains(S4regShimChild) + setClass("S4regShimParent", contains = S4regShimParent_S4) + setClass( + "S4regShimChild", + contains = c(S4regShimChild_S4, "S4regShimParent") + ) + setClass("S4regShimGrandChild", contains = "S4regShimChild") + + object <- methods::new("S4regShimGrandChild", root = 1, x = 2, y = "a") + parent_object <- methods::as(object, S4regShimParent_S4) + + expect_equal(methods::slot(parent_object, "y"), "a") + expect_equal(S7_class(parent_object), S4regShimChild) + expect_true(methods::validObject(object)) +}) + +test_that("S4_register registers abstract S7 classes as virtual S4 classes", { + on.exit({ + try(methods::removeMethod("dim", "S4regAbstractConcrete"), silent = TRUE) + S4_remove_classes(c( + "S4regAbstractParent", + "S4regAbstract", + "S4regAbstractConcrete", + "S4regAbstractShim" + )) + }) + + setClass("S4regAbstractParent", contains = "VIRTUAL") + methods::setValidity("S4regAbstractParent", function(object) { + if (!identical(dim(object), c(1L, 2L))) { + "dim() did not dispatch to the concrete S7 class" + } else { + TRUE + } + }) + + S4regAbstract <- new_class( + "S4regAbstract", + parent = getClass("S4regAbstractParent"), + abstract = TRUE, + package = NULL + ) + S4regAbstractConcrete <- new_class( + "S4regAbstractConcrete", + parent = S4regAbstract, + properties = list(x = class_integer), + package = NULL + ) + method(dim, S4regAbstractConcrete) <- function(x) c(x@x, 2L) + S4regAbstractConcrete_S4 <- S4_contains(S4regAbstractConcrete) + setClass("S4regAbstractShim", contains = S4regAbstractConcrete_S4) + + object <- methods::new("S4regAbstractShim", x = 1L) + abstract_prototype <- methods::getClass("S4regAbstract")@prototype + concrete_prototype <- methods::getClass("S4regAbstractConcrete")@prototype + + expect_true(methods::isVirtualClass("S4regAbstract")) + expect_true("_S7_class" %in% methods::slotNames("S4regAbstract")) + expect_equal(methods::slot(abstract_prototype, "_S7_class"), S4regAbstract) + expect_false(methods::extends("S4regAbstract", "oldClass")) + expect_false(methods::extends("S4regAbstract", "S7_object")) + expect_equal( + methods::slot(concrete_prototype, "_S7_class"), + S4regAbstractConcrete + ) + expect_false("S4regAbstract" %in% attr(concrete_prototype, ".S3Class")) + expect_equal(dim(object), c(1L, 2L)) + expect_true(methods::validObject(object)) +}) + +test_that("S4_register preserves S7 dispatch through abstract S7 parents", { + defer(S4_remove_classes(c( + "S4regAbstractPlainChild", + "S4regAbstractPlainConcrete", + "S4regAbstractPlain" + ))) + + S4regAbstractPlain := new_class( + abstract = TRUE, + package = NULL + ) + S4regAbstractPlainConcrete := new_class( + parent = S4regAbstractPlain, + package = NULL + ) + S4_register(S4regAbstractPlainConcrete) + S4regAbstractPlainConcrete_S4 <- S4_contains(S4regAbstractPlainConcrete) + setClass( + "S4regAbstractPlainChild", + contains = S4regAbstractPlainConcrete_S4 + ) + + object <- methods::new("S4regAbstractPlainChild") + S4regAbstractPlainGeneric <- new_generic("S4regAbstractPlainGeneric", "x") + method(S4regAbstractPlainGeneric, S4regAbstractPlain) <- function(x) { + "abstract" + } + + expect_equal(S4regAbstractPlainGeneric(object), "abstract") + expect_contains( + obj_dispatch(object), + c("S4regAbstractPlainConcrete", "S4regAbstractPlain") + ) +}) + +test_that("S4_register preserves S7 dispatch through S4-rooted abstract S7 parents", { + defer(S4_remove_classes(c( + "S4regAbstractRootChild", + "S4regAbstractRootConcrete", + "S4regAbstractRoot", + "S4regAbstractRootParent" + ))) + + setClass("S4regAbstractRootParent", contains = "VIRTUAL") + S4regAbstractRoot := new_class( + parent = getClass("S4regAbstractRootParent"), + abstract = TRUE, + package = NULL + ) + S4regAbstractRootConcrete := new_class( + parent = S4regAbstractRoot, + package = NULL + ) + S4_register(S4regAbstractRootConcrete) + S4regAbstractRootConcrete_S4 <- S4_contains(S4regAbstractRootConcrete) + setClass( + "S4regAbstractRootChild", + contains = S4regAbstractRootConcrete_S4 + ) + + object <- methods::new("S4regAbstractRootChild") + S4regAbstractRootGeneric <- new_generic("S4regAbstractRootGeneric", "x") + method(S4regAbstractRootGeneric, S4regAbstractRoot) <- function(x) { + "abstract" + } + + expect_equal( + S4regAbstractRootGeneric(S4regAbstractRootConcrete()), + "abstract" + ) + expect_equal(S4regAbstractRootGeneric(object), "abstract") + expect_contains( + obj_dispatch(object), + c("S4regAbstractRootConcrete", "S4regAbstractRoot") + ) +}) + +test_that("S4_contains rejects abstract S7 classes", { + defer(S4_remove_classes(c( + "S4regAbstractContainsParent", + "S4regAbstractContains" + ))) + + setClass("S4regAbstractContainsParent", contains = "VIRTUAL") + S4regAbstractContains <- new_class( + "S4regAbstractContains", + parent = getClass("S4regAbstractContainsParent"), + abstract = TRUE, + package = NULL + ) + + expect_error( + S4_contains(S4regAbstractContains), + "abstract" + ) +}) + +test_that("S4_register uses S7 property defaults for S4 objects", { + on.exit(S4_remove_classes(c( + "S4regPrototype", + "S4regPrototypeChild", + "NULL_OR_character" + ))) + + S4_register(NULL | class_character) + S4regPrototype <- new_class( + "S4regPrototype", + properties = list( + x = new_property(class_numeric, default = quote(1)), + y = new_property(class_character, default = quote("a")), + z = new_property(NULL | class_character, default = NULL) + ), + package = NULL + ) + S4_register(S4regPrototype) + S4regPrototype_S4 <- S4_contains(S4regPrototype) + methods::setClass("S4regPrototypeChild", contains = S4regPrototype_S4) + + object <- methods::new("S4regPrototypeChild") + + expect_equal(methods::slot(object, "x"), 1) + expect_equal(methods::slot(object, "y"), "a") + expect_equal(methods::slot(object, "z"), NULL) + expect_equal(prop(object, "x"), 1) + expect_equal(prop(object, "y"), "a") + expect_equal(prop(object, "z"), NULL) + expect_true(methods::validObject(object)) +}) + +test_that("S4_register evaluates expression defaults for each S4 object", { + defer(S4_remove_classes(c( + "S4regPrototypeExpr", + "S4regPrototypeExprChild" + ))) + + S4regPrototypeExpr <- new_class( + "S4regPrototypeExpr", + properties = list( + x = new_property( + class_environment, + default = quote(new.env(parent = emptyenv())) + ) + ), + package = NULL + ) + S4_register(S4regPrototypeExpr) + S4regPrototypeExpr_S4 <- S4_contains(S4regPrototypeExpr) + methods::setClass("S4regPrototypeExprChild", contains = S4regPrototypeExpr_S4) + + object1 <- methods::new("S4regPrototypeExprChild") + object2 <- methods::new("S4regPrototypeExprChild") + + prop(object1, "x")$value <- 1 + expect_null(prop(object2, "x")$value) +}) + +test_that("S4 subclass prototypes override deferred S7 defaults", { + defer(S4_remove_classes(c( + "S4regPrototypeDeferred", + "S4regPrototypeDeferredChild" + ))) + + S4regPrototypeDeferred := new_class( + properties = list( + x = new_property( + class = class_numeric, + default = quote({ + 1 + }) + ) + ), + package = NULL + ) + S4_register(S4regPrototypeDeferred) + methods::setClass( + Class = "S4regPrototypeDeferredChild", + contains = S4_contains(S4regPrototypeDeferred), + prototype = list(x = 5) + ) + + object <- methods::new("S4regPrototypeDeferredChild") + + expect_equal(methods::slot(object, "x"), 5) + expect_equal(prop(object, "x"), 5) +}) + +test_that("S4_register evaluates deferred defaults in the constructor environment", { + defer(S4_remove_classes(c( + "S4regDefaultEnv", + "S4regDefaultEnvChild" + ))) + + S4regDefaultEnv <- local({ + x <- 1 + S4regDefaultEnv := new_class( + properties = list(x = new_property(class_numeric, default = quote(x))), + package = NULL + ) + }) + S4_register(S4regDefaultEnv) + S4regDefaultEnv_S4 <- S4_contains(S4regDefaultEnv) + methods::setClass("S4regDefaultEnvChild", contains = S4regDefaultEnv_S4) + + object <- methods::new("S4regDefaultEnvChild") + + expect_equal(methods::slot(object, "x"), 1) + expect_equal(prop(object, "x"), 1) +}) + +test_that("S4_register validates deferred NULL defaults", { + defer(S4_remove_classes(c( + "S4regNullDefault", + "S4regNullDefaultChild" + ))) + + S4regNullDefault := new_class( + properties = list( + x = new_property( + class_numeric, + default = quote({ + NULL + }) + ) + ), + package = NULL + ) + S4_register(S4regNullDefault) + S4regNullDefault_S4 <- S4_contains(S4regNullDefault) + methods::setClass("S4regNullDefaultChild", contains = S4regNullDefault_S4) + + expect_snapshot(error = TRUE, { + methods::new("S4regNullDefaultChild") + }) +}) + +test_that("S4 parents preserve slot prototypes in S7 constructors", { + defer(S4_remove_classes(c( + "S4regSlotPrototypeParent", + "S4regSlotPrototypeChild" + ))) + + setClass( + "S4regSlotPrototypeParent", + slots = list(x = "numeric"), + prototype = list(x = 10) + ) + S4regSlotPrototypeChild <- new_class( + "S4regSlotPrototypeChild", + parent = getClass("S4regSlotPrototypeParent"), + package = NULL + ) + + object <- S4regSlotPrototypeChild() + + expect_equal(methods::slot(object, "x"), 10) + expect_equal(prop(object, "x"), 10) +}) + +test_that("S4 parent prototype defaults preserve package-qualified classes", { + pkg_env <- local_package("s4regpkgdefaults") + defer({ + suppressMessages({ + S4_remove_classes(c( + "S4regPackageDefaultParent", + "S4regPackageDefaultChild" + )) + S4_remove_classes("S4regPackageDefaultParent", pkg_env) + }) + }) + + setClass( + "S4regPackageDefaultParent", + slots = list(x = "character"), + contains = "VIRTUAL", + prototype = list(x = "wrong") + ) + pkg_parent <- methods::setClass( + "S4regPackageDefaultParent", + slots = list(x = "numeric"), + contains = "VIRTUAL", + prototype = list(x = 10), + where = pkg_env + ) + S4regPackageDefaultChild := new_class( + parent = pkg_parent, + package = NULL + ) + + child_def <- methods::getClass("S4regPackageDefaultChild") + expect_identical( + child_def@contains$S4regPackageDefaultParent@superClass, + pkg_parent@className + ) + + suppressMessages(object <- S4regPackageDefaultChild()) + expect_equal(prop(object, "x"), 10) + expect_equal(methods::slot(object, "x"), 10) +}) + +test_that("S4_register resolves S4 prototypes from object class package", { + pkg_env <- local_package("s4regprototypepkg") + defer({ + suppressMessages({ + S4_remove_classes("S4regPkgPrototypeChild") + S4_remove_classes( + c( + "S4regPkgPrototype", + "S4regPkgPrototypeChild" + ), + pkg_env + ) + }) + }) + + setClass( + "S4regPkgPrototypeChild", + slots = list(x = "numeric"), + prototype = list(x = 1) + ) + evalq( + { + S4regPkgPrototype <- new_class( + "S4regPkgPrototype", + properties = list( + x = new_property( + class_numeric, + default = quote({ + 10 + }) + ) + ), + package = NULL + ) + S4_register(S4regPkgPrototype) + S4regPkgPrototype_S4 <- S4_contains(S4regPkgPrototype) + methods::setClass( + "S4regPkgPrototypeChild", + contains = S4regPkgPrototype_S4 + ) + }, + pkg_env + ) + + child_def <- methods::getClass("S4regPkgPrototypeChild", where = pkg_env) + suppressWarnings(object <- methods::new(child_def@className)) + + expect_equal(prop(object, "x"), 10) + expect_equal(methods::slot(object, "x"), 10) +}) + +test_that("S7 constructors delegate to S4 parent initialize methods", { + defer(S4_remove_classes(c( + "S4regInitializeParent", + "S4regInitializeChild" + ))) + + setClass("S4regInitializeParent", slots = list(x = "numeric")) + methods::setMethod( + "initialize", + "S4regInitializeParent", + function(.Object, x = 1, ...) { + .Object <- callNextMethod(.Object, ...) + .Object@x <- x * 10 + .Object + } + ) + S4regInitializeChild <- new_class( + "S4regInitializeChild", + parent = getClass("S4regInitializeParent"), + properties = list(y = class_character), + package = NULL + ) + + object <- S4regInitializeChild(x = 2, y = "a") + + expect_equal(prop(object, "x"), 20) + expect_equal(methods::slot(object, "x"), 20) + expect_equal(prop(object, "y"), "a") + + object <- S4regInitializeChild(y = "b") + expect_equal(prop(object, "x"), 10) + expect_equal(prop(object, "y"), "b") +}) + +test_that("S7 constructors delegate to virtual S4 parent initialize methods", { + defer(S4_remove_classes(c( + "S4regVirtualInitializeParent", + "S4regVirtualInitializeChild" + ))) + + setClass( + "S4regVirtualInitializeParent", + slots = list(x = "numeric"), + contains = "VIRTUAL", + prototype = list(x = -1) + ) + methods::setMethod( + "initialize", + "S4regVirtualInitializeParent", + function(.Object, x = 1, ...) { + .Object <- callNextMethod(.Object, ...) + .Object@x <- x * 10 + .Object + } + ) + S4regVirtualInitializeChild := new_class( + parent = getClass("S4regVirtualInitializeParent"), + properties = list(y = class_character), + package = NULL + ) + + object <- S4regVirtualInitializeChild(x = 2, y = "a") + + expect_equal(prop(object, "x"), 20) + expect_equal(methods::slot(object, "x"), 20) + expect_equal(prop(object, "y"), "a") + + object <- S4regVirtualInitializeChild(y = "b") + expect_equal(prop(object, "x"), 10) + expect_equal(prop(object, "y"), "b") +}) + +test_that("S7 constructors validate virtual S4 parents after initialize", { + defer(S4_remove_classes(c( + "S4regVirtualRepairParent", + "S4regVirtualRepairChild" + ))) + + setClass( + "S4regVirtualRepairParent", + slots = list(x = "numeric"), + contains = "VIRTUAL", + prototype = list(x = numeric()) + ) + methods::setValidity("S4regVirtualRepairParent", function(object) { + if (length(methods::slot(object, "x")) != 1) { + "x must have length 1" + } else { + TRUE + } + }) + methods::setMethod( + "initialize", + "S4regVirtualRepairParent", + function(.Object, x = 1, ...) { + .Object <- callNextMethod(.Object, ...) + .Object@x <- x + .Object + } + ) + S4regVirtualRepairChild := new_class( + parent = getClass("S4regVirtualRepairParent"), + properties = list(y = class_character), + package = NULL + ) + + object <- S4regVirtualRepairChild(y = "a") + + expect_equal(prop(object, "x"), 1) + expect_equal(prop(object, "y"), "a") + expect_true(methods::validObject(object)) +}) + +test_that("S7 constructors support callNextMethod in virtual S4 parents", { + defer(S4_remove_classes(c( + "S4regVirtualNextParent", + "S4regVirtualNextChild" + ))) + + setClass( + "S4regVirtualNextParent", + slots = list(x = "numeric"), + contains = "VIRTUAL", + prototype = list(x = -1) + ) + methods::setMethod( + "initialize", + "S4regVirtualNextParent", + function(.Object, x = 1, ...) { + .Object <- callNextMethod() + .Object@x <- x * 10 + .Object + } + ) + S4regVirtualNextChild := new_class( + parent = getClass("S4regVirtualNextParent"), + properties = list(y = class_character), + package = NULL + ) + + object <- S4regVirtualNextChild(x = 2, y = "a") + + expect_equal(prop(object, "x"), 20) + expect_equal(methods::slot(object, "x"), 20) + expect_equal(prop(object, "y"), "a") +}) + +test_that("S4 prototypes use overridden inherited S7 property defaults", { + defer(S4_remove_classes(c( + "S4regOverrideParent", + "S4regOverrideChild", + "S4regOverrideShim" + ))) + + setClass( + "S4regOverrideParent", + slots = list(x = "numeric"), + prototype = list(x = 1) + ) + S4regOverrideChild <- new_class( + "S4regOverrideChild", + parent = getClass("S4regOverrideParent"), + properties = list(x = new_property(class_numeric, default = 2)), + package = NULL + ) + S4regOverrideChild_S4 <- S4_contains(S4regOverrideChild) + setClass("S4regOverrideShim", contains = S4regOverrideChild_S4) + + expect_equal(prop(S4regOverrideChild(), "x"), 2) + + object <- methods::new("S4regOverrideShim") + expect_equal(methods::slot(object, "x"), 2) + expect_equal(prop(object, "x"), 2) +}) + +test_that("S4 prototypes preserve overridden NULL S7 property defaults", { + defer(S4_remove_classes(c( + "S4regNullOverrideParent", + "S4regNullOverrideChild", + "S4regNullOverrideShim", + "S4regNullOverrideSlot" + ))) + + setClassUnion("S4regNullOverrideSlot", c("character", "NULL")) + setClass( + "S4regNullOverrideParent", + slots = list(x = "S4regNullOverrideSlot"), + prototype = list(x = "parent") + ) + S4regNullOverrideChild <- new_class( + "S4regNullOverrideChild", + parent = getClass("S4regNullOverrideParent"), + properties = list( + x = new_property(NULL | class_character, default = NULL) + ), + package = NULL + ) + S4regNullOverrideChild_S4 <- S4_contains(S4regNullOverrideChild) + setClass("S4regNullOverrideShim", contains = S4regNullOverrideChild_S4) + + expect_equal(prop(S4regNullOverrideChild(), "x"), NULL) + + object <- methods::new("S4regNullOverrideShim") + expect_equal(methods::slot(object, "x"), NULL) + expect_equal(prop(object, "x"), NULL) +}) + +test_that("S4_register treats S4 NULL slot sentinels as NULL-valued S7 properties", { + on.exit(S4_remove_classes(c( + "S4regNullable", + "S4regNullableChild", + "NULL_OR_character" + ))) + + S4_register(NULL | class_character) + S4regNullable <- new_class( + "S4regNullable", + properties = list( + x = new_property(NULL | class_character, default = NULL) + ), + package = NULL + ) + S4_register(S4regNullable) + S4regNullable_S4 <- S4_contains(S4regNullable) + methods::setClass("S4regNullableChild", contains = S4regNullable_S4) + + object <- methods::new("S4regNullableChild") + + expect_equal(methods::slot(object, "x"), NULL) + expect_equal(prop(object, "x"), NULL) + expect_true(methods::validObject(object)) + expect_no_error(methods::new("S4regNullableChild", x = NULL)) + + object_with_value <- methods::new("S4regNullableChild", x = "a") + prop(object_with_value, "x") <- NULL + expect_equal(methods::slot(object_with_value, "x"), NULL) + expect_equal(prop(object_with_value, "x"), NULL) + + plain <- S4regNullable(x = "a") + prop(plain, "x") <- NULL + expect_equal(prop(plain, "x"), NULL) + expect_equal(methods::slot(plain, "x"), NULL) + expect_identical(attr(plain, "x", exact = TRUE), as.name("\001NULL\001")) +}) + +test_that("S4_contains rejects properties with custom accessors", { + on.exit(S4_remove_classes(c( + "S4regContainsDynamicChild", + "S7::S4regContainsDynamic", + "S4regContainsSetterChild", + "S7::S4regContainsSetter" + ))) + + S4regContainsDynamic <- new_class( + "S4regContainsDynamic", + properties = list( + x = new_property(class_numeric, getter = function(self) 1) + ), + package = "S7" + ) + expect_no_error(S4_register(S4regContainsDynamic)) + expect_error( + S4_contains(S4regContainsDynamic), + "custom getter" + ) + methods::setClass( + "S4regContainsDynamicChild", + contains = "S7::S4regContainsDynamic" + ) + expect_error( + methods::new("S4regContainsDynamicChild"), + "custom getter" + ) + + S4regContainsSetter <- new_class( + "S4regContainsSetter", + properties = list( + x = new_property( + class_numeric, + setter = function(self, value) { + attr(self, "x") <- value + self + } + ) + ), + package = "S7" + ) + expect_no_error(S4_register(S4regContainsSetter)) + expect_error( + S4_contains(S4regContainsSetter), + "custom setter" + ) + methods::setClass( + "S4regContainsSetterChild", + contains = "S7::S4regContainsSetter" + ) + expect_error( + methods::new("S4regContainsSetterChild"), + "custom setter" + ) +}) + +test_that("S4_register excludes dynamic properties from S4 slots", { + defer(S4_remove_classes("S4regDynamicSlots")) + + S4regDynamicSlots <- new_class( + "S4regDynamicSlots", + properties = list( + x = new_property(class_numeric, getter = function(self) 1), + y = class_numeric + ), + package = NULL + ) + + S4_register(S4regDynamicSlots) + object <- S4regDynamicSlots(y = 2) + + expect_equal( + methods::slotNames("S4regDynamicSlots"), + c("y", "_S7_class", ".S3Class") + ) + expect_equal(prop(object, "x"), 1) + expect_true(methods::validObject(object)) +}) + +test_that("S4_register uses registered S7 unions as S4 slots", { + on.exit(S4_remove_classes(c( + "S7::S4regContainsUnion", + "integer_OR_numeric_OR_character" + ))) + + S4regContainsUnion <- new_class( + "S4regContainsUnion", + properties = list(x = class_numeric | class_character), + package = "S7" + ) + expect_error( + S4_register(S4regContainsUnion), + "not been registered" + ) + + S4_register(class_numeric | class_character) + S4_register(S4regContainsUnion) + S4regContainsUnion_S4 <- S4_contains(S4regContainsUnion) + expect_equal( + as.character(methods::getClass(S4regContainsUnion_S4)@slots$x), + "integer_OR_numeric_OR_character" + ) +}) + +test_that("S4_register uses matching S4 unions as S4 slots", { + env <- topenv(environment()) + on.exit(S4_remove_classes( + c( + "S4regContainsExistingUnion", + "S4regExistingUnion", + "S4regUnionMember2", + "S4regUnionMember1" + ), + env + )) + + setClass("S4regUnionMember1", where = env) + setClass("S4regUnionMember2", where = env) + setClassUnion( + "S4regExistingUnion", + c("S4regUnionMember1", "S4regUnionMember2"), + where = env + ) + + S4regContainsExistingUnion <- new_class( + "S4regContainsExistingUnion", + properties = list( + x = getClass("S4regUnionMember1", where = env) | + getClass("S4regUnionMember2", where = env) + ), + package = NULL + ) + + S4_register(S4regContainsExistingUnion, env) + S4regContainsExistingUnion_S4 <- S4_contains( + S4regContainsExistingUnion, + env + ) + expect_equal( + as.character( + methods::getClass( + S4regContainsExistingUnion_S4, + where = env + )@slots$x + ), + "S4regExistingUnion" + ) +}) + +test_that("S4_register errors on unsupported inputs", { + expect_snapshot(error = TRUE, { + S4_register(1) + S4_register("foo") + }) +}) + +test_that("converts S4 base classes to S7 base classes", { + expect_equal(S4_to_S7_class(getClass("NULL")), NULL) + expect_equal(S4_to_S7_class(getClass("ANY")), class_any) + expect_equal(S4_to_S7_class(getClass("character")), class_character) +}) + +test_that("S4 ANY slots can be narrowed by S7 children", { + defer(S4_remove_classes(c( + "S4regAnySlotChild", + "S4regAnySlotParent" + ))) + + setClass("S4regAnySlotParent", slots = list(x = "ANY")) + S4regAnySlotChild := new_class( + parent = getClass("S4regAnySlotParent"), + properties = list(x = class_numeric), + package = NULL + ) + + object <- S4regAnySlotChild(x = 1) + expect_equal(prop(object, "x"), 1) + expect_true(methods::validObject(object)) +}) + +test_that("converts S4 unions to S7 unions", { + Foo1 := local_S4_class(slots = "x") + Foo2 := local_S4_class(slots = "x") + + Union1 := local_S4_union(c("Foo1", "Foo2")) + expect_equal( + S4_to_S7_class(getClass("Union1")), + new_union(getClass("Foo1"), getClass("Foo2")) + ) + + Foo3 := local_S4_class(slots = "x") + Union2 := local_S4_union(c("Union1", "Foo3")) + expect_equal( + S4_to_S7_class(getClass("Union2")), + new_union(getClass("Foo1"), getClass("Foo2"), getClass("Foo3")) + ) +}) + +test_that("S4 slot properties convert S4 class unions to S7 unions", { + env <- topenv(environment()) + on.exit(S4_remove_classes( + c( + "S4regUnionSlotChild", + "S4regUnionSlotParent", + "S4regUnionSlot" + ), + env + )) + + setClassUnion("S4regUnionSlot", c("character", "NULL"), where = env) + setClass( + "S4regUnionSlotParent", + slots = list(u = "S4regUnionSlot"), + where = env + ) + + S4regUnionSlotChild <- new_class( + "S4regUnionSlotChild", + parent = getClass("S4regUnionSlotParent", where = env), + properties = list(y = class_character), + package = NULL + ) + + expect_equal( + S4regUnionSlotChild@properties$u$class, + new_union(NULL, class_character) + ) +}) + +test_that("converts S4 representation of S3 classes to S7 representation", { + expect_equal( + S4_to_S7_class(getClass("Date")), + class_Date, + ignore_function_env = TRUE + ) +}) + +test_that("S4 old-class representations dispatch as S3 class vectors", { + S4regOrderedGeneric := new_generic(dispatch_args = "x") + method(S4regOrderedGeneric, getClass("ordered")) <- function(x) "ordered" + + expect_equal(S4regOrderedGeneric(ordered("a")), "ordered") +}) + +test_that("S4 old-class slots accept normal S3 class vectors", { + defer(S4_remove_classes(c( + "S4regOldSlotChild", + "S4regOldSlotParent", + "S4regOldFoo", + "S4regOldBar" + ))) + + setOldClass(c("S4regOldFoo", "S4regOldBar")) + setClass("S4regOldSlotParent", slots = list(x = "S4regOldFoo")) + S4regOldSlotChild <- new_class( + "S4regOldSlotChild", + parent = getClass("S4regOldSlotParent"), + package = NULL + ) + x <- structure(list(), class = c("S4regOldFoo", "S4regOldBar")) + + object <- S4regOldSlotChild(x = x) + + expect_equal(prop(object, "x"), x) +}) + +test_that("S7 classes do not import internal slots from S4 parents", { + defer(S4_remove_classes(c( + "S4regImportInternalChild", + "S4regImportInternalParent", + "S4regImportInternalBase" + ))) + + S4regImportInternalBase := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(S4regImportInternalBase) + setClass( + "S4regImportInternalParent", + contains = S4_contains(S4regImportInternalBase), + slots = list(y = "character") + ) + S4regImportInternalChild := new_class( + parent = getClass("S4regImportInternalParent"), + properties = list(z = class_logical), + package = NULL + ) + + object <- S4regImportInternalChild( + x = 1, + y = "a", + z = TRUE + ) + + expect_equal(names(formals(S4regImportInternalChild)), c("y", "x", "z")) + expect_equal(prop_names(object), c("y", "x", "z")) + expect_true(methods::validObject(object)) +}) + +test_that("errors on non-S4 classes", { + expect_snapshot(S4_to_S7_class(1), error = TRUE) +}) + +test_that("S7 classes can extend S4 classes", { + on.exit(S4_remove_classes(c("Parent", "Child"))) + setClass("Parent", slots = list(x = "numeric")) + + Child <- new_class( + "Child", + parent = getClass("Parent"), + properties = list(y = class_character), + package = NULL + ) + child <- Child(x = 1, y = "a") + + expect_false(isS4(child)) + expect_true(S7_inherits(child, Child)) + expect_equal(prop_names(child), c("x", "y")) + expect_equal(prop(child, "x"), 1) + expect_equal(prop(child, "y"), "a") + + prop(child, "x") <- 2 + prop(child, "y") <- "b" + expect_equal(prop(child, "x"), 2) + expect_equal(prop(child, "y"), "b") + + expect_true(methods::is(child, "Parent")) + expect_true(methods::validObject(child)) + expect_equal(as.character(methods::getClass("Child")@className), "Child") + expect_equal( + methods::slotNames("Child"), + c("y", "_S7_class", "x", ".S3Class") + ) + expect_equal(methods::slot(child, "x"), 2) + expect_equal(methods::slot(child, "y"), "b") + + child <- methods::initialize(child, x = 3, y = "c") + expect_equal(prop(child, "x"), 3) + expect_equal(prop(child, "y"), "c") + expect_true(methods::validObject(child)) + + child <- methods::initialize(child, Child(x = 4, y = "d"), y = "e") + expect_equal(prop(child, "x"), 4) + expect_equal(prop(child, "y"), "e") + + parent <- methods::new("Parent", x = 5) + child <- methods::initialize(child, parent, y = "f") + expect_equal(prop(child, "x"), 5) + expect_equal(prop(child, "y"), "f") + + child <- methods::initialize(child, x = 6, x = 7) + expect_equal(prop(child, "x"), 7) + + expect_error(methods::initialize(child, x = "x"), "invalid") + expect_error(methods::initialize(child, z = 1), "Property not found") + + expect_error(Child(x = "x", y = "a")) +}) + +test_that("S7 classes run S4 parent validity", { + defer(S4_remove_classes(c( + "S4regValidityParent", + "S4regValidityChild" + ))) + + setClass("S4regValidityParent", slots = list(x = "numeric")) + methods::setValidity("S4regValidityParent", function(object) { + if (length(methods::slot(object, "x")) != 1) { + "x must have length 1" + } else { + TRUE + } + }) + S4regValidityChild <- new_class( + "S4regValidityChild", + parent = getClass("S4regValidityParent"), + package = NULL + ) + + expect_error( + S4regValidityChild(x = numeric()), + "x must have length 1" + ) + + object <- S4regValidityChild(x = 1) + methods::slot(object, "x") <- numeric() + expect_error(validate(object), "x must have length 1") +}) + +test_that("S4 subclasses of S7-over-S4 classes run S4 parent validity", { + defer(S4_remove_classes(c( + "S4regSubValidityParent", + "S4regSubValidityChild", + "S4regSubValidityShim" + ))) + + setClass("S4regSubValidityParent", slots = list(x = "numeric")) + methods::setValidity("S4regSubValidityParent", function(object) { + if (length(methods::slot(object, "x")) != 1) { + "x must have length 1" + } else { + TRUE + } + }) + S4regSubValidityChild := new_class( + parent = getClass("S4regSubValidityParent"), + properties = list(y = class_character), + package = NULL + ) + S4regSubValidityChild_S4 <- S4_contains(S4regSubValidityChild) + setClass("S4regSubValidityShim", contains = S4regSubValidityChild_S4) + + object <- methods::new("S4regSubValidityShim", x = 1, y = "a") + expect_snapshot(error = TRUE, { + prop(object, "x") <- numeric() + }) + + object <- methods::new("S4regSubValidityShim", x = 1, y = "a") + expect_snapshot(error = TRUE, { + props(object) <- list(x = numeric()) + }) + + object <- methods::new("S4regSubValidityShim", x = 1, y = "a") + expect_snapshot(error = TRUE, { + methods::initialize(object, x = numeric()) + }) +}) + +test_that("S4 subclass validation reports inherited S4 slot errors once", { + defer(S4_remove_classes(c( + "S4regSubSlotErrorParent", + "S4regSubSlotErrorChild", + "S4regSubSlotErrorShim" + ))) + + setClass("S4regSubSlotErrorParent", slots = list(x = "numeric")) + S4regSubSlotErrorChild := new_class( + parent = getClass("S4regSubSlotErrorParent"), + package = NULL + ) + S4regSubSlotErrorChild_S4 <- S4_contains(S4regSubSlotErrorChild) + setClass("S4regSubSlotErrorShim", contains = S4regSubSlotErrorChild_S4) + + object <- methods::new("S4regSubSlotErrorShim", x = 1) + attr(object, "x") <- "bad" + error <- tryCatch(validate(object, properties = FALSE), error = identity) + matches <- gregexpr( + "invalid object for slot", + conditionMessage(error), + fixed = TRUE + ) + + expect_s3_class(error, "S7_error_validation_failed") + expect_equal(lengths(regmatches(conditionMessage(error), matches)), 1L) +}) + +test_that("S7-over-S4 classes run S7 validators inherited through S4", { + defer(S4_remove_classes(c( + "S4regS7HopParent", + "S4regS7HopMid", + "S4regS7HopChild" + ))) + + S4regS7HopParent := new_class( + properties = list(x = class_numeric), + validator = function(self) { + if (length(prop(self, "x")) != 1) { + "x must have length 1" + } + }, + package = NULL + ) + S4_register(S4regS7HopParent) + methods::setClass( + Class = "S4regS7HopMid", + contains = S4_contains(S4regS7HopParent) + ) + S4regS7HopChild := new_class( + parent = methods::getClass("S4regS7HopMid"), + package = NULL + ) + + object <- S4regS7HopChild(x = 1) + expect_equal(S7_inherits(object, S4regS7HopParent), TRUE) + + expect_snapshot(error = TRUE, { + prop(object, "x") <- numeric() + }) +}) + +test_that("S4 subclasses of S7 classes run concrete S4 validity", { + defer(S4_remove_classes(c( + "S4regConcreteValidityParent", + "S4regConcreteValidityChild" + ))) + + S4regConcreteValidityParent := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(S4regConcreteValidityParent) + setClass( + "S4regConcreteValidityChild", + contains = S4_contains(S4regConcreteValidityParent) + ) + methods::setValidity("S4regConcreteValidityChild", function(object) { + if (length(prop(object, "x")) != 1) { + "x must have length 1" + } else { + TRUE + } + }) + + object <- methods::new("S4regConcreteValidityChild", x = 1) + expect_snapshot(error = TRUE, { + prop(object, "x") <- numeric() + }) + + object <- methods::new("S4regConcreteValidityChild", x = 1) + expect_snapshot(error = TRUE, { + props(object) <- list(x = numeric()) + }) +}) + +test_that("S4 subclasses of S7 classes check concrete slot types", { + defer(S4_remove_classes(c( + "S4regConcreteSlotParent", + "S4regConcreteSlotChild" + ))) + + S4regConcreteSlotParent := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(S4regConcreteSlotParent) + setClass( + "S4regConcreteSlotChild", + contains = S4_contains(S4regConcreteSlotParent), + slots = list(x = "integer") + ) + + expect_snapshot(error = TRUE, { + methods::new("S4regConcreteSlotChild", x = 1) + }) +}) + +test_that("S4 subclasses reject multiple S4_contains() parents", { + defer(S4_remove_classes(c( + "S4regMultipleS7ContainsFoo", + "S4regMultipleS7ContainsBar", + "S4regMultipleS7ContainsBoth" + ))) + + S4regMultipleS7ContainsFoo := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4regMultipleS7ContainsBar := new_class( + properties = list(y = class_numeric), + package = NULL + ) + S4_register(S4regMultipleS7ContainsFoo) + S4_register(S4regMultipleS7ContainsBar) + setClass( + "S4regMultipleS7ContainsBoth", + contains = c( + S4_contains(S4regMultipleS7ContainsFoo), + S4_contains(S4regMultipleS7ContainsBar) + ) + ) + + expect_snapshot(error = TRUE, { + methods::new("S4regMultipleS7ContainsBoth", x = 1, y = 2) + }) +}) + +test_that("S4 subclass validation preserves concrete class package", { + pkg_env <- local_package("s4regvalidpkg") + defer({ + suppressMessages({ + S4_remove_classes(c( + "S4regPackageValidityParent", + "S4regPackageValidityChild" + )) + S4_remove_classes("S4regPackageValidityChild", pkg_env) + }) + }) + + S4regPackageValidityParent := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(S4regPackageValidityParent) + setClass("S4regPackageValidityChild") + pkg_child <- methods::setClass( + "S4regPackageValidityChild", + contains = S4_contains(S4regPackageValidityParent), + where = pkg_env + ) + methods::setValidity( + pkg_child@className, + function(object) { + if (length(prop(object, "x")) != 1) { + "x must have length 1" + } else { + TRUE + } + }, + where = pkg_env + ) + + object <- methods::new(pkg_child@className, x = 1) + methods::slot(object, "x") <- numeric() + + expect_match( + methods::validObject(object, test = TRUE), + "x must have length 1" + ) + expect_snapshot(error = TRUE, { + validate(object) + }) +}) + +test_that("S4 subclass validation preserves skipped superclass packages", { + pkg_a_env <- local_package("s4regvalidskipa") + pkg_b_env <- local_package("s4regvalidskipb") + defer({ + suppressMessages({ + S4_remove_classes(c( + "S4regValiditySkip", + "S4regValiditySkipS7", + "S4regValiditySkipChild" + )) + S4_remove_classes( + c( + "S4regValiditySkip", + "S4regValiditySkipPkgAChild" + ), + pkg_a_env + ) + S4_remove_classes("S4regValiditySkip", pkg_b_env) + }) + }) + + pkg_a_base <- methods::setClass( + "S4regValiditySkip", + slots = list(x = "numeric"), + prototype = list(x = 1), + where = pkg_a_env + ) + pkg_a_parent <- methods::setClass( + "S4regValiditySkipPkgAChild", + contains = pkg_a_base@className, + where = pkg_a_env + ) + pkg_b_parent <- methods::setClass( + "S4regValiditySkip", + slots = list(x = "numeric"), + prototype = list(x = 1), + where = pkg_b_env + ) + methods::setValidity( + pkg_b_parent@className, + function(object) { + if (length(methods::slot(object, "x")) != 1) { + "package B x must have length 1" + } else { + TRUE + } + }, + where = pkg_b_env + ) + S4regValiditySkipS7 := new_class( + parent = pkg_a_parent, + package = NULL + ) + suppressWarnings(methods::setClass( + "S4regValiditySkipChild", + contains = list( + S4_contains(S4regValiditySkipS7), + pkg_b_parent@className + ), + slots = list(x = "numeric"), + prototype = list(x = 1) + )) + + object <- methods::new("S4regValiditySkipChild") + methods::slot(object, "x") <- numeric() + + expect_match( + methods::validObject(object, test = TRUE), + "package B x must have length 1" + ) + expect_snapshot(error = TRUE, { + validate(object) + }) +}) + +test_that("S7 validation preserves S4 parent package during coercion", { + pkg_env <- local_package("s4regvalidcoercepkg") + defer({ + suppressMessages({ + S4_remove_classes(c( + "S4regValidityCoerceParent", + "S4regValidityCoerceChild" + )) + S4_remove_classes("S4regValidityCoerceParent", pkg_env) + }) + }) + + setClass("S4regValidityCoerceParent", slots = list(x = "character")) + pkg_parent <- methods::setClass( + "S4regValidityCoerceParent", + contains = "numeric", + where = pkg_env + ) + methods::setValidity( + pkg_parent@className, + function(object) { + if (!identical(as.vector(object), 1)) { + "package parent saw wrong data" + } else { + TRUE + } + }, + where = pkg_env + ) + S4regValidityCoerceChild := new_class( + parent = pkg_parent, + package = NULL + ) + + expect_no_error(S4regValidityCoerceChild(.Data = 1)) +}) + +test_that("S4 initialization validates after S4-only slots are set", { + defer(S4_remove_classes(c( + "S4regInitValidityParent", + "S4regInitValidityChild" + ))) + + S4regInitValidityParent := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(S4regInitValidityParent) + setClass( + "S4regInitValidityChild", + contains = S4_contains(S4regInitValidityParent), + slots = list(z = "numeric"), + prototype = list(z = NA_real_) + ) + methods::setValidity("S4regInitValidityChild", function(object) { + z <- methods::slot(object, "z") + if (is.na(z) || z < 0) { + "z must be non-negative" + } else { + TRUE + } + }) + + object <- methods::new("S4regInitValidityChild", x = 1, z = 2) + expect_equal(prop(object, "x"), 1) + expect_equal(methods::slot(object, "z"), 2) + expect_true(methods::validObject(object)) + + object <- methods::new("S4regInitValidityChild", z = 2) + expect_equal(methods::slot(object, "z"), 2) + expect_true(methods::validObject(object)) + expect_snapshot(error = TRUE, { - S4_register(1) - S4_register("foo") + methods::new("S4regInitValidityChild", z = -1) }) }) -test_that("converts S4 base classes to S7 base classes", { - expect_equal(S4_to_S7_class(getClass("NULL")), NULL) - expect_equal(S4_to_S7_class(getClass("character")), class_character) +test_that("S4 subclasses of S7 classes run inherited S4 validity", { + defer(S4_remove_classes(c( + "S4regInheritedValidityParent", + "S4regInheritedValidityS7", + "S4regInheritedValidityChild" + ))) + + setClass("S4regInheritedValidityParent", slots = list(y = "numeric")) + methods::setValidity("S4regInheritedValidityParent", function(object) { + y <- methods::slot(object, "y") + if (length(y) > 0 && any(y < 0)) { + "y must be non-negative" + } else { + TRUE + } + }) + S4regInheritedValidityS7 := new_class( + properties = list(x = class_character), + package = NULL + ) + S4_register(S4regInheritedValidityS7) + setClass( + "S4regInheritedValidityChild", + contains = c( + S4_contains(S4regInheritedValidityS7), + "S4regInheritedValidityParent" + ) + ) + + object <- methods::new("S4regInheritedValidityChild", x = "a", y = 1) + methods::slot(object, "y") <- -1 + expect_snapshot(error = TRUE, { + prop(object, "x") <- "b" + }) + + object <- methods::new("S4regInheritedValidityChild", x = "a", y = 1) + methods::slot(object, "y") <- -1 + expect_snapshot(error = TRUE, { + props(object) <- list(x = "b") + }) + + object <- methods::new("S4regInheritedValidityChild", x = "a", y = 1) + methods::slot(object, "y") <- -1 + expect_snapshot(error = TRUE, { + methods::initialize(object, x = "b") + }) }) -test_that("converts S4 unions to S7 unions", { - Foo1 := local_S4_class(slots = "x") - Foo2 := local_S4_class(slots = "x") +test_that("S4 initialization sets S4 slots on subclasses of S7 classes", { + on.exit(S4_remove_classes(c( + "ParentForSlots", + "ChildForSlots", + "S4ChildForSlots" + ))) + setClass("ParentForSlots", slots = list(x = "numeric")) - Union1 := local_S4_union(c("Foo1", "Foo2")) - expect_equal( - S4_to_S7_class(getClass("Union1")), - new_union(getClass("Foo1"), getClass("Foo2")) + ChildForSlots <- new_class( + "ChildForSlots", + parent = getClass("ParentForSlots"), + properties = list(y = class_character), + package = NULL ) - Foo3 := local_S4_class(slots = "x") - Union2 := local_S4_union(c("Union1", "Foo3")) - expect_equal( - S4_to_S7_class(getClass("Union2")), - new_union(getClass("Foo1"), getClass("Foo2"), getClass("Foo3")) + setClass( + "S4ChildForSlots", + slots = list(z = "character"), + contains = "ChildForSlots" + ) + + parent <- ChildForSlots(x = 1, y = "a") + child <- methods::new("S4ChildForSlots", parent, z = "b") + + expect_true(isS4(child)) + expect_true(S7_inherits(child, ChildForSlots)) + expect_equal(prop(child, "x"), 1) + expect_equal(prop(child, "y"), "a") + expect_equal(methods::slot(child, "z"), "b") + + child@z <- "c" + child@y <- "d" + expect_equal(methods::slot(child, "z"), "c") + expect_equal(prop(child, "y"), "d") + + child <- methods::new("S4ChildForSlots", child) + expect_equal(methods::slot(child, "z"), "c") + expect_equal(prop(child, "y"), "d") +}) + +test_that("@<- sets S4-only slots on subclasses of S7 classes", { + on.exit(S4_remove_classes(c("ParentForAt", "ChildForAt", "S4ChildForAt"))) + setClass("ParentForAt", slots = list(x = "numeric")) + + ChildForAt <- new_class( + "ChildForAt", + parent = getClass("ParentForAt"), + properties = list(y = class_character), + package = NULL + ) + + setClass( + "S4ChildForAt", + slots = list(z = "character"), + contains = "ChildForAt" + ) + + child <- methods::new("S4ChildForAt", ChildForAt(x = 1, y = "a"), z = "b") + expect_equal(child@z, "b") + + child@z <- "c" + child@y <- "d" + + expect_equal(child@z, "c") + expect_equal(methods::slot(child, "z"), "c") + expect_equal(prop(child, "y"), "d") +}) + +test_that("S4 initialize supports S3 data parts", { + on.exit(S4_remove_classes(c("ParentNum", "ChildNum"))) + setClass("ParentNum", contains = "numeric", slots = list(y = "character")) + + ChildNum <- new_class( + "ChildNum", + parent = getClass("ParentNum"), + properties = list(z = class_integer), + package = NULL ) + child <- ChildNum(y = "a", z = 1L) + + child <- methods::initialize(child, 2.5, y = "b") + expect_equal(as.vector(child), 2.5) + expect_equal(prop(child, ".Data"), 2.5) + expect_equal(prop(child, "y"), "b") + expect_true(methods::validObject(child)) + + child <- methods::initialize(child, .Data = 3.5) + expect_equal(as.vector(child), 3.5) + expect_true(methods::validObject(child)) }) -test_that("converts S4 representation of S3 classes to S7 representation", { +test_that("S4 initialize strips S7 metadata from data parts", { + defer(S4_remove_classes(c( + "S4regDataPartSource", + "S4regDataPartTarget", + "S4regDataPartParent" + ))) + + setClass("S4regDataPartParent", contains = "numeric") + S4regDataPartTarget := new_class( + parent = getClass("S4regDataPartParent"), + properties = list(y = class_character), + package = NULL + ) + S4regDataPartSource := new_class( + parent = class_double, + properties = list(z = class_character), + package = NULL + ) + + target <- S4regDataPartTarget(.Data = 1, y = "target") + source <- S4regDataPartSource(.data = 2, z = "source") + + out <- methods::initialize(target, .Data = source) + + expect_equal(S7_class(out), S4regDataPartTarget) + expect_equal(as.vector(out), 2) + expect_equal(prop(out, "y"), "target") + expect_identical(methods::validObject(out), TRUE) +}) + +test_that("S4 data-part initialization preserves data attributes", { + defer(S4_remove_classes(c( + "S4regDataPartAttrsChild", + "S4regDataPartAttrsParent" + ))) + + setClass("S4regDataPartAttrsParent", contains = "numeric") + S4regDataPartAttrsChild := new_class( + parent = getClass("S4regDataPartAttrsParent"), + package = NULL + ) + + object <- S4regDataPartAttrsChild(.Data = c(a = 1)) + expect_equal(S7_data(object), c(a = 1)) + + source <- methods::new("S4regDataPartAttrsParent", .Data = c(b = 2)) + out <- methods::initialize(object, source) + expect_equal(S7_data(out), c(b = 2)) +}) + +test_that("S4 initialize unwraps S4 data-part replacements", { + defer(S4_remove_classes(c( + "S4regDataPartObjectValueChild", + "S4regDataPartObjectValueParent" + ))) + + setClass("S4regDataPartObjectValueParent", contains = "numeric") + S4regDataPartObjectValueChild := new_class( + parent = getClass("S4regDataPartObjectValueParent"), + properties = list(y = class_character), + package = NULL + ) + + object <- S4regDataPartObjectValueChild(.Data = c(a = 1), y = "target") + source <- methods::new( + "S4regDataPartObjectValueParent", + .Data = c(b = 2) + ) + + out <- methods::initialize(object, .Data = source) + + expect_equal(S7_class(out), S4regDataPartObjectValueChild) + expect_equal(S7_data(out), c(b = 2)) + expect_equal(prop(out, "y"), "target") + expect_identical(methods::validObject(out), TRUE) +}) + +test_that("S4 initialize ignores data-part attributes that collide with slots", { + defer(S4_remove_classes(c( + "S4regDataAttrParent", + "S4regDataAttrChild" + ))) + + setClass( + "S4regDataAttrParent", + contains = "numeric", + slots = list(z = "character") + ) + S4regDataAttrChild := new_class( + parent = getClass("S4regDataAttrParent"), + properties = list(y = class_character), + package = NULL + ) + + target <- S4regDataAttrChild(.Data = 1, y = "target", z = "slot") + source <- structure(2, y = "source", z = "source-slot", other = "keep") + + out <- methods::initialize(target, .Data = source) + + expect_equal(as.vector(out), 2) + expect_equal(prop(out, "y"), "target") + expect_equal(prop(out, "z"), "slot") + expect_equal(attr(out, "other", exact = TRUE), "keep") + expect_identical(methods::validObject(out), TRUE) +}) + +test_that("S4_register keeps direct .Data properties as ordinary properties", { + defer(S4_remove_classes("S4regDirectDataProperty")) + + S4regDirectDataProperty := new_class( + properties = list(.Data = class_numeric), + package = NULL + ) + S4_register(S4regDirectDataProperty) + + object <- S4regDirectDataProperty(.Data = 1) + + expect_equal(intersect(methods::slotNames(object), ".Data"), character()) + expect_equal(prop(object, ".Data"), 1) + expect_identical(methods::validObject(object, test = TRUE), TRUE) +}) + +test_that("S4 data part constructors use the .Data argument", { + defer(S4_remove_classes(c( + "S4regDataPartParent", + "S4regDataPartChild" + ))) + + setClass("S4regDataPartParent", contains = "numeric") + methods::setValidity("S4regDataPartParent", function(object) { + data <- as.vector(object) + if (!identical(data, 1) && !identical(data, 2)) { + "data part must be 1 or 2" + } else { + TRUE + } + }) + S4regDataPartChild <- new_class( + "S4regDataPartChild", + parent = getClass("S4regDataPartParent"), + package = NULL + ) + + object <- S4regDataPartChild(.Data = 1) + + expect_equal(as.vector(object), 1) + expect_equal(prop(object, ".Data"), 1) + expect_null(attr(object, ".Data", exact = TRUE)) + + prop(object, ".Data") <- 2 + expect_equal(as.vector(object), 2) + expect_equal(prop(object, ".Data"), 2) + expect_null(attr(object, ".Data", exact = TRUE)) + expect_true(methods::validObject(object)) +}) + +test_that("S4 data part constructors seed abstract descendants with .Data", { + defer(S4_remove_classes(c( + "S4regAbstractDataPartChild", + "S4regAbstractDataPart", + "S4regAbstractDataPartParent" + ))) + + setClass("S4regAbstractDataPartParent", contains = c("numeric", "VIRTUAL")) + S4regAbstractDataPart := new_class( + parent = getClass("S4regAbstractDataPartParent"), + abstract = TRUE, + package = NULL + ) + S4regAbstractDataPartChild := new_class( + parent = S4regAbstractDataPart, + package = NULL + ) + + object <- S4regAbstractDataPartChild(.Data = 1) + + expect_equal(as.vector(object), 1) + expect_equal(prop(object, ".Data"), 1) + expect_null(attr(object, ".Data", exact = TRUE)) + expect_true(methods::validObject(object)) +}) + +test_that("S7 subclasses validate S4 parents as the parent representation", { + defer(S4_remove_classes(c( + "S4regValidityConcreteParent", + "S4regValidityConcreteChild" + ))) + + setClass("S4regValidityConcreteParent", contains = "numeric") + methods::setValidity("S4regValidityConcreteParent", function(object) { + if (identical(as.character(class(object)), "S4regValidityConcreteParent")) { + TRUE + } else { + "parent validity must see parent class" + } + }) + S4regValidityConcreteChild := new_class( + parent = getClass("S4regValidityConcreteParent"), + package = NULL + ) + + expect_no_error(S4regValidityConcreteChild(.Data = 1)) +}) + +test_that("S7 subclasses validate initialized S4 parents without reinitializing", { + defer(S4_remove_classes(c( + "S4regRequiredInitializeParent", + "S4regRequiredInitializeChild" + ))) + + setClass("S4regRequiredInitializeParent", slots = list(x = "numeric")) + methods::setMethod( + "initialize", + "S4regRequiredInitializeParent", + function(.Object, x, ...) { + .Object <- callNextMethod(.Object, ...) + .Object@x <- x + .Object + } + ) + methods::setValidity("S4regRequiredInitializeParent", function(object) { + if ( + identical(as.character(class(object)), "S4regRequiredInitializeParent") + ) { + if (identical(methods::slot(object, "x"), 1)) { + return(TRUE) + } + return("parent validity must see initialized slot value") + } else { + "parent validity must see parent class" + } + }) + S4regRequiredInitializeChild := new_class( + parent = getClass("S4regRequiredInitializeParent"), + package = NULL + ) + + object <- S4regRequiredInitializeChild(x = 1) + + expect_equal(prop(object, "x"), 1) +}) + +test_that("S4 data part constructors use overridden .Data defaults", { + defer(S4_remove_classes(c( + "S4regDataDefaultParent", + "S4regDataDefaultChild", + "S4regDataDefaultShim" + ))) + + setClass( + "S4regDataDefaultParent", + contains = "numeric", + prototype = 1 + ) + S4regDataDefaultChild <- new_class( + "S4regDataDefaultChild", + parent = getClass("S4regDataDefaultParent"), + properties = list( + .Data = new_property(class_numeric, default = quote(2)) + ), + package = NULL + ) + S4regDataDefaultChild_S4 <- S4_contains(S4regDataDefaultChild) + setClass("S4regDataDefaultShim", contains = S4regDataDefaultChild_S4) + + expect_equal(as.vector(S4regDataDefaultChild()), 2) + + object <- methods::new("S4regDataDefaultShim") + expect_equal(as.vector(object), 2) + expect_equal(prop(object, ".Data"), 2) +}) + +test_that("S7_data() reads and writes S4 subclass data parts", { + defer(S4_remove_classes(c( + "S4regS7DataPartGrandChild", + "S4regS7DataPartChild", + "S4regS7DataPartParent" + ))) + + setClass("S4regS7DataPartParent", contains = "numeric") + S4regS7DataPartChild := new_class( + parent = getClass("S4regS7DataPartParent"), + properties = list(y = class_character), + package = NULL + ) + setClass( + "S4regS7DataPartGrandChild", + slots = list(z = "logical"), + contains = "S4regS7DataPartChild" + ) + + object <- methods::new( + "S4regS7DataPartGrandChild", + .Data = c(a = 1), + y = "a", + z = TRUE + ) + + expect_equal(S7_data(object), c(a = 1)) + expect_equal(as.vector(object), 1) + + S7_data(object) <- c(b = 2) + + expect_s4_class(object, "S4regS7DataPartGrandChild") + expect_equal(S7_data(object), c(b = 2)) + expect_equal(prop(object, "y"), "a") + expect_equal(methods::slot(object, "z"), TRUE) + expect_identical(methods::validObject(object), TRUE) +}) + +test_that("S7_data() preserves S4 data-part attributes on direct S7 children", { + defer(S4_remove_classes(c( + "S4regS7FactorChild", + "S4regS7FactorParent" + ))) + + setClass("S4regS7FactorParent", contains = "factor") + suppressWarnings({ + S4regS7FactorChild := new_class( + parent = getClass("S4regS7FactorParent"), + package = NULL + ) + }) + + object <- S4regS7FactorChild( + .Data = 1:2, + levels = c("a", "b"), + .S3Class = "factor" + ) + + expect_equal(S7_data(object), factor(c("a", "b"))) + + S7_data(object) <- factor("b", levels = c("a", "b", "c")) + + expect_equal(S7_data(object), factor("b", levels = c("a", "b", "c"))) +}) + +test_that("S7_data() keeps data attributes that match renamed S7 properties", { + defer(S4_remove_classes(c( + "S4regS7DataNameAttrChild", + "S4regS7DataNameAttrParent" + ))) + + setClass("S4regS7DataNameAttrParent", contains = "numeric") + S4regS7DataNameAttrChild := new_class( + parent = getClass("S4regS7DataNameAttrParent"), + properties = list(names = class_character), + package = NULL + ) + + object <- S4regS7DataNameAttrChild(.Data = c(a = 1), names = "prop") + + expect_equal(S7_data(object), c(a = 1)) + expect_equal(prop(object, "names"), "prop") + + S7_data(object) <- c(b = 2) + + expect_equal(S7_data(object), c(b = 2)) + expect_equal(prop(object, "names"), "prop") + expect_identical(methods::validObject(object), TRUE) +}) + +test_that("S4 subclasses read and write special-named S7 property storage slots", { + defer(S4_remove_classes(c( + "S4regSpecialSlotsChild", + "S4regSpecialSlots" + ))) + + S4regSpecialSlots <- new_class( + "S4regSpecialSlots", + properties = list( + names = class_character, + dim = class_integer + ), + package = NULL + ) + S4_register(S4regSpecialSlots) + S4regSpecialSlots_S4 <- S4_contains(S4regSpecialSlots) + + direct <- S4regSpecialSlots(names = "direct", dim = 1L) + expect_equal(methods::slot(direct, "_names"), "direct") + expect_equal(prop(direct, "names"), "direct") + + setClass( + "S4regSpecialSlotsChild", + contains = S4regSpecialSlots_S4, + slots = list(names = "character") + ) + + object <- methods::new( + "S4regSpecialSlotsChild", + names = "n", + dim = 2L + ) + methods::slot(object, "names") <- "s4-only" + + expect_equal(methods::slot(object, "_names"), "n") + expect_equal(methods::slot(object, "_dim"), 2L) + expect_equal(methods::slot(object, "names"), "s4-only") + expect_equal(prop(object, "names"), "n") + expect_true(methods::validObject(object)) + + storage_object <- methods::new( + "S4regSpecialSlotsChild", + `_names` = "storage", + `_dim` = 3L + ) + + expect_equal(methods::slot(storage_object, "_names"), "storage") + expect_equal(methods::slot(storage_object, "_dim"), 3L) + expect_equal(prop(storage_object, "names"), "storage") + + prop(object, "names") <- "updated" + expect_equal(methods::slot(object, "_names"), "updated") + expect_equal(methods::slot(object, "names"), "s4-only") + expect_equal(prop(object, "names"), "updated") + + new <- methods::new("S4regSpecialSlotsChild", object) + expect_equal(prop(new, "names"), "updated") + expect_equal(methods::slot(new, "_names"), "updated") +}) + +test_that("S7 classes preserve special-named properties inherited through S4", { + defer(S4_remove_classes(c( + "S4regSpecialSlotGrand", + "S4regSpecialSlotMiddle", + "S4regSpecialSlotParent" + ))) + + S4regSpecialSlotParent := new_class( + properties = list(names = class_character), + package = NULL + ) + S4_register(S4regSpecialSlotParent) + methods::setClass( + "S4regSpecialSlotMiddle", + contains = S4_contains(S4regSpecialSlotParent) + ) + S4regSpecialSlotGrand := new_class( + parent = methods::getClass("S4regSpecialSlotMiddle"), + package = NULL + ) + + object <- S4regSpecialSlotGrand(names = "n") + + expect_equal(prop_names(object), "names") + expect_equal(prop(object, "names"), "n") + expect_equal(methods::slot(object, "_names"), "n") + expect_equal(S7_inherits(object, S4regSpecialSlotParent), TRUE) + expect_identical(methods::validObject(object), TRUE) +}) + +test_that("S7 classes preserve .S3Class slots inherited from S4 parents", { + defer(S4_remove_classes(c( + "S4regS3ClassSlotChild", + "S4regS3ClassSlotParent", + "S4regS3ClassSlotOld", + "S4regS3ClassSlotBase" + ))) + + old_classes <- c("S4regS3ClassSlotOld", "S4regS3ClassSlotBase") + methods::setOldClass(old_classes) + methods::setClass( + "S4regS3ClassSlotParent", + contains = "S4regS3ClassSlotOld" + ) + S4regS3ClassSlotChild := new_class( + parent = methods::getClass("S4regS3ClassSlotParent"), + package = NULL + ) + + object <- S4regS3ClassSlotChild() + + expect_equal(prop(object, ".S3Class"), old_classes) expect_equal( - S4_to_S7_class(getClass("Date")), - class_Date, - ignore_function_env = TRUE + S7_inherits(object, methods::getClass("S4regS3ClassSlotParent")), + TRUE ) + parent <- convert(object, to = methods::getClass("S4regS3ClassSlotParent")) + expect_s4_class(parent, "S4regS3ClassSlotParent") + expect_equal(methods::slot(parent, ".S3Class"), old_classes) }) -test_that("errors on non-S4 classes", { - expect_snapshot(S4_to_S7_class(1), error = TRUE) +test_that("S4 classes can not extend S7-over-S4 classes with property setters", { + on.exit(S4_remove_classes(c("Parent2", "Child2", "S4Child2"))) + setClass("Parent2", slots = list(x = "numeric")) + + Child2 <- new_class( + "Child2", + parent = getClass("Parent2"), + properties = list( + y = new_property(class_character, setter = function(self, value) { + attr(self, "setter_called") <- TRUE + attr(self, "y") <- value + self + }) + ), + package = NULL + ) + expect_true(attr(Child2(x = 1, y = "a"), "setter_called", exact = TRUE)) + expect_error( + S4_contains(Child2), + "custom setter" + ) + + methods::setClass("S4Child2", contains = "Child2") + expect_error( + methods::new("S4Child2"), + "custom setter" + ) +}) + +test_that("S4 parents reject slots that need renamed S7 storage", { + defer(S4_remove_classes(c( + "S4regRenamedSlotChild", + "S4regRenamedSlotParent" + ))) + + setClass("S4regRenamedSlotParent", slots = list(names = "character")) + + expect_snapshot(error = TRUE, { + new_class( + "S4regRenamedSlotChild", + parent = getClass("S4regRenamedSlotParent"), + package = NULL + ) + }) +}) + +test_that("S4 parents reject accessor overrides of inherited slots", { + defer(S4_remove_classes(c( + "S4regAccessorSlotGetterChild", + "S4regAccessorSlotParent", + "S4regAccessorSlotSetterChild" + ))) + + setClass("S4regAccessorSlotParent", slots = list(x = "numeric")) + + expect_snapshot(error = TRUE, { + new_class( + "S4regAccessorSlotGetterChild", + parent = getClass("S4regAccessorSlotParent"), + properties = list( + x = new_property(class_numeric, getter = function(self) 1) + ), + package = NULL + ) + }) + + expect_snapshot(error = TRUE, { + new_class( + "S4regAccessorSlotSetterChild", + parent = getClass("S4regAccessorSlotParent"), + properties = list( + x = new_property(class_numeric, setter = function(self, value) self) + ), + package = NULL + ) + }) +}) + +test_that("S7 subclasses reject accessor overrides of inherited S4 slots", { + defer(S4_remove_classes(c( + "S4regS7AccessorSlotGetterChild", + "S4regS7AccessorSlotParent", + "S4regS7AccessorSlotSetterChild" + ))) + + setClass("S4regS7AccessorSlotParent", slots = list(x = "numeric")) + Parent := new_class( + parent = getClass("S4regS7AccessorSlotParent"), + package = NULL + ) + + expect_snapshot(error = TRUE, { + new_class( + "S4regS7AccessorSlotGetterChild", + parent = Parent, + properties = list( + x = new_property(class_numeric, getter = function(self) 1) + ), + package = NULL + ) + }) + + expect_snapshot(error = TRUE, { + new_class( + "S4regS7AccessorSlotSetterChild", + parent = Parent, + properties = list( + x = new_property(class_numeric, setter = function(self, value) self) + ), + package = NULL + ) + }) +}) + +test_that("S7 property narrowing rejects unrelated S4 name matches", { + defer(S4_remove_classes(c( + "S4regPropertyNameCollisionChild", + "S4regPropertyNameCollisionParent" + ))) + + setClass("S4regPropertyNameCollisionParent") + setClass( + "S4regPropertyNameCollisionChild", + contains = "S4regPropertyNameCollisionParent" + ) + + S4regPropertyNameCollisionParent := new_class(package = NULL) + Parent := new_class( + properties = list(x = S4regPropertyNameCollisionParent), + package = NULL + ) + + expect_snapshot(error = TRUE, { + new_class( + "S4regPropertyNameCollisionOverride", + parent = Parent, + properties = list(x = getClass("S4regPropertyNameCollisionChild")), + package = NULL + ) + }) }) @@ -121,6 +3334,20 @@ test_that("S4_class_dispatch ignores unions", { expect_equal(S4_class_dispatch("Foo2"), "S4/S7::Foo2") }) +test_that("S4_class_dispatch dispatches through the full S3 old-class hierarchy", { + setOldClass(c("S4OldS3a", "S4OldS3b")) + defer(S4_remove_classes(c("S4OldS3Child", "S4OldS3a", "S4OldS3b"))) + setClass("S4OldS3Child", contains = "S4OldS3a") + + generic <- new_generic("S4OldS3Generic", "x") + method(generic, new_S3_class("S4OldS3b")) <- function(x) "S3 parent" + + object <- methods::new("S4OldS3Child") + + expect_contains(obj_dispatch(object), "S4OldS3b") + expect_equal(generic(object), "S3 parent") +}) + test_that("S4_class_dispatch includes virtual classes", { Foo1 := local_S4_class() Foo2 := local_S4_class(contains = "Foo1") @@ -141,6 +3368,45 @@ test_that("S4_class_dispatch captures implicit package name", { expect_equal(S4_class_dispatch("Foo1"), "S4/mypkg::Foo1") }) +test_that("S7 class extending S4 class with multiple parents works", { + on.exit(S4_remove_classes(c( + "MultiParent1", + "MultiParent2", + "MultiChild", + "S7MultiChild", + "S7MultiChild2" + ))) + + setClass("MultiParent1", slots = list(x = "numeric")) + setClass("MultiParent2", slots = list(y = "numeric")) + setClass("MultiChild", contains = c("MultiParent1", "MultiParent2")) + + S7MultiChild <- new_class( + "S7MultiChild", + parent = getClass("MultiChild"), + properties = list(z = class_numeric), + package = NULL + ) + + S7MultiChild2 <- new_class( + "S7MultiChild2", + parent = S7MultiChild, + properties = list(w = class_numeric), + package = NULL + ) + + obj <- S7MultiChild2(x = 1, y = 2, z = 3, w = 4) + expect_true(S7_inherits(obj, S7MultiChild2)) + expect_true(S7_inherits(obj, S7MultiChild)) + expect_equal(prop(obj, "x"), 1) + expect_equal(prop(obj, "y"), 2) + expect_equal(prop(obj, "z"), 3) + expect_equal(prop(obj, "w"), 4) + + expect_true(methods::is(obj, "MultiParent1")) + expect_true(methods::is(obj, "MultiParent2")) +}) + test_that("S4_package_name resolves S4 package name correctly in all cases", { stats_ns <- asNamespace("stats") diff --git a/tests/testthat/test-class.R b/tests/testthat/test-class.R index 6789d278..723b4a62 100644 --- a/tests/testthat/test-class.R +++ b/tests/testthat/test-class.R @@ -60,14 +60,63 @@ test_that("S7 classes check inputs", { }) }) -test_that("S7 classes can't inherit from S4 or class unions", { +test_that("S7 classes can inherit from S4 but not class unions", { parentS4 := local_S4_class(slots = c(x = "numeric")) + + child <- new_class("test", parent = parentS4, package = NULL) + expect_s3_class(child, "S7_class") + expect_s4_class(child@parent, "classRepresentation") + expect_equal(as.character(child@parent@className), "parentS4") + expect_error( + new_class("test", parent = new_union(class_character)), + "`parent` must be an S7 class, S4 class, S3 class, or base type" + ) +}) + +test_that("S7 classes accept ordinary values for S4 parent slots", { + Parent := local_S4_class(slots = list(x = "ANY", y = "matrix")) + Child := new_class(parent = Parent, package = NULL) + + y <- matrix(1, nrow = 1) + obj <- Child(x = 1, y = y) + + expect_equal(obj@x, 1) + expect_equal(obj@y, y) +}) + +test_that("S7 classes reject S4 parents with implicit data parts", { expect_snapshot(error = TRUE, { - new_class("test", parent = parentS4) - new_class("test", parent = new_union("character")) + new_class("Child", parent = methods::getClass("matrix"), package = NULL) }) }) +test_that("S7 classes reject duplicate property storage names", { + defer(S4_remove_classes("StorageNameParent")) + + setClass("StorageNameParent", slots = list(`_names` = "character")) + + expect_snapshot(error = TRUE, { + new_class( + "StorageNameChild", + parent = getClass("StorageNameParent"), + properties = list(names = class_character), + package = NULL + ) + }) +}) + +test_that("S7_class can be used as a property name", { + foo <- new_class( + "foo", + properties = list(S7_class = class_numeric), + package = NULL + ) + object <- foo(S7_class = 1) + + expect_equal(prop(object, "S7_class"), 1) + expect_equal(S7_class(object), foo) +}) + test_that("inheritance combines properties for parent classes", { foo1 := new_class(properties = list(x = class_double)) foo2 := new_class(foo1, properties = list(y = class_double)) @@ -113,6 +162,76 @@ test_that("inheritance lets child properties narrow with S4 inheritance", { expect_s4_class(Child(x = x)@x, "S4PropertyChild") }) +test_that("inheritance lets child properties narrow S4 slots with S7-over-S4 classes", { + Animal := local_S4_class() + Kennel := local_S4_class(slots = list(dog = "Animal")) + Dog := new_class(parent = Animal, package = NULL) + + DogKennel := new_class( + parent = Kennel, + properties = list(dog = Dog), + package = NULL + ) + dog <- Dog() + + expect_equal(prop(DogKennel(dog = dog), "dog"), dog) +}) + +test_that("inheritance lets child properties narrow to S4 subclasses of S7 classes", { + defer(S4_remove_classes(c( + "S4PropertyS7Parent", + "S4PropertyS7Child" + ))) + + S4PropertyS7Parent := new_class(package = NULL) + S4_register(S4PropertyS7Parent) + setClass( + "S4PropertyS7Child", + contains = S4_contains(S4PropertyS7Parent) + ) + S4PropertyParent := new_class( + properties = list(x = S4PropertyS7Parent), + package = NULL + ) + S4PropertyChild := new_class( + parent = S4PropertyParent, + properties = list(x = getClass("S4PropertyS7Child")), + package = NULL + ) + + x <- methods::new("S4PropertyS7Child") + expect_s4_class(S4PropertyChild(x = x)@x, "S4PropertyS7Child") +}) + +test_that("inheritance lets S7-over-S4 children narrow to original S7 parents", { + defer(S4_remove_classes(c( + "S4PropertyS7Bridge", + "S4PropertyS7Descendant", + "S4PropertyS7Ancestor" + ))) + + S4PropertyS7Ancestor := new_class(package = NULL) + S4_register(S4PropertyS7Ancestor) + setClass("S4PropertyS7Bridge", contains = S4_contains(S4PropertyS7Ancestor)) + S4PropertyS7Descendant := new_class( + parent = getClass("S4PropertyS7Bridge"), + package = NULL + ) + + Parent := new_class( + properties = list(x = S4PropertyS7Ancestor), + package = NULL + ) + + expect_no_error({ + Child := new_class( + parent = Parent, + properties = list(x = S4PropertyS7Descendant), + package = NULL + ) + }) +}) + test_that("inheritance doesn't let child properties narrow S7_object with base or S3 classes", { Parent <- new_class( "Parent", @@ -257,6 +376,32 @@ test_that("new_object() errors if `_parent` doesn't inherit from the parent clas }) }) +test_that("new_object() rejects S4 parent objects in custom constructors", { + Parent := local_S4_class(slots = list(x = "numeric")) + Child := new_class( + parent = Parent, + package = NULL, + constructor = function() { + new_object(methods::new("Parent", x = 1)) + } + ) + + expect_snapshot(Child(), error = TRUE) +}) + +test_that("new_object() rejects non-S7 seeds for S4 parents without data parts", { + Parent := local_S4_class(slots = list(x = "numeric")) + Child := new_class( + parent = Parent, + package = NULL, + constructor = function() { + new_object(1, x = 1) + } + ) + + expect_snapshot(Child(), error = TRUE) +}) + test_that("new_object() allows S7_object placeholder for abstract parents", { Abstract := new_class( package = NULL, diff --git a/tests/testthat/test-convert.R b/tests/testthat/test-convert.R index f6b476b3..a0b79ca2 100644 --- a/tests/testthat/test-convert.R +++ b/tests/testthat/test-convert.R @@ -69,6 +69,27 @@ test_that("fallback convert can convert to super class", { expect_equal(attr(obj, "y"), NULL) }) +test_that("fallback convert preserves S7_class property when upcasting", { + local_methods(convert) + Parent := new_class( + properties = list(S7_class = class_numeric), + package = NULL + ) + Child := new_class( + parent = Parent, + properties = list(x = class_character), + package = NULL + ) + + child <- Child(S7_class = 1, x = "a") + parent <- convert(child, to = Parent) + + expect_equal(S7_class(parent), Parent) + expect_equal(prop(parent, "S7_class"), 1) + expect_equal(props(parent), list(S7_class = 1)) + expect_null(attr(parent, "x", exact = TRUE)) +}) + test_that("fallback convert can convert to subclass", { local_methods(convert) Foo := new_class(properties = list(x = class_numeric)) @@ -136,6 +157,151 @@ test_that("fallback convert can convert to base type", { expect_equal(attr(obj, "x"), NULL) }) +test_that("fallback convert can convert_up() an S4-derived S7 object to an S4 object", { + on.exit(S4_remove_classes(c("ParentS4", "ChildS7"))) + setClass("ParentS4", slots = list(x = "numeric")) + + ChildS7 <- new_class( + "ChildS7", + parent = getClass("ParentS4"), + properties = list(y = class_character), + package = NULL + ) + + child <- ChildS7(x = 10, y = "a") + parent <- convert(child, to = getClass("ParentS4")) + + expect_true(isS4(parent)) + expect_equal(class(parent)[1L], "ParentS4") + expect_equal(methods::slot(parent, "x"), 10) +}) + +test_that("fallback convert can convert_down() an S4 object to an S7 child", { + local_methods(convert) + on.exit(S4_remove_classes(c("ParentS4", "ChildS7"))) + setClass("ParentS4", slots = list(x = "numeric")) + + ChildS7 := new_class( + parent = getClass("ParentS4"), + properties = list(y = class_character), + package = NULL + ) + + parent <- methods::new("ParentS4", x = 10) + child <- convert(parent, to = ChildS7, y = "a") + + expect_true(S7_inherits(child, ChildS7)) + expect_equal(prop(child, "x"), 10) + expect_equal(prop(child, "y"), "a") +}) + +test_that("fallback convert drops S4-only slots when upcasting S4 subclasses", { + defer(S4_remove_classes(c( + "ConvertS4OnlyChild", + "ConvertS4OnlyParent" + ))) + + ConvertS4OnlyParent := new_class( + properties = list(x = class_numeric), + package = NULL + ) + S4_register(ConvertS4OnlyParent) + ConvertS4OnlyParent_S4 <- S4_contains(ConvertS4OnlyParent) + methods::setClass( + "ConvertS4OnlyChild", + contains = ConvertS4OnlyParent_S4, + slots = list(y = "character") + ) + + child <- methods::new("ConvertS4OnlyChild", x = 1, y = "a") + parent <- convert(child, to = ConvertS4OnlyParent) + + expect_identical(isS4(parent), FALSE) + expect_equal(S7_class(parent), ConvertS4OnlyParent) + expect_equal(prop(parent, "x"), 1) + expect_null(attr(parent, "y", exact = TRUE)) + expect_null(attr(parent, ".S3Class", exact = TRUE)) +}) + +test_that("fallback convert preserves renamed S7 property slots when upcasting", { + defer(S4_remove_classes(c( + "ConvertS4SpecialChild", + "ConvertS4SpecialParent" + ))) + + ConvertS4SpecialParent := new_class( + properties = list(names = class_character), + package = NULL + ) + S4_register(ConvertS4SpecialParent) + ConvertS4SpecialParent_S4 <- S4_contains(ConvertS4SpecialParent) + methods::setClass( + "ConvertS4SpecialChild", + contains = ConvertS4SpecialParent_S4, + slots = list(extra = "character") + ) + + child <- methods::new( + "ConvertS4SpecialChild", + names = "n", + extra = "old" + ) + parent <- convert(child, to = ConvertS4SpecialParent) + + expect_identical(isS4(parent), FALSE) + expect_equal(S7_class(parent), ConvertS4SpecialParent) + expect_equal(prop(parent, "names"), "n") + expect_null(attr(parent, "extra", exact = TRUE)) +}) + +test_that("fallback convert can use explicit S4 coercion via methods::as", { + on.exit(S4_remove_classes(c("ParentS4", "ChildS7", "UnrelatedS4"))) + setClass("ParentS4", slots = list(x = "numeric")) + setClass("UnrelatedS4", slots = list(z = "character")) + + ChildS7 <- new_class( + "ChildS7", + parent = getClass("ParentS4"), + properties = list(y = class_character), + package = NULL + ) + + setAs("ChildS7", "UnrelatedS4", function(from) { + new("UnrelatedS4", z = as.character(methods::slot(from, "x"))) + }) + + child <- ChildS7(x = 42, y = "a") + res <- convert(child, to = getClass("UnrelatedS4")) + + expect_true(isS4(res)) + expect_equal(class(res)[1L], "UnrelatedS4") + expect_equal(methods::slot(res, "z"), "42") +}) + +test_that("fallback convert rejects unrelated S4 name matches for S7 targets", { + defer(S4_remove_classes(c( + "ConvertS4NameCollisionFrom", + "ConvertS4NameCollisionTo" + ))) + + setClass("ConvertS4NameCollisionFrom", slots = list(x = "numeric")) + setClass("ConvertS4NameCollisionTo", slots = list(y = "numeric")) + ConvertS4NameCollisionTo := new_class(package = NULL) + + setAs( + "ConvertS4NameCollisionFrom", + "ConvertS4NameCollisionTo", + function(from) { + new("ConvertS4NameCollisionTo", y = methods::slot(from, "x")) + } + ) + + from <- methods::new("ConvertS4NameCollisionFrom", x = 1) + expect_snapshot(error = TRUE, { + convert(from, to = ConvertS4NameCollisionTo) + }) +}) + test_that("is_down_cast() is TRUE only when `to` descends from `from` (#509)", { Base := new_class(package = NULL) A := new_class( diff --git a/tests/testthat/test-inherits.R b/tests/testthat/test-inherits.R index 73755a9d..7250c53e 100644 --- a/tests/testthat/test-inherits.R +++ b/tests/testthat/test-inherits.R @@ -26,10 +26,33 @@ test_that("accepts any class specification (#556)", { expect_true(S7_inherits("anything", class_any)) }) +test_that("S4 class checks reject spoofed S3 objects", { + Foo := local_S4_class() + Child := new_class(parent = Foo, package = NULL) + holder := new_class(properties = list(x = Foo), package = NULL) + spoof <- structure(list(), class = "Foo") + + expect_true(S7_inherits(Child(), Foo)) + expect_false(S7_inherits(spoof, Foo)) + expect_snapshot(error = TRUE, holder(x = spoof)) +}) + test_that("checks that input is a class", { expect_snapshot(S7_inherits(1:10, "x"), error = TRUE) }) +test_that("ignores S7 class attributes without an S7 object marker", { + Foo := new_class(package = NULL) + + object <- structure(1, `_S7_class` = Foo) + legacy_object <- structure(1, S7_class = Foo) + + expect_false(S7_inherits(object)) + expect_false(S7_inherits(object, Foo)) + expect_false(S7_inherits(legacy_object)) + expect_false(S7_inherits(legacy_object, Foo)) +}) + test_that("throws informative error", { expect_snapshot(error = TRUE, { foo1 := new_class(package = NULL) diff --git a/tests/testthat/test-method-register-S3.R b/tests/testthat/test-method-register-S3.R index 9357398f..45fecdb6 100644 --- a/tests/testthat/test-method-register-S3.R +++ b/tests/testthat/test-method-register-S3.R @@ -55,6 +55,183 @@ test_that("can register S7 method for S3 generic with S3 class signature", { expect_equal(s3_gen(factor("a")), "factor") }) +test_that("internal generics register S4 methods for S4-backed S7 classes", { + on.exit({ + try(methods::removeMethod("dim", "S4regDimParent"), silent = TRUE) + try(methods::removeMethod("dim", "S4regDimChild"), silent = TRUE) + S4_remove_classes(c( + "S4regDimParent", + "S4regDimChild", + "S4regDimShim" + )) + }) + + setClass("S4regDimParent", contains = "VIRTUAL") + setMethod("dim", "S4regDimParent", function(x) { + stop("parent S4 method should not be called", call. = FALSE) + }) + S4regDimChild <- new_class( + "S4regDimChild", + parent = getClass("S4regDimParent"), + properties = list(x = class_integer), + package = NULL + ) + method(dim, S4regDimChild) <- function(x) c(x@x, 2L) + S4regDimChild_S4 <- S4_contains(S4regDimChild) + setClass("S4regDimShim", contains = S4regDimChild_S4) + + object <- methods::new("S4regDimShim", x = 1L) + + expect_true(isS4(object)) + expect_equal(dim(object), c(1L, 2L)) +}) + +test_that("base closures register S4 methods for S4-backed S7 classes", { + defer({ + suppressWarnings(try( + methods::removeMethod("unlist", "S4regUnlistChild"), + silent = TRUE + )) + S4_remove_classes(c( + "S4regUnlistParent", + "S4regUnlistChild", + "S4regUnlistShim" + )) + }) + + setClass("S4regUnlistParent", contains = "VIRTUAL") + S4regUnlistChild := new_class( + parent = getClass("S4regUnlistParent"), + properties = list(x = class_integer), + package = NULL + ) + method(unlist, S4regUnlistChild) <- function( + x, + recursive = TRUE, + use.names = TRUE + ) { + x@x + } + S4regUnlistChild_S4 <- S4_contains(S4regUnlistChild) + setClass("S4regUnlistShim", contains = S4regUnlistChild_S4) + + object <- methods::new("S4regUnlistShim", x = 1L) + + expect_equal(unlist(object), 1L) + expect_true(methods::hasMethod("unlist", "S4regUnlistChild")) +}) + +test_that("local S3 generics named like internal generics don't register S4 methods", { + defer({ + suppressWarnings(try( + methods::removeMethod("dim", "S4LocalDimChild"), + silent = TRUE + )) + S4_remove_classes(c( + "S4LocalDimParent", + "S4LocalDimChild" + )) + }) + + setClass("S4LocalDimParent", contains = "VIRTUAL") + S4LocalDimChild := new_class( + parent = getClass("S4LocalDimParent"), + properties = list(x = class_integer), + package = NULL + ) + dim <- local(function(x) UseMethod("dim")) + defer(unregister_s3_methods(topenv(environment(dim)), "dim")) + + method(dim, S4LocalDimChild) <- function(x) c(x@x, 2L) + + expect_equal(dim(S4LocalDimChild(x = 1L)), c(1L, 2L)) + expect_null(methods::selectMethod( + "dim", + "S4LocalDimChild", + optional = TRUE, + useInherited = FALSE + )) +}) + +test_that("internal replacement generics can register full S4 signatures", { + on.exit({ + try( + methods::removeMethod( + "dimnames<-", + c("S4regDimnamesChild", "list") + ), + silent = TRUE + ) + S4_remove_classes(c( + "S4regDimnamesParent", + "S4regDimnamesChild", + "S4regDimnamesShim" + )) + }) + + setClass("S4regDimnamesParent", contains = "VIRTUAL") + S4regDimnamesChild <- new_class( + "S4regDimnamesChild", + parent = getClass("S4regDimnamesParent"), + properties = list(x = class_list), + package = NULL + ) + method(`dimnames<-`, list(S4regDimnamesChild, class_list)) <- + function(x, value) { + x@x <- value + x + } + S4regDimnamesChild_S4 <- S4_contains(S4regDimnamesChild) + setClass("S4regDimnamesShim", contains = S4regDimnamesChild_S4) + + object <- methods::new("S4regDimnamesShim", x = list(NULL, NULL)) + value <- list("r", "c") + dimnames(object) <- value + + expect_equal(methods::slot(object, "x"), value) + expect_true(methods::hasMethod( + "dimnames<-", + c("S4regDimnamesChild", "list") + )) +}) + +test_that("sentinels for internal replacement generics keep full S4 signatures", { + on.exit(S4_remove_classes(c( + "S4regDimnamesSentinelParent", + "S4regDimnamesSentinelChild" + ))) + + setClass("S4regDimnamesSentinelParent", contains = "VIRTUAL") + S4regDimnamesSentinelChild <- new_class( + "S4regDimnamesSentinelChild", + parent = getClass("S4regDimnamesSentinelParent"), + properties = list(x = class_list), + package = NULL + ) + + dimnames_sentinel <- generic_sentinel(as_generic(`dimnames<-`)) + expect_no_error( + register_method( + dimnames_sentinel, + list(S4regDimnamesSentinelChild, class_list), + function(x, value) x, + package = NULL + ) + ) + on.exit( + methods::removeMethod( + "dimnames<-", + c("S4regDimnamesSentinelChild", "list") + ), + add = TRUE, + after = FALSE + ) + expect_true(methods::hasMethod( + "dimnames<-", + c("S4regDimnamesSentinelChild", "list") + )) +}) + test_that("S3 registration for a multi-class S3 class uses only the first class", { local_s3_generic("s3_gen") method(s3_gen, new_S3_class(c("ordered", "factor"))) <- function(x) "ord" diff --git a/tests/testthat/test-method-register-S4.R b/tests/testthat/test-method-register-S4.R index 7bc10c97..0dc48d52 100644 --- a/tests/testthat/test-method-register-S4.R +++ b/tests/testthat/test-method-register-S4.R @@ -11,6 +11,22 @@ test_that("can register S7 method for S4 generic", { expect_equal(bar(S4foo()), "foo") }) +test_that("can register S3 method for S4 generic", { + methods::setGeneric("s4_s3", function(x) standardGeneric("s4_s3")) + defer({ + suppressMessages(methods::removeGeneric("s4_s3")) + S4_remove_classes("S4regS3Method") + }) + + S4regS3Method <- new_S3_class("S4regS3Method") + S4_register(S4regS3Method) + + method(s4_s3, S4regS3Method) <- function(x) "s3" + + object <- structure(list(), class = "S4regS3Method") + expect_equal(s4_s3(object), "s3") +}) + test_that("can register S4 methods for base types, class_any, class_missing, and NULL", { methods::setGeneric("s4_gen", function(x) standardGeneric("s4_gen")) method(s4_gen, class_character) <- function(x) "char" diff --git a/tests/testthat/test-method-register.R b/tests/testthat/test-method-register.R index d198c1d3..45943e30 100644 --- a/tests/testthat/test-method-register.R +++ b/tests/testthat/test-method-register.R @@ -51,6 +51,7 @@ test_that("method registration checks argument types", { x <- 10 method(x, class_character) <- function(x) ... method(foo, 1) <- function(x) ... + method(foo, list()) <- function(x) ... }) }) diff --git a/vignettes/compatibility.Rmd b/vignettes/compatibility.Rmd index bd9ef80e..b79a4e88 100644 --- a/vignettes/compatibility.Rmd +++ b/vignettes/compatibility.Rmd @@ -26,7 +26,7 @@ library(S7) S7 objects *are* S3 objects, because S7 is implemented on top of S3. There are two main differences between an S7 object and an S3 object: -- As well as the `class` attribute possessed by S3 objects, S7 objects have an additional `S7_class` attribute that contains the object that defines the class. +- As well as the `class` attribute possessed by S3 objects, S7 objects have an additional `_S7_class` attribute that contains the object that defines the class. - S7 objects have properties; S3 objects have attributes. Properties are implemented on top of attributes, so you can access them directly with `attr` and friends. @@ -143,16 +143,142 @@ The chief disadvantage of this approach is any subclasses will need to be conver ## S4 -S7 properties are equivalent to S4 slots. -The chief difference is that they can be dynamic. +S7 properties play a role similar to S4 slots. +The chief difference is that S7 properties can be dynamic, while S4 slots are +stored fields with a declared S4 class. -- S7 classes can not extend S4 classes -- S4 classes can extend S3 classes -- S7 can register methods for S4 generics and S4 classes +S7 and S4 can interoperate in both directions: + +- S7 classes can extend S4 classes. +- S4 classes can extend S7 classes. +- S7 can register methods for S4 generics and S4 classes. + +### S7 classes that extend S4 classes + +To extend an S4 class, supply its class definition or class generator as the +`parent` of a new S7 class. The S4 parent slots become S7 properties on the new +class, and `new_class()` automatically registers the S7 class with S4. + +```{r} +methods::setClass("S4Point", + slots = c(x = "numeric", y = "numeric") +) + +ColoredPoint <- new_class("ColoredPoint", + parent = methods::getClass("S4Point"), + properties = list(color = class_character) +) + +pt <- ColoredPoint(x = 1, y = 2, color = "red") +pt@x +pt@color +methods::is(pt, "S4Point") +``` + +S4 dispatch follows the S4 parent hierarchy, so S4 methods defined for the +parent can be called on the S7 child. + +```{r} +methods::setGeneric("radius", function(x) standardGeneric("radius")) +methods::setMethod("radius", "S4Point", function(x) { + sqrt(x@x^2 + x@y^2) +}) + +radius(pt) +``` + +S4 code that updates an existing object should use `initialize()` rather than +constructing a new object from `class(x)`. The S7 `initialize()` method accepts +stored S7 properties and S4 slots, and later arguments override earlier ones. + +```{r} +pt <- methods::initialize(pt, x = 3, color = "blue") +pt@x +pt@color +``` + +There are a few important caveats: + +- An S7 object that directly extends S4 is represented as an S3 old-class + object, so `isS4(pt)` is `FALSE`. Use `methods::is()` to ask about S4 + inheritance. +- The class vector is not scalar. S4 code that needs one primary class name + should use `class(x)[1L]`, or `methods::class1(x)` when available. +- `methods::slot()` and `methods::slot<-()` can read and write stored + properties, but they bypass custom S7 getters, setters, and ordinary S7 + validation. Call `methods::validObject()` after direct slot updates when + the object should satisfy the S7 contract. +- Properties with custom getters or setters cannot cross the S4 inheritance + boundary as S4 slots. +- `NULL` properties are stored using the same sentinel that S4 uses for + `NULL` slots. `prop()`, `@`, and `methods::slot()` translate this back to + `NULL`; raw attributes should be treated as an implementation detail. + +### S4 classes that extend S7 classes + +After calling `S4_register()`, use `S4_contains()` when an S4 class should +extend an S7 class. It returns the virtual S4 class name for +`methods::setClass(contains = )`. This class exposes stored S7 properties as +formal S4 slots and carries the `_S7_class` slot that S7 uses for dispatch and +validation. + +```{r} +Sample <- new_class("Sample", + properties = list( + name = class_character, + score = class_numeric + ), + validator = function(self) { + if (length(self@score) != 1) { + "@score must have length 1" + } else if (self@score < 0) { + "@score must be non-negative" + } + } +) + +S4_register(Sample) +Sample_S4 <- S4_contains(Sample) +methods::setClass("ReplicatedSample", + contains = Sample_S4, + slots = c(replicate = "integer") +) + +rs <- methods::new("ReplicatedSample", + name = "A", + score = 3, + replicate = 1L +) + +isS4(rs) +rs@name +prop(rs, "score") +methods::validObject(rs) +``` + +S7 dispatch still sees the S7 class, even though the concrete object is an S4 +object. + +```{r} +sample_label <- new_generic("sample_label", "x") +method(sample_label, Sample) <- function(x) { + paste0(x@name, ": ", x@score) +} + +sample_label(rs) +``` + +The class returned by `S4_contains()` is a compatibility layer, +not a user-facing class. Do not instantiate it directly; use it only as a +superclass for another S4 class. Since S4 subclasses are real S4 objects, S4 +code can access the S7 properties as slots. This is necessary for +compatibility, but it also means S4 code can bypass S7 property setters until +validation is run. ### Unions -S4 unions are automatically converted to S7 unions. +S4 unions are automatically converted to S7 unions when they are used as S7 +property classes. There's an important difference in the way that class unions are handled in S4 and S7. In S4, they're handled at method dispatch time, so when you create `setUnion("u1", c("class1", "class2"))`, `class1` and `class2` now extend `u1`. In S7, unions are handled at method registration time so that registering a method for a union is just short-hand for registering a method for each of the classes. @@ -168,3 +294,5 @@ foo ``` S7 unions allow you to restrict the type of a property in the same way that S4 unions allow you to restrict the type of a slot. +S7 unions can also be registered with `S4_register()` for use in S4 slots and +method signatures.