Support the S7 class reference of S7 > 0.2.1

NAMESPACE

@@ -84,6 +84,7 @@ S3method(.cstr_construct,S7_S3_class.new_S3_class)
 S3method(.cstr_construct,S7_any.class_any)
 S3method(.cstr_construct,S7_base_class.S7)
 S3method(.cstr_construct,S7_class.new_class)
+S3method(.cstr_construct,S7_class_ref.environment)
 S3method(.cstr_construct,S7_external_generic.new_external_generic)
 S3method(.cstr_construct,S7_generic.new_generic)
 S3method(.cstr_construct,S7_object.S7_object)
@@ -525,6 +526,7 @@ S3method(constructive::.cstr_construct,S7_S3_class)
 S3method(constructive::.cstr_construct,S7_any)
 S3method(constructive::.cstr_construct,S7_base_class)
 S3method(constructive::.cstr_construct,S7_class)
+S3method(constructive::.cstr_construct,S7_class_ref)
 S3method(constructive::.cstr_construct,S7_external_generic)
 S3method(constructive::.cstr_construct,S7_generic)
 S3method(constructive::.cstr_construct,S7_object)
@@ -611,6 +613,7 @@ export(opts_S7_S3_class)
 export(opts_S7_any)
 export(opts_S7_base_class)
 export(opts_S7_class)
+export(opts_S7_class_ref)
 export(opts_S7_external_generic)
 export(opts_S7_generic)
 export(opts_S7_object)

NEWS.md

@@ -36,6 +36,7 @@ New supported classes:
 * `Matrix`: `"sparseMatrix"`, `"denseMatrix"`, `"diagonalMatrix"`,
   `"indMatrix"` and `"sparseVector"`
 * `readr`: `"col_spec"`, `"collector"`, `"locale"` and `"date_names"`
+* `S7`: `"S7_class_ref"`, used by S7 > 0.2.2 to store the class of an object
 * `sf`: `"sf"`, `"sfc"`, `"sfg"`, `"crs"` and `"bbox"`
 * `survival`: `"Surv"`
 * `tsibble`: `"tbl_ts"`, `"grouped_ts"`, `"yearmonth"`, `"yearquarter"` and
@@ -45,6 +46,9 @@ New supported classes:
 
 Fixes and improvements:
 
