From 86510b5be8e4aaf89dbddef3d7d0565d3256af5f Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Sat, 9 Sep 2023 10:19:26 -0500 Subject: [PATCH] Implement per-property validators Fixes #275 --- NEWS.md | 5 +++- R/property.R | 42 ++++++++++++++++++++++++++----- man/new_property.Rd | 13 ++++++++++ tests/testthat/_snaps/class.md | 22 ++++++++-------- tests/testthat/_snaps/property.md | 35 ++++++++++++++++++-------- tests/testthat/test-property.R | 16 ++++++++++++ 6 files changed, 106 insertions(+), 27 deletions(-) diff --git a/NEWS.md b/NEWS.md index f59759ac..e68496e4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # S7 (development version) +* `new_property()` gains a `validator` argument that allows you to specify + a per-property validator (#275). + * `new_object()` works better when custom property setters modify other properties. @@ -7,7 +10,7 @@ run and are validated when the object is constructed or when you call `validate()`, not just when you modify them after construction. -* In `new_property()` clarify that it's the users responsibility to return +* In `new_property()` clarify that it's the user's responsibility to return the correct class; it is _not_ automatically validated. * Correctly register S3 methods for S7 objects with a package (#333). diff --git a/R/property.R b/R/property.R index ca4d7644..a4c03f76 100644 --- a/R/property.R +++ b/R/property.R @@ -19,6 +19,17 @@ #' 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 validator A function taking a single argument, `value`, the value +#' to validate. +#' +#' The job of a validator is to determine whether the property value is valid. +#' It should return `NULL` if the object is valid, or if it's not valid, +#' a single string describing the problem. The message should not include the +#' name of the property as this will be automatically appended to the +#' beginning of the message. +#' +#' The validator will be called after the `class` has been verified, so +#' your code can assume that `self` has known type. #' @param default When an object is created and the property is not supplied, #' what should it default to? If `NULL`, defaults to the "empty" instance #' of `class`. @@ -69,7 +80,12 @@ #' hadley@firstName #' hadley@firstName <- "John" #' hadley@first_name -new_property <- function(class = class_any, getter = NULL, setter = NULL, default = NULL, name = NULL) { +new_property <- function(class = class_any, + getter = NULL, + setter = NULL, + validator = NULL, + default = NULL, + name = NULL) { class <- as_class(class) if (!is.null(default) && !class_inherits(default, class)) { msg <- sprintf("`default` must be an instance of %s, not a %s", class_desc(class), obj_desc(default)) @@ -82,12 +98,16 @@ new_property <- function(class = class_any, getter = NULL, setter = NULL, defaul if (!is.null(setter)) { check_function(setter, alist(self = , value = )) } + if (!is.null(validator)) { + check_function(validator, alist(value = )) + } out <- list( name = name, class = class, getter = getter, setter = setter, + validator = validator, default = default ) class(out) <- "S7_property" @@ -219,15 +239,25 @@ prop_error_unknown <- function(object, prop_name) { prop_validate <- function(prop, value, object = NULL) { if (!class_inherits(value, prop$class)) { - return(sprintf("%s@%s must be %s, not %s", - if (!is.null(object)) obj_desc(object) else "", - prop$name, + sprintf("%s must be %s, not %s", + prop_label(object, prop$name), class_desc(prop$class), obj_desc(value) - )) + ) + } else if (!is.null(prop$validator)) { + val <- prop$validator(value) + if (is.null(val)) { + return(NULL) + } + + paste0(prop_label(object, prop$name), " ", val) + } else { + NULL } +} - NULL +prop_label <- function(object, name) { + sprintf("%s@%s", if (!is.null(object)) obj_desc(object) else "", name) } #' @rdname prop diff --git a/man/new_property.Rd b/man/new_property.Rd index 88d8dd41..46cc5395 100644 --- a/man/new_property.Rd +++ b/man/new_property.Rd @@ -8,6 +8,7 @@ new_property( class = class_any, getter = NULL, setter = NULL, + validator = NULL, default = NULL, name = NULL ) @@ -26,6 +27,18 @@ If a property has a getter but doesn't have a setter, it is read only.} \item{setter}{An optional function used to set the value. The function should take \code{self} and \code{value} and return a modified object.} +\item{validator}{A function taking a single argument, \code{value}, the value +to validate. + +The job of a validator is to determine whether the property value is valid. +It should return \code{NULL} if the object is valid, or if it's not valid, +a single string describing the problem. The message should not include the +name of the property as this will be automatically appended to the +beginning of the message. + +The validator will be called after the \code{class} has been verified, so +your code can assume that \code{self} has known type.} + \item{default}{When an object is created and the property is not supplied, what should it default to? If \code{NULL}, defaults to the "empty" instance of \code{class}.} diff --git a/tests/testthat/_snaps/class.md b/tests/testthat/_snaps/class.md index 7989502e..fa55f406 100644 --- a/tests/testthat/_snaps/class.md +++ b/tests/testthat/_snaps/class.md @@ -18,17 +18,19 @@ @ package : NULL @ properties :List of 2 .. $ x: - .. ..$ name : chr "x" - .. ..$ class : : - .. ..$ getter : NULL - .. ..$ setter : NULL - .. ..$ default: NULL + .. ..$ name : chr "x" + .. ..$ class : : + .. ..$ getter : NULL + .. ..$ setter : NULL + .. ..$ validator: NULL + .. ..$ default : NULL .. $ y: - .. ..$ name : chr "y" - .. ..$ class : : - .. ..$ getter : NULL - .. ..$ setter : NULL - .. ..$ default: NULL + .. ..$ name : chr "y" + .. ..$ class : : + .. ..$ getter : NULL + .. ..$ setter : NULL + .. ..$ validator: NULL + .. ..$ default : NULL @ abstract : logi FALSE @ constructor: function (x = class_missing, y = class_missing) @ validator : NULL diff --git a/tests/testthat/_snaps/property.md b/tests/testthat/_snaps/property.md index 8a61ed13..cbb42ea1 100644 --- a/tests/testthat/_snaps/property.md +++ b/tests/testthat/_snaps/property.md @@ -73,21 +73,23 @@ print(x) Output - $ name : chr "foo" - $ class : : - $ getter : NULL - $ setter : NULL - $ default: NULL + $ name : chr "foo" + $ class : : + $ getter : NULL + $ setter : NULL + $ validator: NULL + $ default : NULL Code str(list(x)) Output List of 1 $ : - ..$ name : chr "foo" - ..$ class : : - ..$ getter : NULL - ..$ setter : NULL - ..$ default: NULL + ..$ name : chr "foo" + ..$ class : : + ..$ getter : NULL + ..$ setter : NULL + ..$ validator: NULL + ..$ default : NULL # properties can be base, S3, S4, S7, or S7 union @@ -156,3 +158,16 @@ Error `properties` names must be unique +# can validate with custom validator + + Code + f <- foo(x = 1L) + f@x <- 1:2 + Error + @x must be length 1 + Code + foo(x = 1:2) + Error + object properties are invalid: + - @x must be length 1 + diff --git a/tests/testthat/test-property.R b/tests/testthat/test-property.R index b27ddda1..1ee8e71a 100644 --- a/tests/testthat/test-property.R +++ b/tests/testthat/test-property.R @@ -298,3 +298,19 @@ test_that("as_properties() gives useful error messages", { as_properties(list(x = class_character, x = class_character)) }) }) + +test_that("can validate with custom validator", { + validate_scalar <- function(value) { + if (length(value) != 1) { + "must be length 1" + } + } + prop <- new_property(class_integer, validator = validate_scalar) + foo <- new_class("foo", properties = list(x = prop)) + expect_snapshot(error = TRUE, { + f <- foo(x = 1L) + f@x <- 1:2 + + foo(x = 1:2) + }) +})