Accept initializer in new_class() and new_property()

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)
 

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"

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
   }
 

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");

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;
 

tests/testthat/_snaps/class.md

@@ -19,19 +19,21 @@
        @ package    : NULL
        @ properties :List of 2
        .. $ x: <S7_property> 
-       ..  ..$ name     : chr "x"
-       ..  ..$ class    : <S7_base_class>: <integer>
-       ..  ..$ getter   : NULL
-       ..  ..$ setter   : NULL
-       ..  ..$ validator: NULL
-       ..  ..$ default  : NULL
+       ..  ..$ name       : chr "x"
+       ..  ..$ class      : <S7_base_class>: <integer>
+       ..  ..$ getter     : NULL
+       ..  ..$ setter     : NULL
+       ..  ..$ validator  : NULL
+       ..  ..$ initializer: NULL
+       ..  ..$ default    : NULL
        .. $ y: <S7_property> 
-       ..  ..$ name     : chr "y"
-       ..  ..$ class    : <S7_base_class>: <integer>
-       ..  ..$ getter   : NULL
-       ..  ..$ setter   : NULL
-       ..  ..$ validator: NULL
-       ..  ..$ default  : NULL
+       ..  ..$ name       : chr "y"
+       ..  ..$ class      : <S7_base_class>: <integer>
+       ..  ..$ getter     : NULL
+       ..  ..$ setter     : NULL
+       ..  ..$ validator  : NULL
+       ..  ..$ initializer: NULL
+       ..  ..$ default    : NULL
        @ abstract   : logi FALSE
        @ constructor: function (x = integer(0), y = integer(0))  
        @ validator  : NULL

tests/testthat/_snaps/property.md

@@ -64,23 +64,25 @@
       print(x)
     Output
       <S7_property> 
-       $ name     : chr "foo"
-       $ class    : <S7_base_class>: <integer>
-       $ getter   : NULL
-       $ setter   : NULL
-       $ validator: NULL
-       $ default  : NULL
+       $ name       : chr "foo"
+       $ class      : <S7_base_class>: <integer>
+       $ getter     : NULL
+       $ setter     : NULL
+       $ validator  : NULL
+       $ initializer: NULL
+       $ default    : NULL
     Code
       str(list(x))
     Output
       List of 1
        $ : <S7_property> 
-        ..$ name     : chr "foo"
-        ..$ class    : <S7_base_class>: <integer>
-        ..$ getter   : NULL
-        ..$ setter   : NULL
-        ..$ validator: NULL
-        ..$ default  : NULL
+        ..$ name       : chr "foo"
+        ..$ class      : <S7_base_class>: <integer>
+        ..$ getter     : NULL
+        ..$ setter     : NULL
+        ..$ validator  : NULL
+        ..$ initializer: NULL
+        ..$ default    : NULL
 
 # properties can be base, S3, S4, S7, or S7 union
 

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")
         }
       ),