+* We support S7 > 0.2.2, which stores the class of an object differently.
+  S7 objects built with an S7 version that stores it differently than the
+  installed one are considered corrupted.
 * We don't emit the deprecated `.additional_properties` argument of
   `ellmer::type_object()` anymore. `ellmer` 0.5.0 made it `deprecated()`.
 * Coercion generics and `NA` predicates (`as.character()`, `is.na()`, `[[` and

R/construct-helpers.R

@@ -438,6 +438,7 @@ all_classes <- list(
     "S7_any", 
     "S7_base_class", 
     "S7_class",
+    "S7_class_ref",
     "S7_external_generic",
     "S7_generic", 
     "S7_object", 

R/s3-ggplot2-ggplot2-element_blank.R

@@ -13,7 +13,7 @@ opts_ggplot2_element_blank <- function(constructor = c("element_blank", "next"),
 }
 
 `is_corrupted_ggplot2::element_blank` <- function(x) {
-  typeof(x) != "object"
+  typeof(x) != "object" || has_foreign_s7_attrs(x)
 }
 
 #' @export
@@ -24,7 +24,7 @@ opts_ggplot2_element_blank <- function(constructor = c("element_blank", "next"),
 }
 
 `repair_attributes_ggplot2::element_blank` <- function(x, ...) {
-  property_names <- names(attr(attr(x, "S7_class"),"properties"))
+  property_names <- names(attr(s7_class(x),"properties"))
   .cstr_repair_attributes(
     x,
     idiomatic_class = c(
@@ -34,7 +34,7 @@ opts_ggplot2_element_blank <- function(constructor = c("element_blank", "next"),
       "S7_object",
       "element"
     ),
-    ignore = "S7_class",
+    ignore = s7_internal_attrs(),
     ...
   )
 }

R/s3-ggplot2-ggplot2-element_geom.R

@@ -13,7 +13,7 @@ opts_ggplot2_element_geom <- function(constructor = c("element_geom", "next"), .
 }
 
 `is_corrupted_ggplot2::element_geom` <- function(x) {
-  typeof(x) != "object"
+  typeof(x) != "object" || has_foreign_s7_attrs(x)
 }
 
 #' @export
@@ -57,15 +57,15 @@ opts_ggplot2_element_geom <- function(constructor = c("element_geom", "next"), .
 }
 
 `repair_attributes_ggplot2::element_geom` <- function(x, ...) {
-  property_names <- names(attr(attr(x, "S7_class"),"properties"))
+  property_names <- names(attr(s7_class(x),"properties"))
   .cstr_repair_attributes(
     x,
     idiomatic_class = c(
       "ggplot2::element_geom",
       "ggplot2::element",
       "S7_object"
     ),
-    ignore = c("S7_class", property_names),
+    ignore = c(s7_internal_attrs(), property_names),
     ...
   )
 }

R/s3-ggplot2-ggplot2-element_line.R

@@ -13,7 +13,7 @@ opts_ggplot2_element_line <- function(constructor = c("element_line", "next"), .
 }
 
 `is_corrupted_ggplot2::element_line` <- function(x) {
-  typeof(x) != "object"
+  typeof(x) != "object" || has_foreign_s7_attrs(x)
 }
 
 #' @export
@@ -38,7 +38,7 @@ opts_ggplot2_element_line <- function(constructor = c("element_line", "next"), .
 }
 
 `repair_attributes_ggplot2::element_line` <- function(x, ...) {
-  property_names <- names(attr(attr(x, "S7_class"),"properties"))
+  property_names <- names(attr(s7_class(x),"properties"))
   .cstr_repair_attributes(
     x,
     idiomatic_class = c(
@@ -48,7 +48,7 @@ opts_ggplot2_element_line <- function(constructor = c("element_line", "next"), .
       "S7_object",
       "element"
     ),
-    ignore = c("S7_class", property_names),
+    ignore = c(s7_internal_attrs(), property_names),
     ...
   )
 }

R/s3-ggplot2-ggplot2-element_point.R

@@ -13,7 +13,7 @@ opts_ggplot2_element_point <- function(constructor = c("element_point", "next"),
 }
 
 `is_corrupted_ggplot2::element_point` <- function(x) {
-  typeof(x) != "object"
+  typeof(x) != "object" || has_foreign_s7_attrs(x)
 }
 
 #' @export
@@ -33,15 +33,15 @@ opts_ggplot2_element_point <- function(constructor = c("element_point", "next"),
 }
 
 `repair_attributes_ggplot2::element_point` <- function(x, ...) {
-  property_names <- names(attr(attr(x, "S7_class"),"properties"))
+  property_names <- names(attr(s7_class(x),"properties"))
   .cstr_repair_attributes(
     x,
     idiomatic_class = c(
       "ggplot2::element_point",
       "ggplot2::element",
       "S7_object"
     ),
-    ignore = c("S7_class", property_names),
+    ignore = c(s7_internal_attrs(), property_names),
     ...
   )
 }

R/s3-ggplot2-ggplot2-element_polygon.R

@@ -13,7 +13,7 @@ opts_ggplot2_element_polygon <- function(constructor = c("element_polygon", "nex
 }
 
 `is_corrupted_ggplot2::element_polygon` <- function(x) {
-  typeof(x) != "object"
+  typeof(x) != "object" || has_foreign_s7_attrs(x)
 }
 
 #' @export
@@ -33,15 +33,15 @@ opts_ggplot2_element_polygon <- function(constructor = c("element_polygon", "nex
 }
 
 `repair_attributes_ggplot2::element_polygon` <- function(x, ...) {
-  property_names <- names(attr(attr(x, "S7_class"),"properties"))
+  property_names <- names(attr(s7_class(x),"properties"))
   .cstr_repair_attributes(
     x,
     idiomatic_class = c(
       "ggplot2::element_polygon",
       "ggplot2::element",
       "S7_object"
     ),
-    ignore = c("S7_class", property_names),
+    ignore = c(s7_internal_attrs(), property_names),
     ...
   )
 }

R/s3-ggplot2-ggplot2-element_rect.R

@@ -13,7 +13,7 @@ opts_ggplot2_element_rect <- function(constructor = c("element_rect", "next"), .
 }
 
 `is_corrupted_ggplot2::element_rect` <- function(x) {
-  typeof(x) != "object"
+  typeof(x) != "object" || has_foreign_s7_attrs(x)
 }
 
 #' @export
@@ -33,7 +33,7 @@ opts_ggplot2_element_rect <- function(constructor = c("element_rect", "next"), .
 }
 
 `repair_attributes_ggplot2::element_rect` <- function(x, ...) {
-  property_names <- names(attr(attr(x, "S7_class"),"properties"))
+  property_names <- names(attr(s7_class(x),"properties"))
   .cstr_repair_attributes(
     x,
     idiomatic_class = c(
@@ -43,7 +43,7 @@ opts_ggplot2_element_rect <- function(constructor = c("element_rect", "next"), .
       "S7_object",
       "element"
     ),
-    ignore = c("S7_class", property_names),
+    ignore = c(s7_internal_attrs(), property_names),
     ...
   )
 }

R/s3-ggplot2-ggplot2-element_text.R

@@ -13,7 +13,7 @@ opts_ggplot2_element_text <- function(constructor = c("element_text", "next"), .
 }
 
 `is_corrupted_ggplot2::element_text` <- function(x) {
-  typeof(x) != "object"
+  typeof(x) != "object" || has_foreign_s7_attrs(x)
 }
 
 #' @export
@@ -38,7 +38,7 @@ opts_ggplot2_element_text <- function(constructor = c("element_text", "next"), .
 }
 
 `repair_attributes_ggplot2::element_text` <- function(x, ...) {
-  property_names <- names(attr(attr(x, "S7_class"),"properties"))
+  property_names <- names(attr(s7_class(x),"properties"))
   .cstr_repair_attributes(
     x,
     idiomatic_class = c(
@@ -48,7 +48,7 @@ opts_ggplot2_element_text <- function(constructor = c("element_text", "next"), .
       "S7_object",
       "element"
     ),
-    ignore = c("S7_class", property_names),
+    ignore = c(s7_internal_attrs(), property_names),
     ...
   )
 }

R/s3-ggplot2-ggplot2-ggplot.R

@@ -25,7 +25,7 @@ opts_ggplot2_ggplot <- function(constructor = c("ggplot", "next", "list"), ...)
 }
 
 `is_corrupted_ggplot2::ggplot` <- function(x) {
-  typeof(x) != "object"
+  typeof(x) != "object" || has_foreign_s7_attrs(x)
 }
 
 #' @export
@@ -79,7 +79,7 @@ opts_ggplot2_ggplot <- function(constructor = c("ggplot", "next", "list"), ...)
     x, code_with_parens, pipe = pipe,
     idiomatic_class = c("ggplot2::ggplot", "ggplot", "ggplot2::gg", "S7_object", "gg"),
     ignore = c(
-      "S7_class", "data", "layers", "scales", "guides", "mapping", "theme",
+      s7_internal_attrs(), "data", "layers", "scales", "guides", "mapping", "theme",
       "coordinates", "facet", "layout", "labels", "meta", "plot_env"
     ),
     one_liner = one_liner,

R/s3-ggplot2-ggplot2-labels.R

@@ -23,7 +23,7 @@ opts_ggplot2_labels <- function(constructor = c("labs", "next"), ...) {
 
 `is_corrupted_ggplot2::labels` <- function(x) {
   if (!is.list(x)) return(TRUE)
-  if (!is.function(attr(x, "S7_class"))) return(TRUE)
+  if (!is.function(s7_class(x))) return(TRUE)
   FALSE
 }
 
@@ -34,7 +34,7 @@ opts_ggplot2_labels <- function(constructor = c("labs", "next"), ...) {
   code <- constructive::.cstr_apply(args, fun = "ggplot2::labs", ...)
   constructive::.cstr_repair_attributes(
     x, code, ...,
-    ignore = "S7_class",
+    ignore = s7_internal_attrs(),
     idiomatic_class = c("ggplot2::labels", "gg", "S7_object")
   )
 }

R/s3-ggplot2-ggplot2-mapping.R

@@ -57,15 +57,15 @@ opts_ggplot2_mapping <- function(constructor = c("aes", "next", "list"), ...) {
 
 `is_corrupted_ggplot2::mapping` <- function(x) {
   if (!is.list(x)) return(TRUE)
-  if (!is.function(attr(x, "S7_class"))) return(TRUE)
+  if (!is.function(s7_class(x))) return(TRUE)
   FALSE
 }
 
 `repair_attributes_ggplot2::mapping` <- function(x, code, pipe = NULL, ...) {
   .cstr_repair_attributes(
     x, code, pipe = pipe,
     idiomatic_class = c("ggplot2::mapping", "uneval", "gg", "S7_object"),
-    ignore = "S7_class",
+    ignore = s7_internal_attrs(),
     ...
   )
 }

R/s3-ggplot2-ggplot2-margin.R

@@ -15,7 +15,7 @@ opts_ggplot2_margin <- function(constructor = c("margin", "next", "double"), ...
 `is_corrupted_ggplot2::margin` <- function(x) {
   if (!is.double(x)) return(TRUE)
   if (!is.integer(attr(x, "unit"))) return(TRUE)
-  if (!is.function(attr(x, "S7_class"))) return(TRUE)
+  if (!is.function(s7_class(x))) return(TRUE)
   FALSE
 }
 
@@ -45,7 +45,7 @@ opts_ggplot2_margin <- function(constructor = c("margin", "next", "double"), ...
     x,
     code,
     idiomatic_class = c("ggplot2::margin", "simpleUnit", "unit", "unit_v2", "S7_object"),
-    ignore = c("S7_class", "unit"),
+    ignore = c(s7_internal_attrs(), "unit"),
     ...
   )
 }

R/s3-ggplot2-ggplot2-theme.R

@@ -14,7 +14,7 @@ opts_ggplot2_theme <- function(constructor = c("default", "theme", "next", "list
 
 `is_corrupted_ggplot2::theme` <- function(x) {
   if (!is.list(x)) return(TRUE)
-  if (!is.function(attr(x, "S7_class"))) return(TRUE)
+  if (!is.function(s7_class(x))) return(TRUE)
   if (!is.logical(attr(x, "complete")) || length(attr(x, "complete")) != 1) return(TRUE)
   if (!is.logical(attr(x, "validate")) || length(attr(x, "validate")) != 1) return(TRUE)
   FALSE
@@ -131,7 +131,7 @@ guess_complete_theme <- function(x, ...) {
 }
 
 `repair_attributes_ggplot2::theme` <- function(x, code, ...) {
-  ignore <- c("S7_class", "complete", "validate")
+  ignore <- c(s7_internal_attrs(), "complete", "validate")
   if (identical(names(x), character())) ignore <- c(ignore, "names")
   .cstr_repair_attributes(x, code, idiomatic_class = c("theme", "ggplot2::theme", "gg", "S7_object"), ignore = ignore, ...)
 }

R/s3-ggplot2-theme.R

@@ -15,7 +15,7 @@ opts_theme <- function(constructor = c("default", "theme", "next", "list"), ...)
 is_corrupted_theme <- function(x) {
   # because it's the main class in new ggplot we do this to keep the logic separate
   # for new and old ggplot
-  !is.list(x) || !is.null(attr(x, "S7_class"))
+  !is.list(x) || !is.null(s7_class(x))
 }
 
 #' @export