Skip to content

Commit

Permalink
Working validate function between both interface and fun.
Browse files Browse the repository at this point in the history
  • Loading branch information
dereckmezquita committed Jul 27, 2024
1 parent 5e1f80e commit b2b1bdb
Show file tree
Hide file tree
Showing 3 changed files with 169 additions and 51 deletions.
62 changes: 62 additions & 0 deletions R/fun.R
Original file line number Diff line number Diff line change
@@ -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"))))
}
54 changes: 3 additions & 51 deletions R/interface.R
Original file line number Diff line number Diff line change
Expand Up @@ -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))])
}
Expand All @@ -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)) {
Expand Down Expand Up @@ -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
Expand Down
104 changes: 104 additions & 0 deletions R/validate_property.R
Original file line number Diff line number Diff line change
@@ -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)
}

0 comments on commit b2b1bdb

Please sign in to comment.