From b2b1bdbfe4ebda74db5c9f55e3a6bf40a144ec37 Mon Sep 17 00:00:00 2001 From: Dereck Mezquita Date: Fri, 26 Jul 2024 20:20:40 -0500 Subject: [PATCH] Working validate function between both interface and fun. --- R/fun.R | 62 +++++++++++++++++++++++++ R/interface.R | 54 ++-------------------- R/validate_property.R | 104 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 169 insertions(+), 51 deletions(-) create mode 100644 R/fun.R create mode 100644 R/validate_property.R diff --git a/R/fun.R b/R/fun.R new file mode 100644 index 0000000..188e499 --- /dev/null +++ b/R/fun.R @@ -0,0 +1,62 @@ +#' Create a typed function +#' +#' @param args A list of argument names and their expected types +#' @param return The expected return type(s) +#' @param impl The function implementation +#' @return A typed function +#' @export +fun <- function(args, return, impl) { + force(args) + force(return) + force(impl) + + typed_fun <- function(...) { + call_args <- list(...) + + # Validate input arguments + for (arg_name in names(args)) { + if (!(arg_name %in% names(call_args))) { + stop(sprintf("Missing required argument: %s", arg_name), call. = FALSE) + } + + arg_value <- call_args[[arg_name]] + arg_type <- args[[arg_name]] + + error <- validate_property(arg_name, arg_value, arg_type) + if (!is.null(error)) { + stop(error, call. = FALSE) + } + } + + # Call the implementation + result <- do.call(impl, call_args) + + # Validate return value + error <- validate_property("return", result, return) + if (!is.null(error)) { + stop(error, call. = FALSE) + } + + result + } + + structure(typed_fun, + class = c("typed_function", "function"), + args = args, + return = return, + impl = impl) +} + +#' Print method for typed functions +#' +#' @param x A typed function +#' @param ... Additional arguments (not used) +#' @export +print.typed_function <- function(x, ...) { + cat("Typed function:\n") + cat("Arguments:\n") + for (name in names(attr(x, "args"))) { + cat(sprintf(" %s: %s\n", name, format(attr(x, "args")[[name]]))) + } + cat(sprintf("Return type: %s\n", format(attr(x, "return")))) +} \ No newline at end of file diff --git a/R/interface.R b/R/interface.R index 8fddf16..dea36f0 100644 --- a/R/interface.R +++ b/R/interface.R @@ -11,6 +11,9 @@ interface <- function(..., validate_on_access = FALSE, extends = list()) { # Merge properties from extended interfaces all_properties <- properties for (ext in extends) { + if (!inherits(ext, "interface")) { + stop(sprintf("Invalid extends argument: %s is not an interface", deparse(substitute(ext))), call. = FALSE) + } ext_properties <- attr(ext, "properties") all_properties <- c(all_properties, ext_properties[setdiff(names(ext_properties), names(all_properties))]) } @@ -19,7 +22,6 @@ interface <- function(..., validate_on_access = FALSE, extends = list()) { values <- list(...) obj <- new.env(parent = emptyenv()) - errors <- character() for (name in names(all_properties)) { @@ -59,56 +61,6 @@ interface <- function(..., validate_on_access = FALSE, extends = list()) { extends = extends) } -#' Validate a property -#' -#' @param name The name of the property -#' @param value The value to validate -#' @param validator The validator function or specification -#' @return NULL if valid, otherwise a character string describing the error -validate_property <- function(name, value, validator) { - if (inherits(validator, "interface")) { - if (!inherits(value, "interface_object") || !identical(attr(value, "properties"), attr(validator, "properties"))) { - return(sprintf("Property '%s' must be an object implementing the specified interface", name)) - } - } else if (identical(validator, character) || identical(validator, "character")) { - if (!is.character(value)) { - return(sprintf("Property '%s' must be a character string", name)) - } - } else if (identical(validator, numeric) || identical(validator, "numeric")) { - if (!is.numeric(value)) { - return(sprintf("Property '%s' must be a numeric value", name)) - } - } else if (identical(validator, logical) || identical(validator, "logical")) { - if (!is.logical(value)) { - return(sprintf("Property '%s' must be a logical value", name)) - } - } else if (identical(validator, data.frame) || identical(validator, "data.frame")) { - if (!is.data.frame(value)) { - return(sprintf("Property '%s' must be a data.frame", name)) - } - } else if (identical(validator, data.table::data.table) || identical(validator, "data.table")) { - if (!inherits(value, "data.table")) { - return(sprintf("Property '%s' must be a data.table", name)) - } - } else if (identical(validator, matrix) || identical(validator, "matrix")) { - if (!is.matrix(value)) { - return(sprintf("Property '%s' must be a matrix", name)) - } - } else if (is.function(validator)) { - if (!validator(value)) { - return(sprintf("Invalid value for property '%s'", name)) - } - } else if (is.character(validator)) { - if (!inherits(value, validator)) { - return(sprintf("Property '%s' must be of type %s, but got %s", name, validator, class(value)[1])) - } - } else { - return(sprintf("Invalid validator for property '%s'", name)) - } - - return(NULL) -} - #' Get a property from an interface object #' #' @param x An interface object diff --git a/R/validate_property.R b/R/validate_property.R new file mode 100644 index 0000000..a9da79f --- /dev/null +++ b/R/validate_property.R @@ -0,0 +1,104 @@ +validate_property <- function(name, value, validator) { + if (is.list(validator) && !is.function(validator)) { + # Multiple allowed types + for (v in validator) { + error <- validate_property(name, value, v) + if (is.null(error)) return(NULL) + } + return(sprintf("Property '%s' does not match any of the allowed types", name)) + } else if (inherits(validator, "interface")) { + if (!inherits(value, "interface_object") || !identical(attr(value, "properties"), attr(validator, "properties"))) { + return(sprintf("Property '%s' must be an object implementing the specified interface", name)) + } + } else if (is.function(validator)) { + if (identical(validator, character)) { + if (!is.character(value)) { + return(sprintf("Property '%s' must be of type character", name)) + } + } else if (identical(validator, numeric)) { + if (!is.numeric(value)) { + return(sprintf("Property '%s' must be of type numeric", name)) + } + } else if (identical(validator, logical)) { + if (!is.logical(value)) { + return(sprintf("Property '%s' must be of type logical", name)) + } + } else if (identical(validator, integer)) { + if (!is.integer(value)) { + return(sprintf("Property '%s' must be of type integer", name)) + } + } else if (identical(validator, double)) { + if (!is.double(value)) { + return(sprintf("Property '%s' must be of type double", name)) + } + } else if (identical(validator, complex)) { + if (!is.complex(value)) { + return(sprintf("Property '%s' must be of type complex", name)) + } + } else if (identical(validator, data.table::data.table)) { + if (!data.table::is.data.table(value)) { + return(sprintf("Property '%s' must be a data.table", name)) + } + } else if (!validator(value)) { + return(sprintf("Invalid value for property '%s'", name)) + } + } else if (is.character(validator)) { + if (!inherits(value, validator)) { + return(sprintf("Property '%s' must be of type %s, but got %s", name, validator, class(value)[1])) + } + } else { + return(sprintf("Invalid validator for property '%s'", name)) + } + + return(NULL) +} + +#' Validate a property +#' +#' @param name The name of the property +#' @param value The value to validate +#' @param validator The validator function or specification +#' @return NULL if valid, otherwise a character string describing the error +validate_property_old <- function(name, value, validator) { + if (inherits(validator, "interface")) { + if (!inherits(value, "interface_object") || !identical(attr(value, "properties"), attr(validator, "properties"))) { + return(sprintf("Property '%s' must be an object implementing the specified interface", name)) + } + } else if (identical(validator, character) || identical(validator, "character")) { + if (!is.character(value)) { + return(sprintf("Property '%s' must be a character string", name)) + } + } else if (identical(validator, numeric) || identical(validator, "numeric")) { + if (!is.numeric(value)) { + return(sprintf("Property '%s' must be a numeric value", name)) + } + } else if (identical(validator, logical) || identical(validator, "logical")) { + if (!is.logical(value)) { + return(sprintf("Property '%s' must be a logical value", name)) + } + } else if (identical(validator, data.frame) || identical(validator, "data.frame")) { + if (!is.data.frame(value)) { + return(sprintf("Property '%s' must be a data.frame", name)) + } + } else if (identical(validator, data.table::data.table) || identical(validator, "data.table")) { + if (!inherits(value, "data.table")) { + return(sprintf("Property '%s' must be a data.table", name)) + } + } else if (identical(validator, matrix) || identical(validator, "matrix")) { + if (!is.matrix(value)) { + return(sprintf("Property '%s' must be a matrix", name)) + } + } else if (is.function(validator)) { + if (!validator(value)) { + return(sprintf("Invalid value for property '%s'", name)) + } + } else if (is.character(validator)) { + if (!inherits(value, validator)) { + return(sprintf("Property '%s' must be of type %s, but got %s", name, validator, class(value)[1])) + } + } else { + return(sprintf("Invalid validator for property '%s'", name)) + } + + return(NULL) +}