From 83676c5a6d56f4f3b27690742a9e0c5f5e7ad925 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 24 Jun 2026 14:01:05 -0500 Subject: [PATCH 1/2] Tag S7-generated constructors with `new_S7_constructor()` This allows us to elminate the fragile `is_S3_stub_constructor()` and is useful infrastructure for #717 --- NAMESPACE | 2 ++ R/S3.R | 62 ++++++++++++++++++++----------------------------- R/aaa.R | 10 ++++++++ R/class.R | 2 +- R/constructor.R | 41 ++++++++++++++++++++++++-------- R/utils.R | 4 ++++ 6 files changed, 73 insertions(+), 48 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 713dcf051..bb00c7908 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,6 +17,7 @@ S3method(print,S7_S3_class) S3method(print,S7_any) S3method(print,S7_base_class) S3method(print,S7_class) +S3method(print,S7_constructor) S3method(print,S7_external_class) S3method(print,S7_external_generic) S3method(print,S7_generic) @@ -32,6 +33,7 @@ S3method(str,S7_S3_class) S3method(str,S7_any) S3method(str,S7_base_class) S3method(str,S7_class) +S3method(str,S7_constructor) S3method(str,S7_missing) S3method(str,S7_object) S3method(str,S7_property) diff --git a/R/S3.R b/R/S3.R index 5a941b7a1..b5680de9d 100644 --- a/R/S3.R +++ b/R/S3.R @@ -97,12 +97,13 @@ new_S3_class <- function(class, constructor = NULL, validator = NULL) { check_S3_constructor(constructor) } else { abstract <- TRUE - constructor <- function(.data) { - stop2( - sprintf("S3 class <%s> doesn't have a constructor.", class[[1]]), + constructor <- new_S7_constructor(new_function( + args = alist(.data = ), + body = bquote(stop2( + sprintf("S3 class <%s> doesn't have a constructor.", .(class[[1]])), call = NULL - ) - } + )) + )) } out <- list( @@ -147,21 +148,6 @@ is_S3_class <- function(x) { inherits(x, "S7_S3_class") } -# Detect the stub constructor that `new_S3_class()` inserts when no constructor -# is supplied. Needed as a fallback for `S7_S3_class` objects created by older -# versions of S7. -is_S3_stub_constructor <- function(constructor) { - if (!is.function(constructor)) { - return(FALSE) - } - call <- find_call(body(constructor), quote(sprintf)) - if (is.null(call)) { - return(FALSE) - } - fmt <- call[[2]] - is.character(fmt) && grepl("doesn't have a constructor", fmt, fixed = TRUE) -} - # ------------------------------------------------------------------------- # Pull out validation functions so hit by code coverage @@ -324,10 +310,10 @@ validate_formula <- function(self) { #' @order 3 class_factor <- new_S3_class( "factor", - constructor = function(.data = integer(), levels = NULL) { + constructor = new_S7_constructor(function(.data = integer(), levels = NULL) { levels <- levels %||% attr(.data, "levels", TRUE) %||% character() structure(.data, levels = levels, class = "factor") - }, + }), validator = validate_factor ) @@ -337,9 +323,9 @@ class_factor <- new_S3_class( #' @order 3 class_Date <- new_S3_class( "Date", - constructor = function(.data = double()) { + constructor = new_S7_constructor(function(.data = double()) { .Date(.data) - }, + }), validator = validate_date ) @@ -349,9 +335,9 @@ class_Date <- new_S3_class( #' @order 3 class_POSIXct <- new_S3_class( c("POSIXct", "POSIXt"), - constructor = function(.data = double(), tz = "") { + constructor = new_S7_constructor(function(.data = double(), tz = "") { .POSIXct(.data, tz = tz) - }, + }), validator = validate_POSIXct ) @@ -361,9 +347,9 @@ class_POSIXct <- new_S3_class( #' @order 3 class_POSIXlt <- new_S3_class( c("POSIXlt", "POSIXt"), - constructor = function(.data = NULL, tz = "") { + constructor = new_S7_constructor(function(.data = NULL, tz = "") { as.POSIXlt(.data, tz = tz) - }, + }), validator = validate_POSIXlt ) @@ -379,7 +365,7 @@ class_POSIXt <- new_S3_class("POSIXt") # abstract class #' @order 3 class_data.frame <- new_S3_class( "data.frame", - constructor = function(.data = list(), row.names = NULL) { + constructor = new_S7_constructor(function(.data = list(), row.names = NULL) { if (is.null(row.names)) { list2DF(.data) } else { @@ -387,7 +373,7 @@ class_data.frame <- new_S3_class( attr(out, "row.names") <- row.names out } - }, + }), validator = validate_data.frame ) @@ -397,7 +383,7 @@ class_data.frame <- new_S3_class( # @order 3 class_matrix <- new_S3_class( "matrix", - constructor = function( + constructor = new_S7_constructor(function( .data = logical(), nrow = NULL, ncol = NULL, @@ -412,7 +398,7 @@ class_matrix <- new_S3_class( } } matrix(.data, nrow, ncol, byrow, dimnames) - }, + }), validator = validate_matrix ) @@ -422,13 +408,13 @@ class_matrix <- new_S3_class( # @order 3 class_array <- new_S3_class( "array", - constructor = function( + constructor = new_S7_constructor(function( .data = logical(), dim = base::dim(.data) %||% length(.data), dimnames = base::dimnames(.data) ) { array(.data, dim, dimnames) - }, + }), validator = validate_array ) @@ -438,8 +424,10 @@ class_array <- new_S3_class( #' @order 3 class_formula <- new_S3_class( "formula", - constructor = function(.data = NULL, env = parent.frame()) { - stats::formula(.data, env = env) - }, + constructor = new_S7_constructor( + function(.data = NULL, env = parent.frame()) { + stats::formula(.data, env = env) + } + ), validator = validate_formula ) diff --git a/R/aaa.R b/R/aaa.R index 3f89137ab..5148c3a13 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -4,6 +4,16 @@ new_function <- function(args = NULL, body = NULL, env = asNamespace("S7")) { as.function.default(c(args, body) %||% list(NULL), env) } +# Tag a function as an S7-generated constructor (vs a user-supplied one), so +# `is_default_constructor()` can tell them apart, and re-home it (by default in +# the S7 namespace). Defined here because the base S3 wrappers in S3.R need it +# at load time. +new_S7_constructor <- function(f, env = asNamespace("S7")) { + environment(f) <- env + class(f) <- "S7_constructor" + f +} + `append<-` <- function(x, after, value) { if (missing(after)) { diff --git a/R/class.R b/R/class.R index 4cbf99bf0..7d2df93e8 100644 --- a/R/class.R +++ b/R/class.R @@ -274,7 +274,7 @@ class_is_abstract <- function(class) { if (is_class(class)) { class@abstract } else if (is_S3_class(class)) { - class$abstract %||% is_S3_stub_constructor(class$constructor) + class$abstract %||% is_default_constructor(class$constructor) } else { FALSE } diff --git a/R/constructor.R b/R/constructor.R index 528ae3712..0438121a1 100644 --- a/R/constructor.R +++ b/R/constructor.R @@ -24,15 +24,17 @@ new_constructor <- function( bquote(S7::new_object(S7::S7_object(), ..(self_args)), splice = TRUE) } - return(new_function( - args = arg_info$self, - body = as.call(c( - quote(`{`), - # Force all promises here so that any errors are signaled from - # the constructor() call instead of the new_object() call. - unname(self_args), - new_object_call - )), + return(new_S7_constructor( + new_function( + args = arg_info$self, + body = as.call(c( + quote(`{`), + # Force all promises here so that any errors are signaled from + # the constructor() call instead of the new_object() call. + unname(self_args), + new_object_call + )) + ), env = envir )) } @@ -94,7 +96,10 @@ new_constructor <- function( # And finally the constructor itself env <- new.env(parent = envir) env[[parent_name]] <- parent_fun - new_function(constr_args[constr_nms], child_call, env) + new_S7_constructor( + new_function(constr_args[constr_nms], child_call), + env = env + ) } constructor_args <- function( @@ -118,6 +123,22 @@ constructor_args <- function( # helpers ----------------------------------------------------------------- +# Was this constructor generated by S7 or supplied by the user? +is_default_constructor <- function(constructor) { + inherits(constructor, "S7_constructor") +} + +#' @export +print.S7_constructor <- function(x, ...) { + print(unclass(x), ...) + invisible(x) +} + +#' @export +str.S7_constructor <- function(object, ...) { + str(unclass(object), ...) +} + is_property_dynamic <- function(x) is.function(x$getter) missing_args <- function(names) { diff --git a/R/utils.R b/R/utils.R index cab73e2a1..899692aea 100644 --- a/R/utils.R +++ b/R/utils.R @@ -136,6 +136,10 @@ str_nest <- function( str_function <- function(object, ..., nest.lev = 0) { attr(object, "srcref") <- NULL + # Display S7-generated constructors like any other function + if (inherits(object, "S7_constructor")) { + class(object) <- NULL + } if (identical(class(object), "function")) { cat(" ") } From 534ffcca28ced4864fdc26b62e9e908244f5a0c3 Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 24 Jun 2026 19:05:10 -0500 Subject: [PATCH 2/2] Rename to `AAA.R` so it actually runs first --- R/{aaa.R => AAA.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename R/{aaa.R => AAA.R} (100%) diff --git a/R/aaa.R b/R/AAA.R similarity index 100% rename from R/aaa.R rename to R/AAA.R