From 600eb07b1bc42fb5d68ec5a8274ad26943c5e6d3 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sat, 31 Aug 2024 07:43:17 -0700 Subject: [PATCH 1/2] add convenience property constructors and preconstruct some of the most common property types --- R/property.R | 119 +++++++++++++++++++++++++++++++++++++++++++++++++++ R/utils.R | 13 ++++++ R/zzz.R | 1 + 3 files changed, 133 insertions(+) diff --git a/R/property.R b/R/property.R index f337f810..d832bab0 100644 --- a/R/property.R +++ b/R/property.R @@ -453,3 +453,122 @@ as_property <- function(x, name, i) { new_property(x, name = name) } } + +nullable <- function(prop) { + prop$class <- new_union(NULL, prop$class) + prop["default"] <- list(NULL) + prop +} + +new_scalar_property <- function(class, ..., validator = NULL, default) { + check_scalar(default, class) + prop <- new_property(class, ..., validator = function(value) { + if (is.null(value)) + return(NULL) + c(if (length(value) != 1L || is.na(value)) + "must be of length one and not missing", + if (!is.null(validator)) + validator(value) + ) + }, default = default) + class(prop) <- c("scalar_S7_property", class(prop)) + prop +} + +new_string_property <- function(..., validator = NULL, + default = "", choices = NULL) +{ + prop <- new_scalar_property( + class_character, ..., + validator = function(value) { + c(if (!is.null(choices) && !all(value %in% choices)) + paste("contains values not in", + deparse(choices)), + if (!is.null(validator)) + validator(value) + ) + }, default = default + ) + prop$choices <- choices + class(prop) <- c("string_S7_property", class(prop)) + prop +} + +new_flag_property <- function(..., default = FALSE) { + new_scalar_property(class_logical, ..., default = default) +} + +## TODO: make this handle non-scalars as well +new_number_property <- function(class = class_numeric, ..., validator = NULL, + default = min(max(min, 0), max), + min = -Inf, max = Inf) +{ + prop <- new_scalar_property( + class, ..., + validator = function(value) { + c(if (any(value < min)) + paste("must be >=", min), + if (any(value > max)) + paste("must be <=", max), + if (!is.null(validator)) + validator(value) + ) + }, default = default + ) + prop$min <- min + prop$max <- max + class(prop) <- c("numeric_S7_property", class(prop)) + prop +} + +## Should integer() properties be encouraged? It seems hygienic to use +## integers when appropriate, but the user might be inconvenienced. We +## tried adding a setter that performs the conversion with an +## epsilon check, but just using numeric() seemed simpler. +new_int_property <- function(..., default = min(max(min, 0L), max), + min = .Machine$integer.min, + max = .Machine$integer.max) +{ + new_number_property(class_integer, ..., default = default, min = min, + max = max) +} + +new_list_property <- function(..., validator = NULL, of = class_any, named = NA) +{ + prop <- new_property(class_list, ..., validator = function(value) { + c(if (!identical(of, class_any) && + !all(vapply(value, inherits, logical(1L), of))) + paste("must only contain elements of class", of@name), + if (isTRUE(named) && is.null(names(value))) + "must have names", + if (identical(named, FALSE) && !is.null(names(value))) + "must not have names", + if (!is.null(validator)) + valdiator(value) + ) + }) + prop$of <- of + prop$named <- named + class(prop) <- c("list_S7_property", class(prop)) + prop +} + +prop_string <- NULL +prop_flag <- NULL +prop_number <- NULL +prop_number_nn <- NULL +prop_prob <- NULL +prop_int <- NULL +prop_int_nn <- NULL +prop_int_pos <- NULL + +on_load_define_props <- function() { + prop_string <<- new_string_property() + prop_flag <<- new_flag_property() + prop_number <<- new_number_property() + prop_number_nn <<- new_number_property(min = 0) + prop_prob <<- new_number_property(min = 0, max = 1) + prop_int <<- new_int_property() + prop_int_nn <<- new_int_property(min = 0L) + prop_int_pos <<- new_int_property(min = 1L) +} diff --git a/R/utils.R b/R/utils.R index 1ee9fa46..f4036e4c 100644 --- a/R/utils.R +++ b/R/utils.R @@ -91,6 +91,19 @@ check_name <- function(name, arg = deparse(substitute(name))) { } } +check_scalar <- function(scalar, class, arg = deparse(substitute(scalar))) +{ + if (length(scalar) != 1 || !class_inherits(scalar, class)) { + type_name <- if (identical(class, class_numeric)) "numeric" else class$name + msg <- sprintf("`%s` must be a single %s value", arg, type_name) + stop(msg, call. = FALSE) + } + if (is.na(scalar)) { + msg <- sprintf("`%s` must not be NA", arg) + stop(msg, call. = FALSE) + } +} + check_function <- function(f, args, arg = deparse(substitute(f))) { if (!is.function(f)) { msg <- sprintf("`%s` must be a function", arg) diff --git a/R/zzz.R b/R/zzz.R index b4f463e5..c4fba5dd 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -126,4 +126,5 @@ methods::setOldClass(c("S7_method", "function", "S7_object")) on_load_define_or_methods() on_load_define_S7_type() on_load_define_union_classes() + on_load_define_props() } From fa861fe19ceea41584974f97991ebb5e826478c0 Mon Sep 17 00:00:00 2001 From: Michael Lawrence Date: Sat, 31 Aug 2024 07:37:23 -0700 Subject: [PATCH 2/2] fix a couple of typos in the convenience properties --- R/property.R | 2 +- R/utils.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/property.R b/R/property.R index d832bab0..c1f82353 100644 --- a/R/property.R +++ b/R/property.R @@ -544,7 +544,7 @@ new_list_property <- function(..., validator = NULL, of = class_any, named = NA) if (identical(named, FALSE) && !is.null(names(value))) "must not have names", if (!is.null(validator)) - valdiator(value) + validator(value) ) }) prop$of <- of diff --git a/R/utils.R b/R/utils.R index f4036e4c..aee439fd 100644 --- a/R/utils.R +++ b/R/utils.R @@ -94,7 +94,7 @@ check_name <- function(name, arg = deparse(substitute(name))) { check_scalar <- function(scalar, class, arg = deparse(substitute(scalar))) { if (length(scalar) != 1 || !class_inherits(scalar, class)) { - type_name <- if (identical(class, class_numeric)) "numeric" else class$name + type_name <- if (identical(class, class_numeric)) "numeric" else class$class msg <- sprintf("`%s` must be a single %s value", arg, type_name) stop(msg, call. = FALSE) }