From ba9ad3498649229b5b91c8b6d46e89fad4ef6ac0 Mon Sep 17 00:00:00 2001 From: Claude Developer Date: Mon, 19 Oct 2026 00:50:40 +0200 Subject: [PATCH 1/6] =?UTF-8?q?=F0=9F=A4=96=F0=9F=94=A7=20Support=20the=20?= =?UTF-8?q?S7=20class=20reference=20of=20S7=20>=200.2.1?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The development version of S7 (0.2.2.9000, RConsortium/S7#742) stores an object's class in a "_S7_class" attribute, generally a shared "S7_class_ref" environment, along with "_S7_version", instead of the "S7_class" attribute. Classes gain "S7_class_name", "S7_dispatch" and "S7_version" attributes, and `new_class()` wraps the constructor's environment into a new one holding the reference. Our S7, ggplot2 and ellmer constructors read `attr(x, "S7_class")` and ignored only that attribute, so with dev S7 the output fell back to low-level code, and constructing a generic repaired "_S7_class" with an environment address, which segfaulted under testthat's placeholder address. * `s7_class()` gets the class from either attribute, and `s7_internal_attrs` lists the attributes S7 sets itself, used in the ignore lists that listed "S7_class" * `new_class()` calls get the original constructor environment * `S7_object()` doesn't repair the "_S7_version" it sets Tests whose output legitimately differs (low level "next" constructions, base classes redefined in S7) are split by S7 version, the snapshots for S7 <= 0.2.1 are unchanged. --- R/s3-ggplot2-ggplot2-element_blank.R | 4 +- R/s3-ggplot2-ggplot2-element_geom.R | 4 +- R/s3-ggplot2-ggplot2-element_line.R | 4 +- R/s3-ggplot2-ggplot2-element_point.R | 4 +- R/s3-ggplot2-ggplot2-element_polygon.R | 4 +- R/s3-ggplot2-ggplot2-element_rect.R | 4 +- R/s3-ggplot2-ggplot2-element_text.R | 4 +- R/s3-ggplot2-ggplot2-ggplot.R | 2 +- R/s3-ggplot2-ggplot2-labels.R | 4 +- R/s3-ggplot2-ggplot2-mapping.R | 4 +- R/s3-ggplot2-ggplot2-margin.R | 4 +- R/s3-ggplot2-ggplot2-theme.R | 4 +- R/s3-ggplot2-theme.R | 2 +- R/s7-S7-object.R | 22 ++++-- R/s7-S7_class.R | 18 +++-- R/s7-S7_generic.R | 2 +- R/s7-ellmer_TypeArray.R | 4 +- R/s7-elmer_TypeBasic.R | 4 +- R/s7-elmer_TypeEnum.R | 4 +- R/s7-elmer_TypeJsonSchema.R | 4 +- R/s7-elmer_TypeObject.R | 4 +- tests/testthat/_snaps/s7-S7-object.md | 12 ++++ tests/testthat/_snaps/s7-S7_class.md | 32 +++++++++ tests/testthat/_snaps/s7-S7_generic.md | 30 +++++++- tests/testthat/_snaps/s7-S7_union.md | 95 ++++++++++++++++++++++++++ tests/testthat/test-s7-S7-object.R | 20 +++++- tests/testthat/test-s7-S7_class.R | 29 ++++++++ tests/testthat/test-s7-S7_generic.R | 20 +++++- tests/testthat/test-s7-S7_union.R | 16 +++++ 29 files changed, 318 insertions(+), 46 deletions(-) diff --git a/R/s3-ggplot2-ggplot2-element_blank.R b/R/s3-ggplot2-ggplot2-element_blank.R index 1bf7ef54..3bd68ba4 100644 --- a/R/s3-ggplot2-ggplot2-element_blank.R +++ b/R/s3-ggplot2-ggplot2-element_blank.R @@ -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, ... ) } diff --git a/R/s3-ggplot2-ggplot2-element_geom.R b/R/s3-ggplot2-ggplot2-element_geom.R index d067e011..74d40a15 100644 --- a/R/s3-ggplot2-ggplot2-element_geom.R +++ b/R/s3-ggplot2-ggplot2-element_geom.R @@ -57,7 +57,7 @@ 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( @@ -65,7 +65,7 @@ opts_ggplot2_element_geom <- function(constructor = c("element_geom", "next"), . "ggplot2::element", "S7_object" ), - ignore = c("S7_class", property_names), + ignore = c(s7_internal_attrs, property_names), ... ) } diff --git a/R/s3-ggplot2-ggplot2-element_line.R b/R/s3-ggplot2-ggplot2-element_line.R index 6330368b..6197045e 100644 --- a/R/s3-ggplot2-ggplot2-element_line.R +++ b/R/s3-ggplot2-ggplot2-element_line.R @@ -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), ... ) } diff --git a/R/s3-ggplot2-ggplot2-element_point.R b/R/s3-ggplot2-ggplot2-element_point.R index ca53bc42..a02c2767 100644 --- a/R/s3-ggplot2-ggplot2-element_point.R +++ b/R/s3-ggplot2-ggplot2-element_point.R @@ -33,7 +33,7 @@ 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( @@ -41,7 +41,7 @@ opts_ggplot2_element_point <- function(constructor = c("element_point", "next"), "ggplot2::element", "S7_object" ), - ignore = c("S7_class", property_names), + ignore = c(s7_internal_attrs, property_names), ... ) } diff --git a/R/s3-ggplot2-ggplot2-element_polygon.R b/R/s3-ggplot2-ggplot2-element_polygon.R index d0b8032b..1614a21d 100644 --- a/R/s3-ggplot2-ggplot2-element_polygon.R +++ b/R/s3-ggplot2-ggplot2-element_polygon.R @@ -33,7 +33,7 @@ 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( @@ -41,7 +41,7 @@ opts_ggplot2_element_polygon <- function(constructor = c("element_polygon", "nex "ggplot2::element", "S7_object" ), - ignore = c("S7_class", property_names), + ignore = c(s7_internal_attrs, property_names), ... ) } diff --git a/R/s3-ggplot2-ggplot2-element_rect.R b/R/s3-ggplot2-ggplot2-element_rect.R index a16e7d12..a3d5b05b 100644 --- a/R/s3-ggplot2-ggplot2-element_rect.R +++ b/R/s3-ggplot2-ggplot2-element_rect.R @@ -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), ... ) } diff --git a/R/s3-ggplot2-ggplot2-element_text.R b/R/s3-ggplot2-ggplot2-element_text.R index f5dff7cb..de9c0ede 100644 --- a/R/s3-ggplot2-ggplot2-element_text.R +++ b/R/s3-ggplot2-ggplot2-element_text.R @@ -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), ... ) } diff --git a/R/s3-ggplot2-ggplot2-ggplot.R b/R/s3-ggplot2-ggplot2-ggplot.R index f8d50e3b..84cdf7cf 100644 --- a/R/s3-ggplot2-ggplot2-ggplot.R +++ b/R/s3-ggplot2-ggplot2-ggplot.R @@ -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, diff --git a/R/s3-ggplot2-ggplot2-labels.R b/R/s3-ggplot2-ggplot2-labels.R index d69f2c6f..3c3021f6 100644 --- a/R/s3-ggplot2-ggplot2-labels.R +++ b/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") ) } diff --git a/R/s3-ggplot2-ggplot2-mapping.R b/R/s3-ggplot2-ggplot2-mapping.R index 5b96df93..47ff08c5 100644 --- a/R/s3-ggplot2-ggplot2-mapping.R +++ b/R/s3-ggplot2-ggplot2-mapping.R @@ -57,7 +57,7 @@ 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 } @@ -65,7 +65,7 @@ opts_ggplot2_mapping <- function(constructor = c("aes", "next", "list"), ...) { .cstr_repair_attributes( x, code, pipe = pipe, idiomatic_class = c("ggplot2::mapping", "uneval", "gg", "S7_object"), - ignore = "S7_class", + ignore = s7_internal_attrs, ... ) } diff --git a/R/s3-ggplot2-ggplot2-margin.R b/R/s3-ggplot2-ggplot2-margin.R index 068a2c5e..6a06fea7 100644 --- a/R/s3-ggplot2-ggplot2-margin.R +++ b/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"), ... ) } diff --git a/R/s3-ggplot2-ggplot2-theme.R b/R/s3-ggplot2-ggplot2-theme.R index 6a85efb8..61c3b0c5 100644 --- a/R/s3-ggplot2-ggplot2-theme.R +++ b/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, ...) } diff --git a/R/s3-ggplot2-theme.R b/R/s3-ggplot2-theme.R index 34900faf..6d7cd8e1 100644 --- a/R/s3-ggplot2-theme.R +++ b/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 diff --git a/R/s7-S7-object.R b/R/s7-S7-object.R index 7b119bf9..6107003b 100644 --- a/R/s7-S7-object.R +++ b/R/s7-S7-object.R @@ -48,28 +48,42 @@ is_corrupted_S7_object <- function(x) { #' @export .cstr_construct.S7_object.new_class<- function(x, ...) { - constructor <- attr(attr(x, "S7_class"), "constructor") + constructor <- attr(s7_class(x), "constructor") we_can_use_compact_syntax <- !identical(x, S7::S7_object()) && is_default_s7_class_constructor(constructor) if (!we_can_use_compact_syntax) return(.cstr_construct.S7_object.S7_object(x, ...)) - fun_code <- .cstr_construct(attr(x, "S7_class"), ...) + fun_code <- .cstr_construct(s7_class(x), ...) args <- attributes(x) args$class <- NULL - args$S7_class <- NULL + args[s7_internal_attrs] <- NULL code <- constructive::.cstr_apply(args, fun = fun_code, ...) constructive::.cstr_repair_attributes( x, code, ..., ignore = setdiff(names(attributes(x)), "class"), - idiomatic_class = c(attr(attr(x, "S7_class"), "name"), "S7_object") + idiomatic_class = c(attr(s7_class(x), "name"), "S7_object") ) } #' @export .cstr_construct.S7_object.S7_object <- function(x, ...) { code <- "S7::S7_object()" + # since S7 0.2.2.9000 `S7_object()` sets "_S7_version" + version_set <- identical(attr(x, "_S7_version"), attr(S7::S7_object(), "_S7_version")) constructive::.cstr_repair_attributes( x, code, ..., + ignore = if (version_set) "_S7_version", idiomatic_class = "S7_object" ) } + +# Attributes that S7 sets itself. The class of an object is stored in the +# "S7_class" attribute up to S7 0.2.1, and since S7 0.2.2.9000 in "_S7_class" +# along with "_S7_version", generally through a shared reference to the class +s7_internal_attrs <- c("S7_class", "_S7_class", "_S7_version") + +s7_class <- function(x) { + class <- attr(x, "_S7_class") %||% attr(x, "S7_class") + if (is.environment(class)) class <- get("class", envir = class) + class +} diff --git a/R/s7-S7_class.R b/R/s7-S7_class.R index d89cbb00..f06afb62 100644 --- a/R/s7-S7_class.R +++ b/R/s7-S7_class.R @@ -39,17 +39,27 @@ is_corrupted_S7_class <- function(x) { args$constructor <- NULL } args$properties <- simplify_s7_class_properties(args$properties) + # Since S7 0.2.2.9000 `new_class()` wraps the constructor's environment into + # a new one holding a reference to the class, so we provide the original + # environment and let `new_class()` create the wrapper + wrapped_env <- exists(".S7_class_ref", environment(x), inherits = FALSE) + if (wrapped_env && !is.null(args$constructor)) { + environment(args$constructor) <- parent.env(environment(x)) + } code <- constructive::.cstr_apply(args, fun = "S7::new_class", ...) # repair environment - code <- .cstr_wrap(code, fun = "") - envir_code <- .cstr_apply(list(environment(x)), "(`environment<-`)", ...) - code <- .cstr_pipe(code, envir_code, ...) + if (!wrapped_env) { + code <- .cstr_wrap(code, fun = "") + envir_code <- .cstr_apply(list(environment(x)), "(`environment<-`)", ...) + code <- .cstr_pipe(code, envir_code, ...) + } constructive::.cstr_repair_attributes( x, code, ..., - ignore = attr_names, + # the last 3 are computed by `new_class()` since S7 0.2.2.9000 + ignore = c(attr_names, "S7_class_name", "S7_dispatch", "S7_version"), idiomatic_class = c("S7_class", "S7_object") ) } diff --git a/R/s7-S7_generic.R b/R/s7-S7_generic.R index 3cc9aa00..7fa46a28 100644 --- a/R/s7-S7_generic.R +++ b/R/s7-S7_generic.R @@ -54,7 +54,7 @@ is_corrupted_S7_generic <- function(x) { constructive::.cstr_repair_attributes( x, code, ..., ignore = c( - "name", "dispatch_args", "S7_class", "parent", "properties", + s7_internal_attrs, "name", "dispatch_args", "parent", "properties", "constructor", "methods", "srcref" ), idiomatic_class = c("S7_generic", "function", "S7_object") diff --git a/R/s7-ellmer_TypeArray.R b/R/s7-ellmer_TypeArray.R index cb8a2d59..a474b3ad 100644 --- a/R/s7-ellmer_TypeArray.R +++ b/R/s7-ellmer_TypeArray.R @@ -37,7 +37,7 @@ opts_ellmer_TypeArray <- function(constructor = c("type_array", "TypeArray", "ne constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeArray", "ellmer::Type", "S7_object"), - ignore = c("S7_class", "description", "required", "items") + ignore = c(s7_internal_attrs, "description", "required", "items") ) } @@ -54,6 +54,6 @@ opts_ellmer_TypeArray <- function(constructor = c("type_array", "TypeArray", "ne constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeArray", "ellmer::Type", "S7_object"), - ignore = c("S7_class", "description", "required", "items") + ignore = c(s7_internal_attrs, "description", "required", "items") ) } diff --git a/R/s7-elmer_TypeBasic.R b/R/s7-elmer_TypeBasic.R index dadc4737..3625b067 100644 --- a/R/s7-elmer_TypeBasic.R +++ b/R/s7-elmer_TypeBasic.R @@ -39,7 +39,7 @@ opts_ellmer_TypeBasic <- function(constructor = c("default", "TypeBasic", "next" constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeBasic", "ellmer::Type", "S7_object"), - ignore = c("S7_class", "description", "required", "type") + ignore = c(s7_internal_attrs, "description", "required", "type") ) } @@ -56,6 +56,6 @@ opts_ellmer_TypeBasic <- function(constructor = c("default", "TypeBasic", "next" constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeBasic", "ellmer::Type", "S7_object"), - ignore = c("S7_class", "description", "required", "type") + ignore = c(s7_internal_attrs, "description", "required", "type") ) } diff --git a/R/s7-elmer_TypeEnum.R b/R/s7-elmer_TypeEnum.R index b8dae2dc..5ddade0a 100644 --- a/R/s7-elmer_TypeEnum.R +++ b/R/s7-elmer_TypeEnum.R @@ -38,7 +38,7 @@ opts_ellmer_TypeEnum <- function(constructor = c("type_enum", "TypeEnum", "next" constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeEnum", "ellmer::Type", "S7_object"), - ignore = c("S7_class", "description", "required", "values") + ignore = c(s7_internal_attrs, "description", "required", "values") ) } @@ -55,6 +55,6 @@ opts_ellmer_TypeEnum <- function(constructor = c("type_enum", "TypeEnum", "next" constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeEnum", "ellmer::Type", "S7_object"), - ignore = c("S7_class", "description", "required", "values") + ignore = c(s7_internal_attrs, "description", "required", "values") ) } diff --git a/R/s7-elmer_TypeJsonSchema.R b/R/s7-elmer_TypeJsonSchema.R index 67733f0e..b7b59012 100644 --- a/R/s7-elmer_TypeJsonSchema.R +++ b/R/s7-elmer_TypeJsonSchema.R @@ -33,7 +33,7 @@ opts_ellmer_TypeJsonSchema <- function(constructor = c("type_from_schema", "Type constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeJsonSchema", "ellmer::Type", "S7_object"), - ignore = c("S7_class", "json", "required") + ignore = c(s7_internal_attrs, "json", "required") ) } @@ -50,6 +50,6 @@ opts_ellmer_TypeJsonSchema <- function(constructor = c("type_from_schema", "Type constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeJsonSchema", "ellmer::Type", "S7_object"), - ignore = c("S7_class", "description", "required", "json") + ignore = c(s7_internal_attrs, "description", "required", "json") ) } diff --git a/R/s7-elmer_TypeObject.R b/R/s7-elmer_TypeObject.R index 4a933051..c2f4a12a 100644 --- a/R/s7-elmer_TypeObject.R +++ b/R/s7-elmer_TypeObject.R @@ -46,7 +46,7 @@ opts_ellmer_TypeObject <- function(constructor = c("type_object", "TypeObject", constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeObject", "ellmer::Type", "S7_object"), - ignore = c("S7_class", "description", "required", "additional_properties", "properties") + ignore = c(s7_internal_attrs, "description", "required", "additional_properties", "properties") ) } @@ -64,6 +64,6 @@ opts_ellmer_TypeObject <- function(constructor = c("type_object", "TypeObject", constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeObject", "ellmer::Type", "S7_object"), - ignore = c("S7_class", "description", "required", "additional_properties", "properties") + ignore = c(s7_internal_attrs, "description", "required", "additional_properties", "properties") ) } diff --git a/tests/testthat/_snaps/s7-S7-object.md b/tests/testthat/_snaps/s7-S7-object.md index 01af6425..ebe7c6b9 100644 --- a/tests/testthat/_snaps/s7-S7-object.md +++ b/tests/testthat/_snaps/s7-S7-object.md @@ -4,6 +4,9 @@ construct(S7::S7_object()) Output S7::S7_object() + +# S7_object, S7 <= 0.2.1 + Code construct(S7::S7_object(), opts_S7_object("next")) Output @@ -11,3 +14,12 @@ asS3(complete = FALSE) |> structure(class = "S7_object") +# S7_object, S7 > 0.2.1 + + Code + construct(S7::S7_object(), opts_S7_object("next")) + Output + getClass("S4")@prototype |> + asS3(complete = FALSE) |> + structure(class = "S7_object", `_S7_version` = 1L) + diff --git a/tests/testthat/_snaps/s7-S7_class.md b/tests/testthat/_snaps/s7-S7_class.md index e2998f59..d9ba3776 100644 --- a/tests/testthat/_snaps/s7-S7_class.md +++ b/tests/testthat/_snaps/s7-S7_class.md @@ -4,6 +4,9 @@ construct(S7::S7_object) Output S7::S7_object + +# S7_class, next, S7 <= 0.2.1 + Code construct(S7::S7_object, opts_S7_class("next")) Output @@ -28,3 +31,32 @@ class = c("S7_class", "S7_object") ) +# S7_class, next, S7 > 0.2.1 + + Code + construct(S7::S7_object, opts_S7_class("next"), check = FALSE) + Output + (function() { + .Call(S7_object_) + }) |> + (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) |> + structure( + name = "S7_object", + properties = list(), + abstract = FALSE, + constructor = (function() { + .Call(S7_object_) + }) |> + (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")), + validator = (function(self) { + if (!is_S7_type(self)) { + "Underlying data is corrupt" + } + }) |> + (`environment<-`)(asNamespace("S7")), + S7_class_name = "S7_object", + S7_dispatch = "S7_object", + S7_version = 1L, + class = c("S7_class", "S7_object") + ) + diff --git a/tests/testthat/_snaps/s7-S7_generic.md b/tests/testthat/_snaps/s7-S7_generic.md index 65047717..0e1e2cc0 100644 --- a/tests/testthat/_snaps/s7-S7_generic.md +++ b/tests/testthat/_snaps/s7-S7_generic.md @@ -1,4 +1,4 @@ -# S7_generic +# S7_generic, S7 <= 0.2.1 Code type_of <- S7::new_generic("type_of", dispatch_args = "x") @@ -46,3 +46,31 @@ "A data frame") S7::method(type_of, S7::class_function) <- (function(x, ...) "A function") +# S7_generic, S7 > 0.2.1 + + Code + type_of <- S7::new_generic("type_of", dispatch_args = "x") + construct(type_of) + Output + S7::new_generic("type_of", dispatch_args = "x") + Code + construct(type_of, opts_S7_generic("next"), opts_function(srcref = TRUE), + check = FALSE) + Output + (function(x, ...) S7::S7_dispatch()) |> + structure( + class = c("S7_generic", "function", "S7_object"), + `_S7_version` = 1L, + `_S7_class` = constructive::.env("0x123456789", parents = "empty", class = "S7_class_ref"), + name = "type_of", + methods = constructive::.env("0x123456789", parents = "empty"), + dispatch_args = "x", + srcref = NULL + ) + Code + S7::method(type_of, S7::class_character) <- (function(x, ...) + "A character vector") + S7::method(type_of, S7::new_S3_class("data.frame")) <- (function(x, ...) + "A data frame") + S7::method(type_of, S7::class_function) <- (function(x, ...) "A function") + diff --git a/tests/testthat/_snaps/s7-S7_union.md b/tests/testthat/_snaps/s7-S7_union.md index 051a1f03..2b7278cf 100644 --- a/tests/testthat/_snaps/s7-S7_union.md +++ b/tests/testthat/_snaps/s7-S7_union.md @@ -25,6 +25,9 @@ ) ) |> structure(class = "S7_union") + +# S7_union, S7 <= 0.2.1 + Code construct(S7::class_vector, opts_S7_union("next"), opts_S7_base_class("next"), check = FALSE) @@ -131,3 +134,95 @@ ) |> structure(class = "S7_union") +# S7_union, S7 > 0.2.1 + + Code + construct(S7::class_vector, opts_S7_union("next"), opts_S7_base_class("next"), + check = FALSE) + Output + list( + classes = list( + list( + class = "logical", + constructor_name = "logical", + constructor = as.function(list(.data = logical(0), quote(.data)), envir = asNamespace("S7")), + validator = (function(object) if (base_class(object) != "logical") { + sprintf("Underlying data must be <%s> not <%s>", "logical", base_class(object)) + }) |> + (`environment<-`)(asNamespace("S7")) + ) |> + structure(class = "S7_base_class"), + list( + class = "integer", + constructor_name = "integer", + constructor = as.function(list(.data = integer(0), quote(.data)), envir = asNamespace("S7")), + validator = (function(object) if (base_class(object) != "integer") { + sprintf("Underlying data must be <%s> not <%s>", "integer", base_class(object)) + }) |> + (`environment<-`)(asNamespace("S7")) + ) |> + structure(class = "S7_base_class"), + list( + class = "double", + constructor_name = "double", + constructor = as.function(list(.data = numeric(0), quote(.data)), envir = asNamespace("S7")), + validator = (function(object) if (base_class(object) != "double") { + sprintf("Underlying data must be <%s> not <%s>", "double", base_class(object)) + }) |> + (`environment<-`)(asNamespace("S7")) + ) |> + structure(class = "S7_base_class"), + list( + class = "complex", + constructor_name = "complex", + constructor = as.function(list(.data = complex(0), quote(.data)), envir = asNamespace("S7")), + validator = (function(object) if (base_class(object) != "complex") { + sprintf("Underlying data must be <%s> not <%s>", "complex", base_class(object)) + }) |> + (`environment<-`)(asNamespace("S7")) + ) |> + structure(class = "S7_base_class"), + list( + class = "character", + constructor_name = "character", + constructor = as.function(list(.data = character(0), quote(.data)), envir = asNamespace("S7")), + validator = (function(object) if (base_class(object) != "character") { + sprintf("Underlying data must be <%s> not <%s>", "character", base_class(object)) + }) |> + (`environment<-`)(asNamespace("S7")) + ) |> + structure(class = "S7_base_class"), + list( + class = "raw", + constructor_name = "raw", + constructor = as.function(list(.data = raw(0), quote(.data)), envir = asNamespace("S7")), + validator = (function(object) if (base_class(object) != "raw") { + sprintf("Underlying data must be <%s> not <%s>", "raw", base_class(object)) + }) |> + (`environment<-`)(asNamespace("S7")) + ) |> + structure(class = "S7_base_class"), + list( + class = "expression", + constructor_name = "expression", + constructor = as.function(list(.data = expression(), quote(.data)), envir = asNamespace("S7")), + validator = (function(object) if (base_class(object) != "expression") { + sprintf("Underlying data must be <%s> not <%s>", "expression", base_class(object)) + }) |> + (`environment<-`)(asNamespace("S7")) + ) |> + structure(class = "S7_base_class"), + list( + class = "list", + constructor_name = "list", + constructor = as.function(list(.data = list(), quote(.data)), envir = asNamespace("S7")), + validator = (function(object) if (base_class(object) != "list") { + sprintf("Underlying data must be <%s> not <%s>", "list", base_class(object)) + }) |> + (`environment<-`)(asNamespace("S7")) + ) |> + structure(class = "S7_base_class") + ) + ) |> + structure(class = "S7_union") + diff --git a/tests/testthat/test-s7-S7-object.R b/tests/testthat/test-s7-S7-object.R index c5482e55..7643d452 100644 --- a/tests/testthat/test-s7-S7-object.R +++ b/tests/testthat/test-s7-S7-object.R @@ -3,6 +3,24 @@ test_that("S7_object", { testthat::skip_on_os("linux") expect_snapshot({ construct(S7::S7_object()) - construct(S7::S7_object(), opts_S7_object("next")) }) }) + +test_that("S7_object, S7 <= 0.2.1", { + testthat::skip_on_os("linux") + skip_if_not_installed("S7") + skip_if(with_versions(S7 > "0.2.1")) + expect_snapshot({ + construct(S7::S7_object(), opts_S7_object("next")) + }) +}) + +test_that("S7_object, S7 > 0.2.1", { + # objects have a "_S7_version" attribute + testthat::skip_on_os("linux") + skip_if_not_installed("S7") + skip_if(with_versions(S7 <= "0.2.1")) + expect_snapshot({ + construct(S7::S7_object(), opts_S7_object("next")) + }) +}) diff --git a/tests/testthat/test-s7-S7_class.R b/tests/testthat/test-s7-S7_class.R index 8cba0923..7a161279 100644 --- a/tests/testthat/test-s7-S7_class.R +++ b/tests/testthat/test-s7-S7_class.R @@ -23,6 +23,35 @@ test_that("S7_class", { ) expect_snapshot({ construct(S7::S7_object) + }) +}) + +test_that("S7_class, next, S7 <= 0.2.1", { + # see comments above + testthat::skip_on_os("linux") + skip_if_not_installed("S7") + skip_if(with_versions(S7 > "0.2.1")) + skip_if( + !is.null(attr(S7::S7_object@constructor, "srcref")), + "S7 was installed with source references" + ) + expect_snapshot({ construct(S7::S7_object, opts_S7_class("next")) }) }) + +test_that("S7_class, next, S7 > 0.2.1", { + # see comments above + testthat::skip_on_os("linux") + skip_if_not_installed("S7") + skip_if(with_versions(S7 <= "0.2.1")) + skip_if( + !is.null(attr(S7::S7_object@constructor, "srcref")), + "S7 was installed with source references" + ) + expect_snapshot({ + # the class's environment holds a reference to the class, it is constructed + # from its memory address so we use check = FALSE + construct(S7::S7_object, opts_S7_class("next"), check = FALSE) + }) +}) diff --git a/tests/testthat/test-s7-S7_generic.R b/tests/testthat/test-s7-S7_generic.R index d7306b1c..673afd70 100644 --- a/tests/testthat/test-s7-S7_generic.R +++ b/tests/testthat/test-s7-S7_generic.R @@ -1,4 +1,6 @@ -test_that("S7_generic", { +test_that("S7_generic, S7 <= 0.2.1", { + skip_if_not_installed("S7") + skip_if(with_versions(S7 > "0.2.1")) expect_snapshot({ # examples from `?S7::new_property` type_of <- S7::new_generic("type_of", dispatch_args = "x") @@ -12,3 +14,19 @@ test_that("S7_generic", { S7::method(type_of, S7::class_function) <- function(x, ...) "A function" }) }) + +test_that("S7_generic, S7 > 0.2.1", { + # The class is stored in a reference shared by all generics, so we don't + # change its environment, check = FALSE because of environment addresses + skip_if_not_installed("S7") + skip_if(with_versions(S7 <= "0.2.1")) + expect_snapshot({ + # examples from `?S7::new_property` + type_of <- S7::new_generic("type_of", dispatch_args = "x") + construct(type_of) + construct(type_of, opts_S7_generic("next"), opts_function(srcref = TRUE), check = FALSE) + S7::method(type_of, S7::class_character) <- function(x, ...) "A character vector" + S7::method(type_of, S7::new_S3_class("data.frame")) <- function(x, ...) "A data frame" + S7::method(type_of, S7::class_function) <- function(x, ...) "A function" + }) +}) diff --git a/tests/testthat/test-s7-S7_union.R b/tests/testthat/test-s7-S7_union.R index 649006ad..f131980e 100644 --- a/tests/testthat/test-s7-S7_union.R +++ b/tests/testthat/test-s7-S7_union.R @@ -4,11 +4,27 @@ test_that("S7_union", { construct(S7::class_vector, opts_S7_union("|")) construct(S7::class_vector, opts_S7_union("new_union")) construct(S7::class_vector, opts_S7_union("next")) + }) +}) + +test_that("S7_union, S7 <= 0.2.1", { + skip_if_not_installed("S7") + skip_if(with_versions(S7 > "0.2.1")) + expect_snapshot({ # check = FALSE because of changing environment address issues construct(S7::class_vector, opts_S7_union("next"), opts_S7_base_class("next"), check = FALSE) }) }) +test_that("S7_union, S7 > 0.2.1", { + # the base classes are defined differently + skip_if_not_installed("S7") + skip_if(with_versions(S7 <= "0.2.1")) + expect_snapshot({ + construct(S7::class_vector, opts_S7_union("next"), opts_S7_base_class("next"), check = FALSE) + }) +}) + class_logical <- list( class = "logical", From bdcf5f22655f557d0dbb22db107146e4a5357212 Mon Sep 17 00:00:00 2001 From: moodymudskipper Date: Sun, 18 Oct 2026 22:55:24 +0000 Subject: [PATCH 2/6] chore: Auto-update from GitHub Actions Run: https://github.com/cynkra/constructive/actions/runs/39174006239 --- tests/testthat/_snaps/s7-S7_generic.new.md | 46 +++++++ tests/testthat/_snaps/s7-S7_union.new.md | 136 +++++++++++++++++++++ 2 files changed, 182 insertions(+) create mode 100644 tests/testthat/_snaps/s7-S7_generic.new.md create mode 100644 tests/testthat/_snaps/s7-S7_union.new.md diff --git a/tests/testthat/_snaps/s7-S7_generic.new.md b/tests/testthat/_snaps/s7-S7_generic.new.md new file mode 100644 index 00000000..b2b41fbc --- /dev/null +++ b/tests/testthat/_snaps/s7-S7_generic.new.md @@ -0,0 +1,46 @@ +# S7_generic, S7 > 0.2.1 + + Code + type_of <- S7::new_generic("type_of", dispatch_args = "x") + construct(type_of) + Output + S7::new_generic("type_of", dispatch_args = "x") + Code + construct(type_of, opts_S7_generic("next"), opts_function(srcref = TRUE), + check = FALSE) + Output + (function(x, ...) S7::S7_dispatch()) |> + structure( + class = c("S7_generic", "function", "S7_object"), + S7_class = (S7::new_class( + "S7_generic", + parent = S7::class_function, + properties = list( + name = S7::class_character, + methods = S7::class_environment, + dispatch_args = S7::class_character + ), + constructor = as.function( + list( + .data = quote(function() NULL), + name = character(0), + methods = quote(new.env(parent = emptyenv())), + dispatch_args = character(0), + quote(new_object(fun(.data = .data), name = name, methods = methods, dispatch_args = dispatch_args)) + ), + envir = constructive::.env("0x123456789", parents = c("0x123456789", "namespace:S7")) + ) + )) |> + (`environment<-`)(constructive::.env("0x123456789", parents = c("0x123456789", "namespace:S7"))), + name = "type_of", + methods = constructive::.env("0x123456789", parents = "empty"), + dispatch_args = "x", + srcref = NULL + ) + Code + S7::method(type_of, S7::class_character) <- (function(x, ...) + "A character vector") + S7::method(type_of, S7::new_S3_class("data.frame")) <- (function(x, ...) + "A data frame") + S7::method(type_of, S7::class_function) <- (function(x, ...) "A function") + diff --git a/tests/testthat/_snaps/s7-S7_union.new.md b/tests/testthat/_snaps/s7-S7_union.new.md new file mode 100644 index 00000000..dd9f96f0 --- /dev/null +++ b/tests/testthat/_snaps/s7-S7_union.new.md @@ -0,0 +1,136 @@ +# S7_union + + Code + construct(S7::class_vector) + Output + S7::class_vector + Code + construct(S7::class_vector, opts_S7_union("|")) + Output + S7::class_logical | S7::class_integer | S7::class_double | S7::class_complex | S7::class_character | S7::class_raw | S7::class_expression | S7::class_list + Code + construct(S7::class_vector, opts_S7_union("new_union")) + Output + S7::new_union( + S7::class_logical, S7::class_integer, S7::class_double, S7::class_complex, + S7::class_character, S7::class_raw, S7::class_expression, S7::class_list + ) + Code + construct(S7::class_vector, opts_S7_union("next")) + Output + list( + classes = list( + S7::class_logical, S7::class_integer, S7::class_double, S7::class_complex, + S7::class_character, S7::class_raw, S7::class_expression, S7::class_list + ) + ) |> + structure(class = "S7_union") + +# S7_union, S7 > 0.2.1 + + Code + construct(S7::class_vector, opts_S7_union("next"), opts_S7_base_class("next"), + check = FALSE) + Output + list( + classes = list( + list( + class = "logical", + constructor_name = "logical", + constructor = as.function(list(.data = logical(0), quote(.data)), envir = baseenv()), + validator = (function(object) { + if (base_class(object) != name) { + sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) + } + }) |> + (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) + ) |> + structure(class = "S7_base_class"), + list( + class = "integer", + constructor_name = "integer", + constructor = as.function(list(.data = integer(0), quote(.data)), envir = baseenv()), + validator = (function(object) { + if (base_class(object) != name) { + sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) + } + }) |> + (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) + ) |> + structure(class = "S7_base_class"), + list( + class = "double", + constructor_name = "double", + constructor = as.function(list(.data = numeric(0), quote(.data)), envir = baseenv()), + validator = (function(object) { + if (base_class(object) != name) { + sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) + } + }) |> + (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) + ) |> + structure(class = "S7_base_class"), + list( + class = "complex", + constructor_name = "complex", + constructor = as.function(list(.data = complex(0), quote(.data)), envir = baseenv()), + validator = (function(object) { + if (base_class(object) != name) { + sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) + } + }) |> + (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) + ) |> + structure(class = "S7_base_class"), + list( + class = "character", + constructor_name = "character", + constructor = as.function(list(.data = character(0), quote(.data)), envir = baseenv()), + validator = (function(object) { + if (base_class(object) != name) { + sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) + } + }) |> + (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) + ) |> + structure(class = "S7_base_class"), + list( + class = "raw", + constructor_name = "raw", + constructor = as.function(list(.data = raw(0), quote(.data)), envir = baseenv()), + validator = (function(object) { + if (base_class(object) != name) { + sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) + } + }) |> + (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) + ) |> + structure(class = "S7_base_class"), + list( + class = "expression", + constructor_name = "expression", + constructor = as.function(list(.data = expression(), quote(.data)), envir = baseenv()), + validator = (function(object) { + if (base_class(object) != name) { + sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) + } + }) |> + (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) + ) |> + structure(class = "S7_base_class"), + list( + class = "list", + constructor_name = "list", + constructor = as.function(list(.data = list(), quote(.data)), envir = baseenv()), + validator = (function(object) { + if (base_class(object) != name) { + sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) + } + }) |> + (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) + ) |> + structure(class = "S7_base_class") + ) + ) |> + structure(class = "S7_union") + From cc966666fc3faf4c6f8a5e3fd87a04dce4167b1f Mon Sep 17 00:00:00 2001 From: Claude Developer Date: Mon, 19 Oct 2026 01:08:31 +0200 Subject: [PATCH 3/6] =?UTF-8?q?=F0=9F=A4=96=F0=9F=94=A7=20Use=20with=5Fver?= =?UTF-8?q?sions()=20for=20S7=5Fobject's=20version=20attribute?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Instead of calling S7::S7_object() during construction to find out which "_S7_version" it sets, we check the S7 version and compare to the value set since S7 0.2.2.9000 (1L). --- R/s7-S7-object.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/s7-S7-object.R b/R/s7-S7-object.R index 6107003b..bf17b90b 100644 --- a/R/s7-S7-object.R +++ b/R/s7-S7-object.R @@ -67,8 +67,9 @@ is_corrupted_S7_object <- function(x) { #' @export .cstr_construct.S7_object.S7_object <- function(x, ...) { code <- "S7::S7_object()" - # since S7 0.2.2.9000 `S7_object()` sets "_S7_version" - version_set <- identical(attr(x, "_S7_version"), attr(S7::S7_object(), "_S7_version")) + # since S7 0.2.2.9000 `S7_object()` sets `_S7_version = 1L` + version_set <- + with_versions(S7 > "0.2.1") && identical(attr(x, "_S7_version"), 1L) constructive::.cstr_repair_attributes( x, code, ..., ignore = if (version_set) "_S7_version", From 321f7dda0cf00925809766235950616bbce4b13e Mon Sep 17 00:00:00 2001 From: Claude Developer Date: Mon, 19 Oct 2026 01:14:34 +0200 Subject: [PATCH 4/6] =?UTF-8?q?=F0=9F=A4=96=F0=9F=94=A7=20Split=20S7=20tes?= =?UTF-8?q?ts=20at=200.2.2,=20the=20current=20CRAN=20version?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The class reference ("_S7_class", "_S7_version") is only in the development version of S7 (0.2.2.9000). S7 0.2.2 is on CRAN and still uses the "S7_class" attribute, but the tests and the version check of the S7_object constructor used 0.2.1 as threshold, so CI (S7 0.2.2) ran the blocks meant for the development version. Also removes the snapshots CI committed from these runs. --- R/s7-S7-object.R | 4 +- tests/testthat/_snaps/s7-S7-object.md | 4 +- tests/testthat/_snaps/s7-S7_class.md | 4 +- tests/testthat/_snaps/s7-S7_generic.md | 4 +- tests/testthat/_snaps/s7-S7_generic.new.md | 46 ------- tests/testthat/_snaps/s7-S7_union.md | 4 +- tests/testthat/_snaps/s7-S7_union.new.md | 136 --------------------- tests/testthat/test-s7-S7-object.R | 8 +- tests/testthat/test-s7-S7_class.R | 8 +- tests/testthat/test-s7-S7_generic.R | 8 +- tests/testthat/test-s7-S7_union.R | 8 +- 11 files changed, 26 insertions(+), 208 deletions(-) delete mode 100644 tests/testthat/_snaps/s7-S7_generic.new.md delete mode 100644 tests/testthat/_snaps/s7-S7_union.new.md diff --git a/R/s7-S7-object.R b/R/s7-S7-object.R index bf17b90b..fe5e2a8e 100644 --- a/R/s7-S7-object.R +++ b/R/s7-S7-object.R @@ -69,7 +69,7 @@ is_corrupted_S7_object <- function(x) { code <- "S7::S7_object()" # since S7 0.2.2.9000 `S7_object()` sets `_S7_version = 1L` version_set <- - with_versions(S7 > "0.2.1") && identical(attr(x, "_S7_version"), 1L) + with_versions(S7 > "0.2.2") && identical(attr(x, "_S7_version"), 1L) constructive::.cstr_repair_attributes( x, code, ..., ignore = if (version_set) "_S7_version", @@ -79,7 +79,7 @@ is_corrupted_S7_object <- function(x) { # Attributes that S7 sets itself. The class of an object is stored in the -# "S7_class" attribute up to S7 0.2.1, and since S7 0.2.2.9000 in "_S7_class" +# "S7_class" attribute up to S7 0.2.2, and since S7 0.2.2.9000 in "_S7_class" # along with "_S7_version", generally through a shared reference to the class s7_internal_attrs <- c("S7_class", "_S7_class", "_S7_version") diff --git a/tests/testthat/_snaps/s7-S7-object.md b/tests/testthat/_snaps/s7-S7-object.md index ebe7c6b9..e8e4c6b7 100644 --- a/tests/testthat/_snaps/s7-S7-object.md +++ b/tests/testthat/_snaps/s7-S7-object.md @@ -5,7 +5,7 @@ Output S7::S7_object() -# S7_object, S7 <= 0.2.1 +# S7_object, S7 <= 0.2.2 Code construct(S7::S7_object(), opts_S7_object("next")) @@ -14,7 +14,7 @@ asS3(complete = FALSE) |> structure(class = "S7_object") -# S7_object, S7 > 0.2.1 +# S7_object, S7 > 0.2.2 Code construct(S7::S7_object(), opts_S7_object("next")) diff --git a/tests/testthat/_snaps/s7-S7_class.md b/tests/testthat/_snaps/s7-S7_class.md index d9ba3776..da825b1a 100644 --- a/tests/testthat/_snaps/s7-S7_class.md +++ b/tests/testthat/_snaps/s7-S7_class.md @@ -5,7 +5,7 @@ Output S7::S7_object -# S7_class, next, S7 <= 0.2.1 +# S7_class, next, S7 <= 0.2.2 Code construct(S7::S7_object, opts_S7_class("next")) @@ -31,7 +31,7 @@ class = c("S7_class", "S7_object") ) -# S7_class, next, S7 > 0.2.1 +# S7_class, next, S7 > 0.2.2 Code construct(S7::S7_object, opts_S7_class("next"), check = FALSE) diff --git a/tests/testthat/_snaps/s7-S7_generic.md b/tests/testthat/_snaps/s7-S7_generic.md index 0e1e2cc0..ced2c3bd 100644 --- a/tests/testthat/_snaps/s7-S7_generic.md +++ b/tests/testthat/_snaps/s7-S7_generic.md @@ -1,4 +1,4 @@ -# S7_generic, S7 <= 0.2.1 +# S7_generic, S7 <= 0.2.2 Code type_of <- S7::new_generic("type_of", dispatch_args = "x") @@ -46,7 +46,7 @@ "A data frame") S7::method(type_of, S7::class_function) <- (function(x, ...) "A function") -# S7_generic, S7 > 0.2.1 +# S7_generic, S7 > 0.2.2 Code type_of <- S7::new_generic("type_of", dispatch_args = "x") diff --git a/tests/testthat/_snaps/s7-S7_generic.new.md b/tests/testthat/_snaps/s7-S7_generic.new.md deleted file mode 100644 index b2b41fbc..00000000 --- a/tests/testthat/_snaps/s7-S7_generic.new.md +++ /dev/null @@ -1,46 +0,0 @@ -# S7_generic, S7 > 0.2.1 - - Code - type_of <- S7::new_generic("type_of", dispatch_args = "x") - construct(type_of) - Output - S7::new_generic("type_of", dispatch_args = "x") - Code - construct(type_of, opts_S7_generic("next"), opts_function(srcref = TRUE), - check = FALSE) - Output - (function(x, ...) S7::S7_dispatch()) |> - structure( - class = c("S7_generic", "function", "S7_object"), - S7_class = (S7::new_class( - "S7_generic", - parent = S7::class_function, - properties = list( - name = S7::class_character, - methods = S7::class_environment, - dispatch_args = S7::class_character - ), - constructor = as.function( - list( - .data = quote(function() NULL), - name = character(0), - methods = quote(new.env(parent = emptyenv())), - dispatch_args = character(0), - quote(new_object(fun(.data = .data), name = name, methods = methods, dispatch_args = dispatch_args)) - ), - envir = constructive::.env("0x123456789", parents = c("0x123456789", "namespace:S7")) - ) - )) |> - (`environment<-`)(constructive::.env("0x123456789", parents = c("0x123456789", "namespace:S7"))), - name = "type_of", - methods = constructive::.env("0x123456789", parents = "empty"), - dispatch_args = "x", - srcref = NULL - ) - Code - S7::method(type_of, S7::class_character) <- (function(x, ...) - "A character vector") - S7::method(type_of, S7::new_S3_class("data.frame")) <- (function(x, ...) - "A data frame") - S7::method(type_of, S7::class_function) <- (function(x, ...) "A function") - diff --git a/tests/testthat/_snaps/s7-S7_union.md b/tests/testthat/_snaps/s7-S7_union.md index 2b7278cf..e7d5f3a8 100644 --- a/tests/testthat/_snaps/s7-S7_union.md +++ b/tests/testthat/_snaps/s7-S7_union.md @@ -26,7 +26,7 @@ ) |> structure(class = "S7_union") -# S7_union, S7 <= 0.2.1 +# S7_union, S7 <= 0.2.2 Code construct(S7::class_vector, opts_S7_union("next"), opts_S7_base_class("next"), @@ -134,7 +134,7 @@ ) |> structure(class = "S7_union") -# S7_union, S7 > 0.2.1 +# S7_union, S7 > 0.2.2 Code construct(S7::class_vector, opts_S7_union("next"), opts_S7_base_class("next"), diff --git a/tests/testthat/_snaps/s7-S7_union.new.md b/tests/testthat/_snaps/s7-S7_union.new.md deleted file mode 100644 index dd9f96f0..00000000 --- a/tests/testthat/_snaps/s7-S7_union.new.md +++ /dev/null @@ -1,136 +0,0 @@ -# S7_union - - Code - construct(S7::class_vector) - Output - S7::class_vector - Code - construct(S7::class_vector, opts_S7_union("|")) - Output - S7::class_logical | S7::class_integer | S7::class_double | S7::class_complex | S7::class_character | S7::class_raw | S7::class_expression | S7::class_list - Code - construct(S7::class_vector, opts_S7_union("new_union")) - Output - S7::new_union( - S7::class_logical, S7::class_integer, S7::class_double, S7::class_complex, - S7::class_character, S7::class_raw, S7::class_expression, S7::class_list - ) - Code - construct(S7::class_vector, opts_S7_union("next")) - Output - list( - classes = list( - S7::class_logical, S7::class_integer, S7::class_double, S7::class_complex, - S7::class_character, S7::class_raw, S7::class_expression, S7::class_list - ) - ) |> - structure(class = "S7_union") - -# S7_union, S7 > 0.2.1 - - Code - construct(S7::class_vector, opts_S7_union("next"), opts_S7_base_class("next"), - check = FALSE) - Output - list( - classes = list( - list( - class = "logical", - constructor_name = "logical", - constructor = as.function(list(.data = logical(0), quote(.data)), envir = baseenv()), - validator = (function(object) { - if (base_class(object) != name) { - sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) - } - }) |> - (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) - ) |> - structure(class = "S7_base_class"), - list( - class = "integer", - constructor_name = "integer", - constructor = as.function(list(.data = integer(0), quote(.data)), envir = baseenv()), - validator = (function(object) { - if (base_class(object) != name) { - sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) - } - }) |> - (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) - ) |> - structure(class = "S7_base_class"), - list( - class = "double", - constructor_name = "double", - constructor = as.function(list(.data = numeric(0), quote(.data)), envir = baseenv()), - validator = (function(object) { - if (base_class(object) != name) { - sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) - } - }) |> - (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) - ) |> - structure(class = "S7_base_class"), - list( - class = "complex", - constructor_name = "complex", - constructor = as.function(list(.data = complex(0), quote(.data)), envir = baseenv()), - validator = (function(object) { - if (base_class(object) != name) { - sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) - } - }) |> - (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) - ) |> - structure(class = "S7_base_class"), - list( - class = "character", - constructor_name = "character", - constructor = as.function(list(.data = character(0), quote(.data)), envir = baseenv()), - validator = (function(object) { - if (base_class(object) != name) { - sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) - } - }) |> - (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) - ) |> - structure(class = "S7_base_class"), - list( - class = "raw", - constructor_name = "raw", - constructor = as.function(list(.data = raw(0), quote(.data)), envir = baseenv()), - validator = (function(object) { - if (base_class(object) != name) { - sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) - } - }) |> - (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) - ) |> - structure(class = "S7_base_class"), - list( - class = "expression", - constructor_name = "expression", - constructor = as.function(list(.data = expression(), quote(.data)), envir = baseenv()), - validator = (function(object) { - if (base_class(object) != name) { - sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) - } - }) |> - (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) - ) |> - structure(class = "S7_base_class"), - list( - class = "list", - constructor_name = "list", - constructor = as.function(list(.data = list(), quote(.data)), envir = baseenv()), - validator = (function(object) { - if (base_class(object) != name) { - sprintf("Underlying data must be <%s> not <%s>", name, base_class(object)) - } - }) |> - (`environment<-`)(constructive::.env("0x123456789", parents = "namespace:S7")) - ) |> - structure(class = "S7_base_class") - ) - ) |> - structure(class = "S7_union") - diff --git a/tests/testthat/test-s7-S7-object.R b/tests/testthat/test-s7-S7-object.R index 7643d452..82462708 100644 --- a/tests/testthat/test-s7-S7-object.R +++ b/tests/testthat/test-s7-S7-object.R @@ -6,20 +6,20 @@ test_that("S7_object", { }) }) -test_that("S7_object, S7 <= 0.2.1", { +test_that("S7_object, S7 <= 0.2.2", { testthat::skip_on_os("linux") skip_if_not_installed("S7") - skip_if(with_versions(S7 > "0.2.1")) + skip_if(with_versions(S7 > "0.2.2")) expect_snapshot({ construct(S7::S7_object(), opts_S7_object("next")) }) }) -test_that("S7_object, S7 > 0.2.1", { +test_that("S7_object, S7 > 0.2.2", { # objects have a "_S7_version" attribute testthat::skip_on_os("linux") skip_if_not_installed("S7") - skip_if(with_versions(S7 <= "0.2.1")) + skip_if(with_versions(S7 <= "0.2.2")) expect_snapshot({ construct(S7::S7_object(), opts_S7_object("next")) }) diff --git a/tests/testthat/test-s7-S7_class.R b/tests/testthat/test-s7-S7_class.R index 7a161279..702a0a0d 100644 --- a/tests/testthat/test-s7-S7_class.R +++ b/tests/testthat/test-s7-S7_class.R @@ -26,11 +26,11 @@ test_that("S7_class", { }) }) -test_that("S7_class, next, S7 <= 0.2.1", { +test_that("S7_class, next, S7 <= 0.2.2", { # see comments above testthat::skip_on_os("linux") skip_if_not_installed("S7") - skip_if(with_versions(S7 > "0.2.1")) + skip_if(with_versions(S7 > "0.2.2")) skip_if( !is.null(attr(S7::S7_object@constructor, "srcref")), "S7 was installed with source references" @@ -40,11 +40,11 @@ test_that("S7_class, next, S7 <= 0.2.1", { }) }) -test_that("S7_class, next, S7 > 0.2.1", { +test_that("S7_class, next, S7 > 0.2.2", { # see comments above testthat::skip_on_os("linux") skip_if_not_installed("S7") - skip_if(with_versions(S7 <= "0.2.1")) + skip_if(with_versions(S7 <= "0.2.2")) skip_if( !is.null(attr(S7::S7_object@constructor, "srcref")), "S7 was installed with source references" diff --git a/tests/testthat/test-s7-S7_generic.R b/tests/testthat/test-s7-S7_generic.R index 673afd70..c6c7a821 100644 --- a/tests/testthat/test-s7-S7_generic.R +++ b/tests/testthat/test-s7-S7_generic.R @@ -1,6 +1,6 @@ -test_that("S7_generic, S7 <= 0.2.1", { +test_that("S7_generic, S7 <= 0.2.2", { skip_if_not_installed("S7") - skip_if(with_versions(S7 > "0.2.1")) + skip_if(with_versions(S7 > "0.2.2")) expect_snapshot({ # examples from `?S7::new_property` type_of <- S7::new_generic("type_of", dispatch_args = "x") @@ -15,11 +15,11 @@ test_that("S7_generic, S7 <= 0.2.1", { }) }) -test_that("S7_generic, S7 > 0.2.1", { +test_that("S7_generic, S7 > 0.2.2", { # The class is stored in a reference shared by all generics, so we don't # change its environment, check = FALSE because of environment addresses skip_if_not_installed("S7") - skip_if(with_versions(S7 <= "0.2.1")) + skip_if(with_versions(S7 <= "0.2.2")) expect_snapshot({ # examples from `?S7::new_property` type_of <- S7::new_generic("type_of", dispatch_args = "x") diff --git a/tests/testthat/test-s7-S7_union.R b/tests/testthat/test-s7-S7_union.R index f131980e..1103dc34 100644 --- a/tests/testthat/test-s7-S7_union.R +++ b/tests/testthat/test-s7-S7_union.R @@ -7,19 +7,19 @@ test_that("S7_union", { }) }) -test_that("S7_union, S7 <= 0.2.1", { +test_that("S7_union, S7 <= 0.2.2", { skip_if_not_installed("S7") - skip_if(with_versions(S7 > "0.2.1")) + skip_if(with_versions(S7 > "0.2.2")) expect_snapshot({ # check = FALSE because of changing environment address issues construct(S7::class_vector, opts_S7_union("next"), opts_S7_base_class("next"), check = FALSE) }) }) -test_that("S7_union, S7 > 0.2.1", { +test_that("S7_union, S7 > 0.2.2", { # the base classes are defined differently skip_if_not_installed("S7") - skip_if(with_versions(S7 <= "0.2.1")) + skip_if(with_versions(S7 <= "0.2.2")) expect_snapshot({ construct(S7::class_vector, opts_S7_union("next"), opts_S7_base_class("next"), check = FALSE) }) From e9db18372ec1900fb0d0345e67bca8728a82f4f9 Mon Sep 17 00:00:00 2001 From: Claude Developer Date: Mon, 19 Oct 2026 01:18:10 +0200 Subject: [PATCH 5/6] =?UTF-8?q?=F0=9F=A4=96=F0=9F=94=A7=20Ignore=20only=20?= =?UTF-8?q?the=20S7=20attributes=20the=20installed=20S7=20sets?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The repair functions ignored "S7_class", "_S7_class" and "_S7_version" whatever the S7 version, but each version's constructors only set one set, so an object carrying the other version's attributes would have lost them. s7_internal_attrs() now depends on with_versions(S7 > "0.2.2"), and so do the class attributes ignored by the "new_class" constructor. The arguments of S7 object constructors still drop all three. --- R/s3-ggplot2-ggplot2-element_blank.R | 2 +- R/s3-ggplot2-ggplot2-element_geom.R | 2 +- R/s3-ggplot2-ggplot2-element_line.R | 2 +- R/s3-ggplot2-ggplot2-element_point.R | 2 +- R/s3-ggplot2-ggplot2-element_polygon.R | 2 +- R/s3-ggplot2-ggplot2-element_rect.R | 2 +- R/s3-ggplot2-ggplot2-element_text.R | 2 +- R/s3-ggplot2-ggplot2-ggplot.R | 2 +- R/s3-ggplot2-ggplot2-labels.R | 2 +- R/s3-ggplot2-ggplot2-mapping.R | 2 +- R/s3-ggplot2-ggplot2-margin.R | 2 +- R/s3-ggplot2-ggplot2-theme.R | 2 +- R/s7-S7-object.R | 15 +++++++++------ R/s7-S7_class.R | 7 +++++-- R/s7-S7_generic.R | 2 +- R/s7-ellmer_TypeArray.R | 4 ++-- R/s7-elmer_TypeBasic.R | 4 ++-- R/s7-elmer_TypeEnum.R | 4 ++-- R/s7-elmer_TypeJsonSchema.R | 4 ++-- R/s7-elmer_TypeObject.R | 4 ++-- 20 files changed, 37 insertions(+), 31 deletions(-) diff --git a/R/s3-ggplot2-ggplot2-element_blank.R b/R/s3-ggplot2-ggplot2-element_blank.R index 3bd68ba4..8b09a25c 100644 --- a/R/s3-ggplot2-ggplot2-element_blank.R +++ b/R/s3-ggplot2-ggplot2-element_blank.R @@ -34,7 +34,7 @@ opts_ggplot2_element_blank <- function(constructor = c("element_blank", "next"), "S7_object", "element" ), - ignore = s7_internal_attrs, + ignore = s7_internal_attrs(), ... ) } diff --git a/R/s3-ggplot2-ggplot2-element_geom.R b/R/s3-ggplot2-ggplot2-element_geom.R index 74d40a15..2be6321c 100644 --- a/R/s3-ggplot2-ggplot2-element_geom.R +++ b/R/s3-ggplot2-ggplot2-element_geom.R @@ -65,7 +65,7 @@ opts_ggplot2_element_geom <- function(constructor = c("element_geom", "next"), . "ggplot2::element", "S7_object" ), - ignore = c(s7_internal_attrs, property_names), + ignore = c(s7_internal_attrs(), property_names), ... ) } diff --git a/R/s3-ggplot2-ggplot2-element_line.R b/R/s3-ggplot2-ggplot2-element_line.R index 6197045e..732351c6 100644 --- a/R/s3-ggplot2-ggplot2-element_line.R +++ b/R/s3-ggplot2-ggplot2-element_line.R @@ -48,7 +48,7 @@ opts_ggplot2_element_line <- function(constructor = c("element_line", "next"), . "S7_object", "element" ), - ignore = c(s7_internal_attrs, property_names), + ignore = c(s7_internal_attrs(), property_names), ... ) } diff --git a/R/s3-ggplot2-ggplot2-element_point.R b/R/s3-ggplot2-ggplot2-element_point.R index a02c2767..014291f2 100644 --- a/R/s3-ggplot2-ggplot2-element_point.R +++ b/R/s3-ggplot2-ggplot2-element_point.R @@ -41,7 +41,7 @@ opts_ggplot2_element_point <- function(constructor = c("element_point", "next"), "ggplot2::element", "S7_object" ), - ignore = c(s7_internal_attrs, property_names), + ignore = c(s7_internal_attrs(), property_names), ... ) } diff --git a/R/s3-ggplot2-ggplot2-element_polygon.R b/R/s3-ggplot2-ggplot2-element_polygon.R index 1614a21d..21660e23 100644 --- a/R/s3-ggplot2-ggplot2-element_polygon.R +++ b/R/s3-ggplot2-ggplot2-element_polygon.R @@ -41,7 +41,7 @@ opts_ggplot2_element_polygon <- function(constructor = c("element_polygon", "nex "ggplot2::element", "S7_object" ), - ignore = c(s7_internal_attrs, property_names), + ignore = c(s7_internal_attrs(), property_names), ... ) } diff --git a/R/s3-ggplot2-ggplot2-element_rect.R b/R/s3-ggplot2-ggplot2-element_rect.R index a3d5b05b..9a51f370 100644 --- a/R/s3-ggplot2-ggplot2-element_rect.R +++ b/R/s3-ggplot2-ggplot2-element_rect.R @@ -43,7 +43,7 @@ opts_ggplot2_element_rect <- function(constructor = c("element_rect", "next"), . "S7_object", "element" ), - ignore = c(s7_internal_attrs, property_names), + ignore = c(s7_internal_attrs(), property_names), ... ) } diff --git a/R/s3-ggplot2-ggplot2-element_text.R b/R/s3-ggplot2-ggplot2-element_text.R index de9c0ede..254a7959 100644 --- a/R/s3-ggplot2-ggplot2-element_text.R +++ b/R/s3-ggplot2-ggplot2-element_text.R @@ -48,7 +48,7 @@ opts_ggplot2_element_text <- function(constructor = c("element_text", "next"), . "S7_object", "element" ), - ignore = c(s7_internal_attrs, property_names), + ignore = c(s7_internal_attrs(), property_names), ... ) } diff --git a/R/s3-ggplot2-ggplot2-ggplot.R b/R/s3-ggplot2-ggplot2-ggplot.R index 84cdf7cf..7b82ec56 100644 --- a/R/s3-ggplot2-ggplot2-ggplot.R +++ b/R/s3-ggplot2-ggplot2-ggplot.R @@ -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_internal_attrs, "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, diff --git a/R/s3-ggplot2-ggplot2-labels.R b/R/s3-ggplot2-ggplot2-labels.R index 3c3021f6..cc86dc35 100644 --- a/R/s3-ggplot2-ggplot2-labels.R +++ b/R/s3-ggplot2-ggplot2-labels.R @@ -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_internal_attrs, + ignore = s7_internal_attrs(), idiomatic_class = c("ggplot2::labels", "gg", "S7_object") ) } diff --git a/R/s3-ggplot2-ggplot2-mapping.R b/R/s3-ggplot2-ggplot2-mapping.R index 47ff08c5..e7b0ff54 100644 --- a/R/s3-ggplot2-ggplot2-mapping.R +++ b/R/s3-ggplot2-ggplot2-mapping.R @@ -65,7 +65,7 @@ opts_ggplot2_mapping <- function(constructor = c("aes", "next", "list"), ...) { .cstr_repair_attributes( x, code, pipe = pipe, idiomatic_class = c("ggplot2::mapping", "uneval", "gg", "S7_object"), - ignore = s7_internal_attrs, + ignore = s7_internal_attrs(), ... ) } diff --git a/R/s3-ggplot2-ggplot2-margin.R b/R/s3-ggplot2-ggplot2-margin.R index 6a06fea7..e75bd4c2 100644 --- a/R/s3-ggplot2-ggplot2-margin.R +++ b/R/s3-ggplot2-ggplot2-margin.R @@ -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_internal_attrs, "unit"), + ignore = c(s7_internal_attrs(), "unit"), ... ) } diff --git a/R/s3-ggplot2-ggplot2-theme.R b/R/s3-ggplot2-ggplot2-theme.R index 61c3b0c5..253ef3dd 100644 --- a/R/s3-ggplot2-ggplot2-theme.R +++ b/R/s3-ggplot2-ggplot2-theme.R @@ -131,7 +131,7 @@ guess_complete_theme <- function(x, ...) { } `repair_attributes_ggplot2::theme` <- function(x, code, ...) { - ignore <- c(s7_internal_attrs, "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, ...) } diff --git a/R/s7-S7-object.R b/R/s7-S7-object.R index fe5e2a8e..09e5d5f1 100644 --- a/R/s7-S7-object.R +++ b/R/s7-S7-object.R @@ -55,7 +55,8 @@ is_corrupted_S7_object <- function(x) { fun_code <- .cstr_construct(s7_class(x), ...) args <- attributes(x) args$class <- NULL - args[s7_internal_attrs] <- NULL + # the S7 attributes of any S7 version, they're not properties + args[c("S7_class", "_S7_class", "_S7_version")] <- NULL code <- constructive::.cstr_apply(args, fun = fun_code, ...) constructive::.cstr_repair_attributes( x, code, ..., @@ -77,11 +78,13 @@ is_corrupted_S7_object <- function(x) { ) } - -# Attributes that S7 sets itself. The class of an object is stored in the -# "S7_class" attribute up to S7 0.2.2, and since S7 0.2.2.9000 in "_S7_class" -# along with "_S7_version", generally through a shared reference to the class -s7_internal_attrs <- c("S7_class", "_S7_class", "_S7_version") +# Attributes that the installed S7 sets itself. The class of an object is stored +# in the "S7_class" attribute up to S7 0.2.2, and since S7 0.2.2.9000 in +# "_S7_class" along with "_S7_version", generally through a shared reference to +# the class +s7_internal_attrs <- function() { + if (with_versions(S7 > "0.2.2")) c("_S7_class", "_S7_version") else "S7_class" +} s7_class <- function(x) { class <- attr(x, "_S7_class") %||% attr(x, "S7_class") diff --git a/R/s7-S7_class.R b/R/s7-S7_class.R index f06afb62..7dae47f6 100644 --- a/R/s7-S7_class.R +++ b/R/s7-S7_class.R @@ -58,8 +58,11 @@ is_corrupted_S7_class <- function(x) { constructive::.cstr_repair_attributes( x, code, ..., - # the last 3 are computed by `new_class()` since S7 0.2.2.9000 - ignore = c(attr_names, "S7_class_name", "S7_dispatch", "S7_version"), + # `new_class()` also computes these since S7 0.2.2.9000 + ignore = c( + attr_names, + if (with_versions(S7 > "0.2.2")) c("S7_class_name", "S7_dispatch", "S7_version") + ), idiomatic_class = c("S7_class", "S7_object") ) } diff --git a/R/s7-S7_generic.R b/R/s7-S7_generic.R index 7fa46a28..da23857b 100644 --- a/R/s7-S7_generic.R +++ b/R/s7-S7_generic.R @@ -54,7 +54,7 @@ is_corrupted_S7_generic <- function(x) { constructive::.cstr_repair_attributes( x, code, ..., ignore = c( - s7_internal_attrs, "name", "dispatch_args", "parent", "properties", + s7_internal_attrs(), "name", "dispatch_args", "parent", "properties", "constructor", "methods", "srcref" ), idiomatic_class = c("S7_generic", "function", "S7_object") diff --git a/R/s7-ellmer_TypeArray.R b/R/s7-ellmer_TypeArray.R index a474b3ad..d6156998 100644 --- a/R/s7-ellmer_TypeArray.R +++ b/R/s7-ellmer_TypeArray.R @@ -37,7 +37,7 @@ opts_ellmer_TypeArray <- function(constructor = c("type_array", "TypeArray", "ne constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeArray", "ellmer::Type", "S7_object"), - ignore = c(s7_internal_attrs, "description", "required", "items") + ignore = c(s7_internal_attrs(), "description", "required", "items") ) } @@ -54,6 +54,6 @@ opts_ellmer_TypeArray <- function(constructor = c("type_array", "TypeArray", "ne constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeArray", "ellmer::Type", "S7_object"), - ignore = c(s7_internal_attrs, "description", "required", "items") + ignore = c(s7_internal_attrs(), "description", "required", "items") ) } diff --git a/R/s7-elmer_TypeBasic.R b/R/s7-elmer_TypeBasic.R index 3625b067..1ed984bb 100644 --- a/R/s7-elmer_TypeBasic.R +++ b/R/s7-elmer_TypeBasic.R @@ -39,7 +39,7 @@ opts_ellmer_TypeBasic <- function(constructor = c("default", "TypeBasic", "next" constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeBasic", "ellmer::Type", "S7_object"), - ignore = c(s7_internal_attrs, "description", "required", "type") + ignore = c(s7_internal_attrs(), "description", "required", "type") ) } @@ -56,6 +56,6 @@ opts_ellmer_TypeBasic <- function(constructor = c("default", "TypeBasic", "next" constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeBasic", "ellmer::Type", "S7_object"), - ignore = c(s7_internal_attrs, "description", "required", "type") + ignore = c(s7_internal_attrs(), "description", "required", "type") ) } diff --git a/R/s7-elmer_TypeEnum.R b/R/s7-elmer_TypeEnum.R index 5ddade0a..a98b5ba6 100644 --- a/R/s7-elmer_TypeEnum.R +++ b/R/s7-elmer_TypeEnum.R @@ -38,7 +38,7 @@ opts_ellmer_TypeEnum <- function(constructor = c("type_enum", "TypeEnum", "next" constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeEnum", "ellmer::Type", "S7_object"), - ignore = c(s7_internal_attrs, "description", "required", "values") + ignore = c(s7_internal_attrs(), "description", "required", "values") ) } @@ -55,6 +55,6 @@ opts_ellmer_TypeEnum <- function(constructor = c("type_enum", "TypeEnum", "next" constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeEnum", "ellmer::Type", "S7_object"), - ignore = c(s7_internal_attrs, "description", "required", "values") + ignore = c(s7_internal_attrs(), "description", "required", "values") ) } diff --git a/R/s7-elmer_TypeJsonSchema.R b/R/s7-elmer_TypeJsonSchema.R index b7b59012..56b760ee 100644 --- a/R/s7-elmer_TypeJsonSchema.R +++ b/R/s7-elmer_TypeJsonSchema.R @@ -33,7 +33,7 @@ opts_ellmer_TypeJsonSchema <- function(constructor = c("type_from_schema", "Type constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeJsonSchema", "ellmer::Type", "S7_object"), - ignore = c(s7_internal_attrs, "json", "required") + ignore = c(s7_internal_attrs(), "json", "required") ) } @@ -50,6 +50,6 @@ opts_ellmer_TypeJsonSchema <- function(constructor = c("type_from_schema", "Type constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeJsonSchema", "ellmer::Type", "S7_object"), - ignore = c(s7_internal_attrs, "description", "required", "json") + ignore = c(s7_internal_attrs(), "description", "required", "json") ) } diff --git a/R/s7-elmer_TypeObject.R b/R/s7-elmer_TypeObject.R index c2f4a12a..cf0036be 100644 --- a/R/s7-elmer_TypeObject.R +++ b/R/s7-elmer_TypeObject.R @@ -46,7 +46,7 @@ opts_ellmer_TypeObject <- function(constructor = c("type_object", "TypeObject", constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeObject", "ellmer::Type", "S7_object"), - ignore = c(s7_internal_attrs, "description", "required", "additional_properties", "properties") + ignore = c(s7_internal_attrs(), "description", "required", "additional_properties", "properties") ) } @@ -64,6 +64,6 @@ opts_ellmer_TypeObject <- function(constructor = c("type_object", "TypeObject", constructive::.cstr_repair_attributes( x, code, ..., idiomatic_class = c("ellmer::TypeObject", "ellmer::Type", "S7_object"), - ignore = c(s7_internal_attrs, "description", "required", "additional_properties", "properties") + ignore = c(s7_internal_attrs(), "description", "required", "additional_properties", "properties") ) } From 56ca584ce44eba98271e3fc54d52545ec7030e6b Mon Sep 17 00:00:00 2001 From: Antoine Fabri Date: Mon, 19 Oct 2026 09:36:40 +0200 Subject: [PATCH 6/6] =?UTF-8?q?=F0=9F=A4=96=F0=9F=94=A7=20Build=20S7=20obj?= =?UTF-8?q?ects=20accurately=20with=20both=20S7=20storage=20schemes?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Read the class and check attributes according to the installed S7 version with with_versions(), consider S7 objects built by an S7 version storing the class differently as corrupted, and construct the "S7_class_ref" of S7 > 0.2.2 from its class rather than from a memory address. Co-Authored-By: Claude Opus 5.5 (1M context) --- NAMESPACE | 3 ++ NEWS.md | 4 ++ R/construct-helpers.R | 1 + R/s3-ggplot2-ggplot2-element_blank.R | 2 +- R/s3-ggplot2-ggplot2-element_geom.R | 2 +- R/s3-ggplot2-ggplot2-element_line.R | 2 +- R/s3-ggplot2-ggplot2-element_point.R | 2 +- R/s3-ggplot2-ggplot2-element_polygon.R | 2 +- R/s3-ggplot2-ggplot2-element_rect.R | 2 +- R/s3-ggplot2-ggplot2-element_text.R | 2 +- R/s3-ggplot2-ggplot2-ggplot.R | 2 +- R/s7-S7-object.R | 22 +++++++--- R/s7-S7_class.R | 12 ++++- R/s7-S7_class_ref.R | 47 ++++++++++++++++++++ R/s7-S7_generic.R | 2 +- R/s7-ellmer_TypeArray.R | 2 +- R/s7-elmer_TypeBasic.R | 2 +- R/s7-elmer_TypeEnum.R | 2 +- R/s7-elmer_TypeJsonSchema.R | 2 +- R/s7-elmer_TypeObject.R | 2 +- man/construct.Rd | 1 + man/opts_S7_class_ref.Rd | 30 +++++++++++++ tests/testthat/_snaps/s7-S7-object.md | 12 +++++ tests/testthat/_snaps/s7-S7_class_ref.md | 56 ++++++++++++++++++++++++ tests/testthat/_snaps/s7-S7_generic.md | 23 +++++++++- tests/testthat/test-s7-S7-object.R | 4 ++ tests/testthat/test-s7-S7_class_ref.R | 17 +++++++ 27 files changed, 237 insertions(+), 23 deletions(-) create mode 100644 R/s7-S7_class_ref.R create mode 100644 man/opts_S7_class_ref.Rd create mode 100644 tests/testthat/_snaps/s7-S7_class_ref.md create mode 100644 tests/testthat/test-s7-S7_class_ref.R diff --git a/NAMESPACE b/NAMESPACE index ff9d8476..3371174b 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index b30aa8dd..9bf6b329 100644 --- a/NEWS.md +++ b/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 diff --git a/R/construct-helpers.R b/R/construct-helpers.R index 5966dd9a..4df40138 100644 --- a/R/construct-helpers.R +++ b/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", diff --git a/R/s3-ggplot2-ggplot2-element_blank.R b/R/s3-ggplot2-ggplot2-element_blank.R index 8b09a25c..66e1f054 100644 --- a/R/s3-ggplot2-ggplot2-element_blank.R +++ b/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 diff --git a/R/s3-ggplot2-ggplot2-element_geom.R b/R/s3-ggplot2-ggplot2-element_geom.R index 2be6321c..a0659d5c 100644 --- a/R/s3-ggplot2-ggplot2-element_geom.R +++ b/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 diff --git a/R/s3-ggplot2-ggplot2-element_line.R b/R/s3-ggplot2-ggplot2-element_line.R index 732351c6..b1da5e08 100644 --- a/R/s3-ggplot2-ggplot2-element_line.R +++ b/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 diff --git a/R/s3-ggplot2-ggplot2-element_point.R b/R/s3-ggplot2-ggplot2-element_point.R index 014291f2..e9c09c89 100644 --- a/R/s3-ggplot2-ggplot2-element_point.R +++ b/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 diff --git a/R/s3-ggplot2-ggplot2-element_polygon.R b/R/s3-ggplot2-ggplot2-element_polygon.R index 21660e23..19ec3233 100644 --- a/R/s3-ggplot2-ggplot2-element_polygon.R +++ b/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 diff --git a/R/s3-ggplot2-ggplot2-element_rect.R b/R/s3-ggplot2-ggplot2-element_rect.R index 9a51f370..4ed530c8 100644 --- a/R/s3-ggplot2-ggplot2-element_rect.R +++ b/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 diff --git a/R/s3-ggplot2-ggplot2-element_text.R b/R/s3-ggplot2-ggplot2-element_text.R index 254a7959..405eabc3 100644 --- a/R/s3-ggplot2-ggplot2-element_text.R +++ b/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 diff --git a/R/s3-ggplot2-ggplot2-ggplot.R b/R/s3-ggplot2-ggplot2-ggplot.R index 7b82ec56..dd1b29c2 100644 --- a/R/s3-ggplot2-ggplot2-ggplot.R +++ b/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 diff --git a/R/s7-S7-object.R b/R/s7-S7-object.R index 09e5d5f1..0feec997 100644 --- a/R/s7-S7-object.R +++ b/R/s7-S7-object.R @@ -38,11 +38,11 @@ is_corrupted_S7_object <- function(x) { # directly anyway if (with_versions(R < "4.4")) { # see ?opts_S7_object - typeof(x) != "S4" + if (typeof(x) != "S4") return(TRUE) } else { - typeof(x) != "object" + if (typeof(x) != "object") return(TRUE) } - + has_foreign_s7_attrs(x) } @@ -55,8 +55,7 @@ is_corrupted_S7_object <- function(x) { fun_code <- .cstr_construct(s7_class(x), ...) args <- attributes(x) args$class <- NULL - # the S7 attributes of any S7 version, they're not properties - args[c("S7_class", "_S7_class", "_S7_version")] <- NULL + args[s7_internal_attrs()] <- NULL code <- constructive::.cstr_apply(args, fun = fun_code, ...) constructive::.cstr_repair_attributes( x, code, ..., @@ -87,7 +86,18 @@ s7_internal_attrs <- function() { } s7_class <- function(x) { - class <- attr(x, "_S7_class") %||% attr(x, "S7_class") + if (with_versions(S7 <= "0.2.2")) return(attr(x, "S7_class")) + class <- attr(x, "_S7_class") if (is.environment(class)) class <- get("class", envir = class) class } + +# S7 objects built with an S7 version that stores the class differently than the +# installed one can't be built idiomatically, we consider them corrupted +has_foreign_s7_attrs <- function(x) { + if (with_versions(S7 <= "0.2.2")) { + !is.null(attr(x, "_S7_class")) || !is.null(attr(x, "_S7_version")) + } else { + !is.null(attr(x, "S7_class")) || is.null(attr(x, "_S7_version")) + } +} diff --git a/R/s7-S7_class.R b/R/s7-S7_class.R index 7dae47f6..cf57a548 100644 --- a/R/s7-S7_class.R +++ b/R/s7-S7_class.R @@ -22,7 +22,15 @@ opts_S7_class <- function(constructor = c("new_class", "next"), ...) { } is_corrupted_S7_class <- function(x) { - FALSE + # Since S7 0.2.2.9000 `new_class()` wraps the constructor's environment into + # a new one holding a reference to the class, and sets "S7_version", classes + # built with another S7 version than the installed one are corrupted + wrapped_env <- exists(".S7_class_ref", environment(x), inherits = FALSE) + if (with_versions(S7 <= "0.2.2")) { + wrapped_env || !is.null(attr(x, "S7_version")) + } else { + !wrapped_env || is.null(attr(x, "S7_version")) + } } #' @export @@ -42,7 +50,7 @@ is_corrupted_S7_class <- function(x) { # Since S7 0.2.2.9000 `new_class()` wraps the constructor's environment into # a new one holding a reference to the class, so we provide the original # environment and let `new_class()` create the wrapper - wrapped_env <- exists(".S7_class_ref", environment(x), inherits = FALSE) + wrapped_env <- with_versions(S7 > "0.2.2") if (wrapped_env && !is.null(args$constructor)) { environment(args$constructor) <- parent.env(environment(x)) } diff --git a/R/s7-S7_class_ref.R b/R/s7-S7_class_ref.R new file mode 100644 index 00000000..55647821 --- /dev/null +++ b/R/s7-S7_class_ref.R @@ -0,0 +1,47 @@ +#' Constructive options for class 'S7_class_ref' +#' +#' These options will be used on objects of class 'S7_class_ref'. Since S7 +#' 0.2.2.9000 an S7 object stores its class in the "_S7_class" attribute through +#' such a reference, which `S7::new_class()` creates and stores in the +#' environment of the class. +#' +#' Depending on `constructor`, we construct the object as follows: +#' * `"environment"` (default): We build the class and fetch the reference +#' from its environment. +#' * `"next"` : Use the constructor for the next supported class. +#' +#' @param constructor String. Name of the function used to construct the object. +#' @param ... Additional options used by user defined constructors through the `opts` object +#' @return An object of class +#' @export +opts_S7_class_ref <- function(constructor = c("environment", "next"), ...) { + constructive::.cstr_options("S7_class_ref", constructor = constructor[[1]], ...) +} + +#' @exportS3Method constructive::.cstr_construct +.cstr_construct.S7_class_ref <- function(x, ...) { + opts <- list(...)$opts$S7_class_ref %||% opts_S7_class_ref() + if (is_corrupted_S7_class_ref(x) || opts$constructor == "next") return(NextMethod()) + UseMethod(".cstr_construct.S7_class_ref", structure(NA, class = opts$constructor)) +} + +is_corrupted_S7_class_ref <- function(x) { + # S7 <= 0.2.2 doesn't use class references + if (with_versions(S7 <= "0.2.2")) return(TRUE) + if (!is.environment(x)) return(TRUE) + class <- get0("class", envir = x, inherits = FALSE) + if (!inherits(class, "S7_class")) return(TRUE) + ref <- get0(".S7_class_ref", envir = environment(class), inherits = FALSE) + !identical(ref, x) +} + +#' @export +.cstr_construct.S7_class_ref.environment <- function(x, ...) { + # opts <- list(...)$opts$S7_class_ref %||% opts_S7_class_ref() + code <- .cstr_apply(list(get("class", envir = x)), "environment", ...) + code[[length(code)]] <- paste0(code[[length(code)]], "$.S7_class_ref") + constructive::.cstr_repair_attributes( + x, code, ..., + idiomatic_class = "S7_class_ref" + ) +} diff --git a/R/s7-S7_generic.R b/R/s7-S7_generic.R index da23857b..83ad102d 100644 --- a/R/s7-S7_generic.R +++ b/R/s7-S7_generic.R @@ -22,7 +22,7 @@ opts_S7_generic <- function(constructor = c("new_generic", "next"), ...) { } is_corrupted_S7_generic <- function(x) { - FALSE + has_foreign_s7_attrs(x) } #' @export diff --git a/R/s7-ellmer_TypeArray.R b/R/s7-ellmer_TypeArray.R index d6156998..80667f1b 100644 --- a/R/s7-ellmer_TypeArray.R +++ b/R/s7-ellmer_TypeArray.R @@ -22,7 +22,7 @@ opts_ellmer_TypeArray <- function(constructor = c("type_array", "TypeArray", "ne } `is_corrupted_ellmer::TypeArray` <- function(x) { - FALSE + has_foreign_s7_attrs(x) } #' @export diff --git a/R/s7-elmer_TypeBasic.R b/R/s7-elmer_TypeBasic.R index 1ed984bb..3351780e 100644 --- a/R/s7-elmer_TypeBasic.R +++ b/R/s7-elmer_TypeBasic.R @@ -22,7 +22,7 @@ opts_ellmer_TypeBasic <- function(constructor = c("default", "TypeBasic", "next" } `is_corrupted_ellmer::TypeBasic` <- function(x) { - FALSE + has_foreign_s7_attrs(x) } #' @export diff --git a/R/s7-elmer_TypeEnum.R b/R/s7-elmer_TypeEnum.R index a98b5ba6..175ac29d 100644 --- a/R/s7-elmer_TypeEnum.R +++ b/R/s7-elmer_TypeEnum.R @@ -22,7 +22,7 @@ opts_ellmer_TypeEnum <- function(constructor = c("type_enum", "TypeEnum", "next" } `is_corrupted_ellmer::TypeEnum` <- function(x) { - FALSE + has_foreign_s7_attrs(x) } #' @export diff --git a/R/s7-elmer_TypeJsonSchema.R b/R/s7-elmer_TypeJsonSchema.R index 56b760ee..25d7220c 100644 --- a/R/s7-elmer_TypeJsonSchema.R +++ b/R/s7-elmer_TypeJsonSchema.R @@ -22,7 +22,7 @@ opts_ellmer_TypeJsonSchema <- function(constructor = c("type_from_schema", "Type } `is_corrupted_ellmer::TypeJsonSchema` <- function(x) { - FALSE + has_foreign_s7_attrs(x) } #' @export diff --git a/R/s7-elmer_TypeObject.R b/R/s7-elmer_TypeObject.R index cf0036be..5da90792 100644 --- a/R/s7-elmer_TypeObject.R +++ b/R/s7-elmer_TypeObject.R @@ -22,7 +22,7 @@ opts_ellmer_TypeObject <- function(constructor = c("type_object", "TypeObject", } `is_corrupted_ellmer::TypeObject` <- function(x) { - FALSE + has_foreign_s7_attrs(x) } #' @export diff --git a/man/construct.Rd b/man/construct.Rd index 238c9155..23186314 100644 --- a/man/construct.Rd +++ b/man/construct.Rd @@ -282,6 +282,7 @@ We can provide calls to `opts_*()` functions to the `...` argument. Each of thes \item \code{\link[=opts_S7_any]{opts_S7_any}(constructor = c("class_any", "next"), ...)} \item \code{\link[=opts_S7_base_class]{opts_S7_base_class}(constructor = c("S7", "next"), ...)} \item \code{\link[=opts_S7_class]{opts_S7_class}(constructor = c("new_class", "next"), ...)} + \item \code{\link[=opts_S7_class_ref]{opts_S7_class_ref}(constructor = c("environment", "next"), ...)} \item \code{\link[=opts_S7_external_generic]{opts_S7_external_generic}(constructor = c("new_external_generic", "next"), ...)} \item \code{\link[=opts_S7_generic]{opts_S7_generic}(constructor = c("new_generic", "next"), ...)} \item \code{\link[=opts_S7_object]{opts_S7_object}(constructor = c("S7_object", "next"), ...)} diff --git a/man/opts_S7_class_ref.Rd b/man/opts_S7_class_ref.Rd new file mode 100644 index 00000000..9bbf2a64 --- /dev/null +++ b/man/opts_S7_class_ref.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/s7-S7_class_ref.R +\name{opts_S7_class_ref} +\alias{opts_S7_class_ref} +\title{Constructive options for class 'S7_class_ref'} +\usage{ +opts_S7_class_ref(constructor = c("environment", "next"), ...) +} +\arguments{ +\item{constructor}{String. Name of the function used to construct the object.} + +\item{...}{Additional options used by user defined constructors through the \code{opts} object} +} +\value{ +An object of class +} +\description{ +These options will be used on objects of class 'S7_class_ref'. Since S7 +0.2.2.9000 an S7 object stores its class in the "_S7_class" attribute through +such a reference, which \code{S7::new_class()} creates and stores in the +environment of the class. +} +\details{ +Depending on \code{constructor}, we construct the object as follows: +\itemize{ +\item \code{"environment"} (default): We build the class and fetch the reference +from its environment. +\item \code{"next"} : Use the constructor for the next supported class. +} +} diff --git a/tests/testthat/_snaps/s7-S7-object.md b/tests/testthat/_snaps/s7-S7-object.md index e8e4c6b7..15bf8e78 100644 --- a/tests/testthat/_snaps/s7-S7-object.md +++ b/tests/testthat/_snaps/s7-S7-object.md @@ -13,6 +13,12 @@ getClass("S4")@prototype |> asS3(complete = FALSE) |> structure(class = "S7_object") + Code + construct(structure(S7::S7_object(), `_S7_version` = 1L)) + Output + getClass("S4")@prototype |> + asS3(complete = FALSE) |> + structure(class = "S7_object", `_S7_version` = 1L) # S7_object, S7 > 0.2.2 @@ -22,4 +28,10 @@ getClass("S4")@prototype |> asS3(complete = FALSE) |> structure(class = "S7_object", `_S7_version` = 1L) + Code + construct(structure(S7::S7_object(), `_S7_version` = NULL)) + Output + getClass("S4")@prototype |> + asS3(complete = FALSE) |> + structure(class = "S7_object") diff --git a/tests/testthat/_snaps/s7-S7_class_ref.md b/tests/testthat/_snaps/s7-S7_class_ref.md new file mode 100644 index 00000000..fa7fef6d --- /dev/null +++ b/tests/testthat/_snaps/s7-S7_class_ref.md @@ -0,0 +1,56 @@ +# S7_class_ref + + Code + Dog <- evalq(S7::new_class("Dog", properties = list(name = S7::class_character)), + .GlobalEnv) + construct(Dog(name = "x"), check = FALSE) + Output + S7::S7_object() |> + structure( + class = c("Dog", "S7_object"), + `_S7_class` = environment( + S7::new_class( + "Dog", + parent = S7::S7_object, + properties = list(name = S7::class_character), + constructor = as.function( + list( + name = character(0), + quote({ + name + S7::new_object(S7::S7_object(), name = name) + }) + ), + envir = .GlobalEnv + ) |> + structure(class = "S7_constructor") + ) + )$.S7_class_ref, + name = "x" + ) + Code + construct(attr(Dog(name = "x"), "_S7_class"), check = FALSE) + Output + environment( + S7::new_class( + "Dog", + parent = S7::S7_object, + properties = list(name = S7::class_character), + constructor = as.function( + list( + name = character(0), + quote({ + name + S7::new_object(S7::S7_object(), name = name) + }) + ), + envir = .GlobalEnv + ) |> + structure(class = "S7_constructor") + ) + )$.S7_class_ref + Code + construct(attr(Dog(name = "x"), "_S7_class"), opts_S7_class_ref("next"), check = FALSE) + Output + constructive::.env("0x123456789", parents = "empty", class = "S7_class_ref") + diff --git a/tests/testthat/_snaps/s7-S7_generic.md b/tests/testthat/_snaps/s7-S7_generic.md index ced2c3bd..73024982 100644 --- a/tests/testthat/_snaps/s7-S7_generic.md +++ b/tests/testthat/_snaps/s7-S7_generic.md @@ -61,7 +61,28 @@ structure( class = c("S7_generic", "function", "S7_object"), `_S7_version` = 1L, - `_S7_class` = constructive::.env("0x123456789", parents = "empty", class = "S7_class_ref"), + `_S7_class` = environment( + S7::new_class( + "S7_generic", + parent = S7::class_function, + properties = list( + name = S7::class_character, + methods = S7::class_environment, + dispatch_args = S7::class_character + ), + constructor = as.function( + list( + .data = quote(function() NULL), + name = character(0), + methods = quote(new.env(parent = emptyenv())), + dispatch_args = character(0), + quote(new_object(fun(.data = .data), name = name, methods = methods, dispatch_args = dispatch_args)) + ), + envir = constructive::.env("0x123456789", parents = c("0x123456789", "namespace:S7")) + ) |> + structure(class = "S7_constructor") + ) + )$.S7_class_ref, name = "type_of", methods = constructive::.env("0x123456789", parents = "empty"), dispatch_args = "x", diff --git a/tests/testthat/test-s7-S7-object.R b/tests/testthat/test-s7-S7-object.R index 82462708..29acc651 100644 --- a/tests/testthat/test-s7-S7-object.R +++ b/tests/testthat/test-s7-S7-object.R @@ -12,6 +12,8 @@ test_that("S7_object, S7 <= 0.2.2", { skip_if(with_versions(S7 > "0.2.2")) expect_snapshot({ construct(S7::S7_object(), opts_S7_object("next")) + # built by another S7 version + construct(structure(S7::S7_object(), `_S7_version` = 1L)) }) }) @@ -22,5 +24,7 @@ test_that("S7_object, S7 > 0.2.2", { skip_if(with_versions(S7 <= "0.2.2")) expect_snapshot({ construct(S7::S7_object(), opts_S7_object("next")) + # built by another S7 version + construct(structure(S7::S7_object(), `_S7_version` = NULL)) }) }) diff --git a/tests/testthat/test-s7-S7_class_ref.R b/tests/testthat/test-s7-S7_class_ref.R new file mode 100644 index 00000000..8a9d869c --- /dev/null +++ b/tests/testthat/test-s7-S7_class_ref.R @@ -0,0 +1,17 @@ +test_that("S7_class_ref", { + # S7 <= 0.2.2 doesn't use class references + testthat::skip_on_os("linux") + skip_if_not_installed("S7") + skip_if(with_versions(S7 <= "0.2.2")) + expect_snapshot({ + Dog <- evalq( + S7::new_class("Dog", properties = list(name = S7::class_character)), + .GlobalEnv + ) + # check = FALSE because the check evaluates the code in the test environment + # where `new_class()` infers the package "constructive" + construct(Dog(name = "x"), check = FALSE) + construct(attr(Dog(name = "x"), "_S7_class"), check = FALSE) + construct(attr(Dog(name = "x"), "_S7_class"), opts_S7_class_ref("next"), check = FALSE) + }) +})