Make onLoad mechanisms more consistent (#355)

RConsortium · Sep 15, 2023 · 5b59cbc · 5b59cbc
1 parent 72e68a9
commit 5b59cbc
Show file tree

Hide file tree

Showing 5 changed files with 47 additions and 30 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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()
 }