From 600eb07b1bc42fb5d68ec5a8274ad26943c5e6d3 Mon Sep 17 00:00:00 2001
From: Michael Lawrence <lawremi@gmail.com>
Date: Sat, 31 Aug 2024 07:43:17 -0700
Subject: [PATCH] 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()
 }