diff --git a/R/base.R b/R/base.R index 973c340b..729775c6 100644 --- a/R/base.R +++ b/R/base.R @@ -158,8 +158,6 @@ class_function <- new_base_class("function", "fun") #' @order 1 class_environment <- new_base_class("environment") -# Base unions are created .onLoad - #' @export #' @rdname base_classes #' @format NULL @@ -177,3 +175,10 @@ class_atomic <- NULL #' @format NULL #' @order 2 class_vector <- NULL + +# Define onload to avoid dependencies between files +on_load_define_union_classes <- function() { + class_numeric <<- new_union(class_integer, class_double) + class_atomic <<- new_union(class_logical, class_numeric, class_complex, class_character, class_raw) + class_vector <<- new_union(class_atomic, class_expression, class_list) +} diff --git a/R/class.R b/R/class.R index dc8c0c45..426387bb 100644 --- a/R/class.R +++ b/R/class.R @@ -290,7 +290,7 @@ str.S7_object <- function(object, ..., nest.lev = 0) { cat(if (nest.lev > 0) " ") cat(obj_desc(object)) - if (typeof(object) != .S7_type) { + if (!is_S7_type(object)) { if (!typeof(object) %in% c("numeric", "integer", "character", "double")) cat(" ") diff --git a/R/convert.R b/R/convert.R index f9db8378..89c5296a 100644 --- a/R/convert.R +++ b/R/convert.R @@ -101,4 +101,12 @@ convert <- function(from, to, ...) { stop(msg, call. = FALSE) } } -# Converted to S7_generic on .onLoad + +# Converted to S7_generic onLoad in order to avoid dependency between files +on_load_make_convert_generic <- function() { + convert <<- S7_generic( + convert, + name = "convert", + dispatch_args = c("from", "to") + ) +} diff --git a/R/union.R b/R/union.R index ff5b98ec..4f5fd58d 100644 --- a/R/union.R +++ b/R/union.R @@ -53,10 +53,19 @@ new_union <- function(...) { `|.S7_class` <- function(e1, e2) { new_union(e1, e2) } - -# Method registration for the remaining classes happens onLoad so that -# their pointers are identical, working around a bug that was fixed in -# R 4.1: https://github.com/wch/r-source/commit/b41344e3d0da7d78fd +# Register remaining methods onLoad so that their pointers are identical, +# working around a bug that was fixed in R 4.1: +# https://github.com/wch/r-source/commit/b41344e3d0da7d78fd +on_load_define_or_methods <- function() { + registerS3method("|", "S7_union", `|.S7_class`) + registerS3method("|", "S7_base_class", `|.S7_class`) + registerS3method("|", "S7_S3_class", `|.S7_class`) + registerS3method("|", "S7_any", `|.S7_class`) + registerS3method("|", "S7_missing", `|.S7_class`) + registerS3method("|", "classGeneratorFunction", `|.S7_class`) + registerS3method("|", "ClassUnionRepresentation", `|.S7_class`) + registerS3method("|", "classRepresentation", `|.S7_class`) +} is_union <- function(x) inherits(x, "S7_union") diff --git a/R/zzz.R b/R/zzz.R index 86ab06f7..8e4b7b34 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -15,13 +15,22 @@ S7_object <- new_class( .Call(S7_object_) }, validator = function(self) { - if (typeof(self) != .S7_type) { + if (!is_S7_type(self)) { "Underlying data is corrupt" } } ) methods::setOldClass("S7_object") +.S7_type <- NULL +# Defined onLoad because it depends on R version +on_load_define_S7_type <- function() { + .S7_type <<- typeof(.Call(S7_object_)) +} +is_S7_type <- function(x) { + typeof(x) == .S7_type +} + #' @export `$.S7_object` <- function(x, name) { if (typeof(x) %in% c("list", "environment")) { @@ -100,6 +109,8 @@ S7_method <- new_class("S7_method", ) methods::setOldClass(c("S7_method", "function", "S7_object")) +# hooks ------------------------------------------------------------------- + .onAttach <- function(libname, pkgname) { env <- as.environment(paste0("package:", pkgname)) if (getRversion() < "4.3.0") { @@ -108,26 +119,10 @@ methods::setOldClass(c("S7_method", "function", "S7_object")) } .onLoad <- function(...) { - on_load_define_ops() + on_load_make_convert_generic() on_load_define_matrixOps() - - ## "S4" or [in R-devel 2023-07-x] "object" - assign(".S7_type", typeof(.Call(S7_object_)), topenv()) - - convert <<- S7_generic(convert, name = "convert", dispatch_args = c("from", "to")) - - class_numeric <<- new_union(class_integer, class_double) - class_atomic <<- new_union(class_logical, class_numeric, class_complex, class_character, class_raw) - class_vector <<- new_union(class_atomic, class_expression, class_list) - - # Dynamic register so that function pointers are the same, avoiding R 4.0 - # and earlier bug related to incompatible S3 methods during Ops dispatch - registerS3method("|", "S7_union", `|.S7_class`) - registerS3method("|", "S7_base_class", `|.S7_class`) - registerS3method("|", "S7_S3_class", `|.S7_class`) - registerS3method("|", "S7_any", `|.S7_class`) - registerS3method("|", "S7_missing", `|.S7_class`) - registerS3method("|", "classGeneratorFunction", `|.S7_class`) - registerS3method("|", "ClassUnionRepresentation", `|.S7_class`) - registerS3method("|", "classRepresentation", `|.S7_class`) + on_load_define_ops() + on_load_define_or_methods() + on_load_define_S7_type() + on_load_define_union_classes() }