From 2776aad8618111202626e940482ca269ef7cc3b4 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 24 Sep 2024 13:53:39 -0400 Subject: [PATCH] Add `initializer` to `new_class()` and `new_property()` --- R/class.R | 24 ++++++++++++++++++++---- R/property.R | 28 +++++++++++++++++++++++----- R/utils.R | 1 + man/new_class.Rd | 5 +++++ man/new_property.Rd | 25 ++++++++++++++++++++----- src/init.c | 2 ++ src/prop.c | 2 ++ tests/testthat/_snaps/class.md | 26 ++++++++++++++------------ tests/testthat/_snaps/property.md | 26 ++++++++++++++------------ tests/testthat/test-constructor.R | 7 ++++--- 10 files changed, 105 insertions(+), 41 deletions(-) diff --git a/R/class.R b/R/class.R index fe6521fc..cde29f67 100644 --- a/R/class.R +++ b/R/class.R @@ -33,6 +33,9 @@ #' A custom constructor should call `new_object()` to create the S7 object. #' The first argument, `.data`, should be an instance of the parent class #' (if used). The subsequent arguments are used to set the properties. +#' @param initializer An optional initializer function. If provided, this +#' function is called after `constructor()` but before `validator()`. It +#' should take a single argument, `self`. #' @param validator A function taking a single argument, `self`, the object #' to validate. #' @@ -104,6 +107,7 @@ new_class <- function( properties = list(), abstract = FALSE, constructor = NULL, + initializer = NULL, validator = NULL) { check_name(name) @@ -144,13 +148,14 @@ new_class <- function( attr(object, "properties") <- all_props attr(object, "abstract") <- abstract attr(object, "constructor") <- constructor + attr(object, "initializer") <- initializer attr(object, "validator") <- validator class(object) <- c("S7_class", "S7_object") global_variables(names(all_props)) object } -globalVariables(c("name", "parent", "package", "properties", "abstract", "constructor", "validator")) +globalVariables(c("name", "parent", "package", "properties", "abstract", "constructor", "validator", "initializer")) #' @rawNamespace if (getRversion() >= "4.3.0") S3method(nameOfClass, S7_class, S7_class_name) S7_class_name <- function(x) { @@ -260,12 +265,23 @@ new_object <- function(.parent, ...) { attr(object, "S7_class") <- class class(object) <- class_dispatch(class) - # Set properties. This will potentially invoke custom property setters - for (name in names(args)) - prop(object, name, check = FALSE) <- args[[name]] + args <- list(...) + for (name in names(args)) { + if (is.function(prop_initializer <- class@properties[[name]]$initializer)) { + attr(object, ".setting_prop") <- pairlist(as.symbol(name)) + object <- prop_initializer(object, args[[name]]) + attr(object, ".setting_prop") <- NULL + } else { + prop(object, name, check = FALSE) <- args[[name]] + } + } + + if (is.function(class@initializer)) + object <- class@initializer(object) # Don't need to validate if parent class already validated, # i.e. it's a non-abstract S7 class + # if(interactive() && !pkgload::is_loading()) browser() parent_validated <- inherits(class@parent, "S7_object") && !class@parent@abstract validate(object, recursive = !parent_validated) diff --git a/R/property.R b/R/property.R index 75c78eef..1af5b4d6 100644 --- a/R/property.R +++ b/R/property.R @@ -20,6 +20,9 @@ #' If a property has a getter but doesn't have a setter, it is read only. #' @param setter An optional function used to set the value. The function #' should take `self` and `value` and return a modified object. +#' @param initializer An optional initializer function. If provided, this +#' function is called when the instance is first constructed, instead of +#' `prop<-` (which invokes `setter`, if provided). #' @param validator A function taking a single argument, `value`, the value #' to validate. #' @@ -71,9 +74,10 @@ #' args(clock) #' #' # These can be useful if you want to deprecate a property -#' person <- new_class("person", properties = list( +#' Person <- new_class("Person", properties = list( #' first_name = class_character, #' firstName = new_property( +#' class_character, #' getter = function(self) { #' warning("@firstName is deprecated; please use @first_name instead", call. = FALSE) #' self@first_name @@ -82,13 +86,22 @@ #' warning("@firstName is deprecated; please use @first_name instead", call. = FALSE) #' self@first_name <- value #' self +#' }, +#' initializer = function(self, value) { +#' if (length(value)) { +#' warning("@firstName is deprecated; please use @first_name instead", call. = FALSE) +#' self@first_name <- value # will warn +#' } +#' self@firstName <- character() # for validator +#' self #' } #' ) #' )) -#' hadley <- person(first_name = "Hadley") -#' hadley@firstName -#' hadley@firstName <- "John" -#' hadley@first_name +#' Hadley <- Person(firstName = "Hadley") # warning +#' Hadley <- Person(first_name = "Hadley") +#' Hadley@firstName # warning +#' Hadley@firstName <- "John" # warning +#' Hadley@first_name #' #' # Properties can have default values that are quoted calls. #' # These become standard function promises in the default constructor, @@ -114,6 +127,7 @@ new_property <- function(class = class_any, getter = NULL, setter = NULL, validator = NULL, + initializer = NULL, default = NULL, name = NULL) { class <- as_class(class) @@ -130,6 +144,9 @@ new_property <- function(class = class_any, if (!is.null(setter)) { check_function(setter, alist(self = , value = )) } + if (!is.null(initializer)) { + check_function(initializer, alist(self = , value = )) + } if (!is.null(validator)) { check_function(validator, alist(value = )) } @@ -140,6 +157,7 @@ new_property <- function(class = class_any, getter = getter, setter = setter, validator = validator, + initializer = initializer, default = default ) class(out) <- "S7_property" diff --git a/R/utils.R b/R/utils.R index e04ec31b..cdd6623e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -138,6 +138,7 @@ modify_list <- function (x, new_vals) { nms <- names2(new_vals) if (!all(nzchar(nms))) stop("all elements in `new_vals` must be named") + x <- x %||% list() x[nms] <- new_vals } diff --git a/man/new_class.Rd b/man/new_class.Rd index f11e4ff5..70c1c5ca 100644 --- a/man/new_class.Rd +++ b/man/new_class.Rd @@ -12,6 +12,7 @@ new_class( properties = list(), abstract = FALSE, constructor = NULL, + initializer = NULL, validator = NULL ) @@ -55,6 +56,10 @@ A custom constructor should call \code{new_object()} to create the S7 object. The first argument, \code{.data}, should be an instance of the parent class (if used). The subsequent arguments are used to set the properties.} +\item{initializer}{An optional initializer function. If provided, this +function is called after \code{constructor()} but before \code{validator()}. It +should take a single argument, \code{self}.} + \item{validator}{A function taking a single argument, \code{self}, the object to validate. diff --git a/man/new_property.Rd b/man/new_property.Rd index 461e64b0..a5732b88 100644 --- a/man/new_property.Rd +++ b/man/new_property.Rd @@ -9,6 +9,7 @@ new_property( getter = NULL, setter = NULL, validator = NULL, + initializer = NULL, default = NULL, name = NULL ) @@ -39,6 +40,10 @@ beginning of the message. The validator will be called after the \code{class} has been verified, so your code can assume that \code{value} has known type.} +\item{initializer}{An optional initializer function. If provided, this +function is called when the instance is first constructed, instead of +\verb{prop<-} (which invokes \code{setter}, if provided).} + \item{default}{When an object is created and the property is not supplied, what should it default to? If \code{NULL}, it defaults to the "empty" instance of \code{class}. This can also be a quoted call, which then becomes a standard @@ -92,9 +97,10 @@ try(clock(now = 10)) args(clock) # These can be useful if you want to deprecate a property -person <- new_class("person", properties = list( +Person <- new_class("Person", properties = list( first_name = class_character, firstName = new_property( + class_character, getter = function(self) { warning("@firstName is deprecated; please use @first_name instead", call. = FALSE) self@first_name @@ -103,13 +109,22 @@ person <- new_class("person", properties = list( warning("@firstName is deprecated; please use @first_name instead", call. = FALSE) self@first_name <- value self + }, + initializer = function(self, value) { + if (length(value)) { + warning("@firstName is deprecated; please use @first_name instead", call. = FALSE) + self@first_name <- value # will warn + } + self@firstName <- character() # for validator + self } ) )) -hadley <- person(first_name = "Hadley") -hadley@firstName -hadley@firstName <- "John" -hadley@first_name +Hadley <- Person(firstName = "Hadley") # warning +Hadley <- Person(first_name = "Hadley") +Hadley@firstName # warning +Hadley@firstName <- "John" # warning +Hadley@first_name # Properties can have default values that are quoted calls. # These become standard function promises in the default constructor, diff --git a/src/init.c b/src/init.c index 11568282..f1ff218b 100644 --- a/src/init.c +++ b/src/init.c @@ -29,6 +29,7 @@ SEXP sym_package; SEXP sym_properties; SEXP sym_abstract; SEXP sym_constructor; +SEXP sym_initializer; SEXP sym_validator; SEXP sym_getter; @@ -52,6 +53,7 @@ void R_init_S7(DllInfo *dll) sym_properties = Rf_install("properties"); sym_abstract = Rf_install("abstract"); sym_constructor = Rf_install("constructor"); + sym_initializer = Rf_install("initializer"); sym_validator = Rf_install("validator"); sym_getter = Rf_install("getter"); sym_dot_should_validate = Rf_install(".should_validate"); diff --git a/src/prop.c b/src/prop.c index 7f5ec376..75ada5b4 100644 --- a/src/prop.c +++ b/src/prop.c @@ -10,6 +10,7 @@ extern SEXP sym_package; extern SEXP sym_properties; extern SEXP sym_abstract; extern SEXP sym_constructor; +extern SEXP sym_initializer; extern SEXP sym_validator; extern SEXP ns_S7; @@ -275,6 +276,7 @@ SEXP prop_(SEXP object, SEXP name) { name_sym == sym_properties || name_sym == sym_abstract || name_sym == sym_constructor || + name_sym == sym_initializer || name_sym == sym_validator)) return value; diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 64515b4c..d0fc0b30 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -19,19 +19,21 @@ @ package : NULL @ properties :List of 2 .. $ x: - .. ..$ name : chr "x" - .. ..$ class : : - .. ..$ getter : NULL - .. ..$ setter : NULL - .. ..$ validator: NULL - .. ..$ default : NULL + .. ..$ name : chr "x" + .. ..$ class : : + .. ..$ getter : NULL + .. ..$ setter : NULL + .. ..$ validator : NULL + .. ..$ initializer: NULL + .. ..$ default : NULL .. $ y: - .. ..$ name : chr "y" - .. ..$ class : : - .. ..$ getter : NULL - .. ..$ setter : NULL - .. ..$ validator: NULL - .. ..$ default : NULL + .. ..$ name : chr "y" + .. ..$ class : : + .. ..$ getter : NULL + .. ..$ setter : NULL + .. ..$ validator : NULL + .. ..$ initializer: NULL + .. ..$ default : NULL @ abstract : logi FALSE @ constructor: function (x = integer(0), y = integer(0)) @ validator : NULL diff --git a/tests/testthat/_snaps/property.md b/tests/testthat/_snaps/property.md index b787d673..4087822a 100644 --- a/tests/testthat/_snaps/property.md +++ b/tests/testthat/_snaps/property.md @@ -64,23 +64,25 @@ print(x) Output - $ name : chr "foo" - $ class : : - $ getter : NULL - $ setter : NULL - $ validator: NULL - $ default : NULL + $ name : chr "foo" + $ class : : + $ getter : NULL + $ setter : NULL + $ validator : NULL + $ initializer: NULL + $ default : NULL Code str(list(x)) Output List of 1 $ : - ..$ name : chr "foo" - ..$ class : : - ..$ getter : NULL - ..$ setter : NULL - ..$ validator: NULL - ..$ default : NULL + ..$ name : chr "foo" + ..$ class : : + ..$ getter : NULL + ..$ setter : NULL + ..$ validator : NULL + ..$ initializer: NULL + ..$ default : NULL # properties can be base, S3, S4, S7, or S7 union diff --git a/tests/testthat/test-constructor.R b/tests/testthat/test-constructor.R index c51efd02..1328a16d 100644 --- a/tests/testthat/test-constructor.R +++ b/tests/testthat/test-constructor.R @@ -117,11 +117,12 @@ test_that("can create constructors with missing or lazy defaults", { birthdate = new_property( class = class_Date, default = quote(Sys.Date()), - setter = function(self, value) { - if (!is.null(self@birthdate)) - stop("Can't set read-only property Person@birthdate") + initializer = function(self, value) { self@birthdate <- value self + }, + setter = function(self, value) { + stop("Can't set read-only property Person@birthdate") } ),