Allow a property setter to (optionally) take name (#624)

Fixes #552

Author: hadley

NEWS.md

@@ -13,6 +13,7 @@
 * Method dispatch on `class_missing` now correctly handles missing arguments forwarded through a wrapper functions (#595).
 * `super()` now works with S3 and S4 objects, not just S7 objects (#500).
 * `new_object()` no longer materialises ALTREP parent values (e.g. `seq_len()`), so constructing an S7 object that wraps a large compact integer sequence is now O(1) in memory instead of O(n) (@kschaubroeck, #607).
+* `new_property()` now accepts a `setter` that takes `self`, `name`, and `value` making it easy to reuse the same definition for multiple properties (#552).
 * `new_S3_class()` objects now work with `inherits()` (and other functions that use `nameOfClass()`) in R 4.3 and later (@lawremi, #521).
 * New `prop_info()` returns a data frame summarising the properties of an S7 object or class, with one row per property and columns for name, default, class, getter, setter, and validator (#551).
 * `prop()` and `prop<-()` errors from custom getters and setters now report a synthetic `<Class>@<prop>` call, making it easier to see which property triggered the error (#536, #627, #638).

R/property.R

@@ -21,8 +21,12 @@
 #'   an object of the correct `class`; it will not be validated automatically.
 #'
 #'   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 setter An optional function used to set the value.
+#'   There are two supported forms:
+#'
+#'   * `function(self, value)` is supplied the object and the value.
+#'   * `function(self, name, value)` also gets the property name being set,
+#'      which makes it easy to reuse the same property for multiple properties.
 #' @param validator A function taking a single argument, `value`, the value
 #'   to validate.
 #'
@@ -93,7 +97,13 @@ new_property <- function(
     check_function(getter, alist(self = ))
   }
   if (!is.null(setter)) {
-    check_function(setter, alist(self = , value = ))
+    check_function(
+      setter,
+      list(
+        alist(self = , value = ),
+        alist(self = , name = , value = )
+      )
+    )
   }
   if (!is.null(validator)) {
     check_function(validator, alist(value = ))

R/utils.R

@@ -106,16 +106,30 @@ check_function <- function(f, args, arg = deparse(substitute(f))) {
     stop(msg, call. = FALSE)
   }
 
-  args <- as.pairlist(args)
-  if (!identical(formals(f), args)) {
-    msg <- sprintf(
-      "`%s` must be %s, not %s.",
-      arg,
-      show_args(args),
-      show_args(formals(f))
-    )
-    stop(msg, call. = FALSE)
+  # `args` is either a single formals list (e.g. alist(self = , value = ))
+  # or an unnamed list of such formals lists. Distinguish via names: a
+  # single signature has named entries (one per arg); a list of signatures
+  # is unnamed.
+  if (length(args) == 0 || any(nzchar(names2(args)))) {
+    candidates <- list(as.pairlist(args))
+  } else {
+    candidates <- lapply(args, as.pairlist)
+  }
+
+  for (cand in candidates) {
+    if (identical(formals(f), cand)) {
+      return(invisible())
+    }
   }
+
+  expected <- oxford_or(vapply(candidates, show_args, character(1)))
+  msg <- sprintf(
+    "`%s` must be %s, not %s.",
+    arg,
+    expected,
+    show_args(formals(f))
+  )
+  stop(msg, call. = FALSE)
 }
 
 show_function <- function(x, constructor = FALSE) {

man/new_property.Rd

@@ -15,12 +15,14 @@ static inline
 SEXP s7_get_var_in_frame(SEXP env, SEXP sym, SEXP ifnotfound) {
   return R_getVarEx(sym, env, FALSE, ifnotfound);
 }
+#define getClosureFormals R_ClosureFormals
 #else
 static inline
 SEXP s7_get_var_in_frame(SEXP env, SEXP sym, SEXP ifnotfound) {
   SEXP val = Rf_findVarInFrame(env, sym);
   return val == R_UnboundValue ? ifnotfound : val;
 }
+#define getClosureFormals FORMALS
 #endif
 
 static inline

src/compat.h

@@ -1,11 +1,5 @@
 #include "compat.h"
 
-#if (R_VERSION >= R_Version(4, 5, 0))
-#define getClosureFormals R_ClosureFormals
-#else
-#define getClosureFormals FORMALS
-#endif
-
 extern SEXP parent_sym;
 extern SEXP sym_ANY;
 extern SEXP ns_S7;

src/method-dispatch.c

@@ -328,7 +328,14 @@ SEXP do_setter_call(SEXP setter, SEXP S7_class, SEXP name, SEXP object,
   object = protect_quote_if_needed(object, &n_protected);
   value = protect_quote_if_needed(value, &n_protected);
 
-  SEXP call = PROTECT(Rf_lang3(fn_sym, object, value));
+  // Support both function(self, value) and function(self, name, value)
+  // signatures. `name` is a string, so it self-evaluates and needs no quoting.
+  SEXP call;
+  if (Rf_length(getClosureFormals(setter)) >= 3) {
+    call = PROTECT(Rf_lang4(fn_sym, object, name, value));
+  } else {
+    call = PROTECT(Rf_lang3(fn_sym, object, value));
+  }
   ++n_protected;
   call_data.call = call;
 

src/prop.c

@@ -66,7 +66,7 @@
       new_property(setter = function(x, y, z) { })
     Condition
       Error:
-      ! `setter` must be function(self, value), not function(x, y, z).
+      ! `setter` must be function(self, value) or function(self, name, value), not function(x, y, z).
 
 # new_property() / validates default
 

tests/testthat/_snaps/property.md

@@ -0,0 +1,24 @@
+# check_function() accepts a matching single signature
+
+    Code
+      check_function(1, alist(x = ), arg = "f")
+    Condition
+      Error:
+      ! `f` must be a function.
+
+---
+
+    Code
+      check_function(function(y) { }, alist(x = ), arg = "f")
+    Condition
+      Error:
+      ! `f` must be function(x), not function(y).
+
+# check_function() accepts any of several candidate signatures
+
+    Code
+      check_function(function(x, y, z) { }, sigs, arg = "setter")
+    Condition
+      Error:
+      ! `setter` must be function(self, value) or function(self, name, value), not function(x, y, z).
+

tests/testthat/_snaps/utils.md

@@ -163,6 +163,28 @@ describe("prop setting", {
     x <- "foo"
     expect_error(x@blah <- "bar", "is not a slot in class")
   })
+
+  it("setter can receive the property name (#552)", {
+    property_colour <- new_property(
+      class = class_character,
+      setter = function(self, name, value) {
+        prop(self, name) <- as.character(value)
+        self
+      }
+    )
+    Rectangle <- new_class(
+      "Rectangle",
+      properties = list(colour = property_colour, fill = property_colour),
+      package = NULL
+    )
+
+    r <- Rectangle(colour = "red", fill = 99L)
+    expect_equal(r@colour, "red")
+    expect_equal(r@fill, "99")
+
+    r@colour <- 42L
+    expect_equal(r@colour, "42")
+  })
 })
 
 describe("props<-", {