MISC-1: R interface package; initial build and research

.Rbuildignore

@@ -0,0 +1,8 @@
+^.*\.Rproj$
+^\.Rproj\.user$
+^\.pre-commit-config\.yaml$
+^renv$
+^renv\.lock$
+dev-docs/
+dev/
+research/

.Rprofile

@@ -0,0 +1,4 @@
+source("renv/activate.R")
+options(
+    styler.addins_style_transformer = "styler::tidyverse_style(indent_by = 4L)"
+)

.github/pull_request_template.md

@@ -0,0 +1,7 @@
+# jira ticket
+
+https://dereckmezquita.atlassian.net/browse/<TICKET-ID>
+
+# todo list
+
+-   [ ] Version bump

.gitignore

@@ -1,3 +1,7 @@
+# renv
+/renv/
+!renv.lock
+
 # History files
 .Rhistory
 .Rapp.history

.lintr

@@ -0,0 +1,6 @@
+linters: linters_with_defaults(
+  object_name_linter = NULL,
+  indentation_linter = indentation_linter(indent = 4),
+  line_length_linter = line_length_linter(120),
+  commented_code_linter = NULL
+)

.pre-commit-config.yaml

@@ -0,0 +1,80 @@
+# All available hooks: https://pre-commit.com/hooks.html
+# R specific hooks: https://github.com/lorenzwalthert/precommit
+repos:
+-   repo: https://github.com/lorenzwalthert/precommit
+    rev: v0.4.2
+    hooks:
+    -   id: style-files
+        args: [--style_pkg=styler, --style_fun=tidyverse_style, --indent_by=4]
+    -   id: roxygenize
+    # codemeta must be above use-tidy-description when both are used
+    # -   id: codemeta-description-updated
+    -   id: use-tidy-description
+    -   id: spell-check
+        exclude: >
+          (?x)^(
+          .*\.[rR]|
+          .*\.feather|
+          .*\.jpeg|
+          .*\.pdf|
+          .*\.png|
+          .*\.py|
+          .*\.RData|
+          .*\.rds|
+          .*\.Rds|
+          .*\.Rproj|
+          .*\.sh|
+          (.*/|)\.gitignore|
+          (.*/|)\.gitlab-ci\.yml|
+          (.*/|)\.lintr|
+          (.*/|)\.pre-commit-.*|
+          (.*/|)\.Rbuildignore|
+          (.*/|)\.Renviron|
+          (.*/|)\.Rprofile|
+          (.*/|)\.travis\.yml|
+          (.*/|)appveyor\.yml|
+          (.*/|)NAMESPACE|
+          (.*/|)renv/settings\.dcf|
+          (.*/|)renv\.lock|
+          (.*/|)WORDLIST|
+          \.github/workflows/.*|
+          data/.*|
+          )$
+    -   id: lintr
+        args: [--warn_only]
+        exclude: dev/.*|
+    -   id: readme-rmd-rendered
+    -   id: parsable-R
+    -   id: no-browser-statement
+    -   id: no-print-statement
+        exclude: dev/.*|
+    -   id: no-debug-statement
+    -   id: deps-in-desc
+        args: [--allow_private_imports]
+    -   id: pkgdown
+-   repo: https://github.com/pre-commit/pre-commit-hooks
+    rev: v4.6.0
+    hooks: 
+    -   id: check-added-large-files
+        args: ['--maxkb=200']
+    -   id: file-contents-sorter
+        files: '^\.Rbuildignore$'
+    -   id: end-of-file-fixer
+        exclude: '\.Rd'
+-   repo: https://github.com/pre-commit-ci/pre-commit-ci-config
+    rev: v1.6.1
+    hooks:
+    # Only required when https://pre-commit.ci is used for config validation
+    -   id: check-pre-commit-ci-config
+-   repo: local
+    hooks:
+    -   id: forbid-to-commit
+        name: Don't commit common R artifacts
+        entry: Cannot commit .Rhistory, .RData, .Rds or .rds.
+        language: fail
+        files: '\.(Rhistory|RData|Rds|rds)$'
+        # `exclude: <regex>` to allow committing specific files
+
+ci:
+    autoupdate_schedule: monthly
+    skip: [pkgdown]

DESCRIPTION

@@ -0,0 +1,22 @@
+Package: interface
+Type: Package
+Title: Interfaces for data validation and typing in R
+Version: 0.0.1
+Authors@R: 
+    person(given = "Dereck",
+           family = "Mezquita",
+           role = c("aut", "cre"),
+           email = "[email protected]",
+           comment = c(ORCID = "0000-0002-9307-6762"))
+Maintainer: Dereck Mezquita <[email protected]>
+Description: An easy to use TypeScript-like system for defining and implementing interfaces in R, with optional runtime type checking.
+License: MIT + file LICENSE
+Encoding: UTF-8
+LazyData: true
+VignetteBuilder: knitr
+RoxygenNote: 7.3.2
+Suggests:
+    testthat (>= 3.0.0),
+    knitr,
+    rmarkdown,
+    box

NAMESPACE

@@ -0,0 +1,8 @@
+# Generated by roxygen2: do not edit by hand
+
+S3method("$",validated_list)
+S3method(print,Interface)
+S3method(print,InterfaceImplementation)
+S3method(summary,Interface)
+export(implement)
+export(interface)

NEWS.md

@@ -0,0 +1,7 @@
+# interface 0.1.0
+
+- Initial CRAN submission.
+- Implemented core functionality for defining and implementing interfaces.
+- Added support for optional runtime type checking.
+- Included support for nested interfaces and custom validation functions.
+- Created comprehensive documentation and vignettes.

R/helpers.R

@@ -0,0 +1,57 @@
+# Helper function to check if a value matches a type specification
+check_type <- function(value, type_spec) {
+    if (identical(type_spec, "ANY")) {
+        return(TRUE)
+    } else if (inherits(type_spec, "Interface")) {
+        return(check_interface(value, type_spec))
+    } else if (is.character(type_spec)) {
+        if (type_spec %in% c("numeric", "integer", "logical", "character", "list")) {
+            return(inherits(value, type_spec))
+        } else {
+            stop(sprintf("Unsupported character type specification: %s", type_spec))
+        }
+    } else if (is.function(type_spec)) {
+        tryCatch(
+            {
+                result <- type_spec(value)
+                if (!is.logical(result) || length(result) != 1) {
+                    stop("Custom type check function must return a single logical value")
+                }
+                return(result)
+            },
+            error = function(e) {
+                stop(sprintf("Error in custom type check function: %s", e$message))
+            }
+        )
+    } else {
+        stop(sprintf("Unsupported type specification: %s", class(type_spec)[1]))
+    }
+}
+
+# Helper function to check if a value implements an interface
+check_interface <- function(value, interface) {
+    if (!is.list(value)) {
+        return(FALSE)
+    }
+    all(names(interface$properties) %in% names(value)) &&
+        all(mapply(check_type, value[names(interface$properties)], interface$properties))
+}
+
+# Validation function
+validate_object <- function(obj, interface) {
+    for (prop in names(interface$properties)) {
+        expected_type <- interface$properties[[prop]]
+        actual_value <- obj[[prop]]
+
+        if (!check_type(actual_value, expected_type)) {
+            stop(sprintf("Property '%s' does not match the expected type specification", prop))
+        }
+    }
+    return(TRUE)
+}
+
+# Custom accessor function
+custom_accessor <- function(x, i) {
+    validate_object(x, attr(x, "interface"))
+    x[[i]]
+}

R/implement.R

@@ -0,0 +1,58 @@
+#' Implement an Interface
+#'
+#' @param interface An Interface object
+#' @param ... Properties to implement the interface
+#' @param validate_on_access Logical, whether to validate on access
+#'
+#' @return An object implementing the interface
+#' @export
+implement <- function(interface, ..., validate_on_access = NULL, allow_extra = FALSE) {
+    obj <- list(...)
+
+    # Check if all required properties are present and not NULL
+    missing_props <- setdiff(names(interface$properties), names(obj))
+    null_props <- names(obj)[vapply(obj, is.null, logical(1))]
+    if (length(missing_props) > 0 || length(null_props) > 0) {
+        stop(paste(
+            "Missing or NULL properties:",
+            paste(c(missing_props, null_props), collapse = ", ")
+        ))
+    }
+
+    # Remove extra properties if not allowed
+    if (!allow_extra) {
+        extra_props <- setdiff(names(obj), names(interface$properties))
+        if (length(extra_props) > 0) {
+            obj <- obj[names(interface$properties)]
+            warning(paste("Removed extra properties:", paste(extra_props, collapse = ", ")))
+        }
+    }
+
+    # Initial validation
+    validate_object(obj, interface)
+
+    # Determine validate_on_access value
+    if (is.null(validate_on_access)) {
+        validate_on_access <- interface$validate_on_access
+    }
+
+    # Prepare class and attributes
+    class_name <- paste0(interface$interface_name, "Implementation")
+    classes <- c(class_name, "InterfaceImplementation", "list")
+
+    if (validate_on_access) {
+        classes <- c("validated_list", classes)
+    }
+
+    # Return the object with appropriate class and attributes
+    return(structure(
+        obj,
+        class = classes,
+        interface = interface,
+        validate_on_access = if (validate_on_access) TRUE else NULL,
+        allow_extra = allow_extra
+    ))
+}
+
+#' @export
+`$.validated_list` <- custom_accessor

R/interface.R

@@ -0,0 +1,25 @@
+#' Create an Interface
+#'
+#' @param interface_name A character string naming the interface
+#' @param ... Property definitions for the interface
+#' @param validate_on_access Logical, whether to validate on access by default
+#'
+#' @return An Interface object
+#' @export
+interface <- function(interface_name, ..., validate_on_access = FALSE) {
+    properties <- list(...)
+    structure(list(
+        interface_name = interface_name,
+        properties = properties,
+        validate_on_access = validate_on_access
+    ), class = "Interface")
+}
+
+# Internal function, no need to export
+Interface <- function(interface_name, properties, validate_on_access = FALSE) {
+    structure(list(
+        interface_name = interface_name,
+        properties = properties,
+        validate_on_access = validate_on_access
+    ), class = "Interface")
+}

R/print_methods.R

@@ -0,0 +1,47 @@
+#' @export
+print.InterfaceImplementation <- function(x, ...) {
+    interface <- attr(x, "interface")
+    cat("Object implementing", interface$interface_name, "interface:\n")
+    for (prop in names(x)) {
+        cat(sprintf("  %s: ", prop))
+        if (is.atomic(x[[prop]]) && length(x[[prop]]) == 1) {
+            cat(x[[prop]], "\n")
+        } else if (inherits(x[[prop]], "InterfaceImplementation")) {
+            cat("<", class(x[[prop]])[1], ">\n", sep = "")
+        } else {
+            cat("<", class(x[[prop]])[1], ">\n", sep = "")
+        }
+    }
+    cat(
+        "Validation on access:",
+        if (isTRUE(attr(x, "validate_on_access"))) "Enabled" else "Disabled",
+        "\n"
+    )
+    invisible(x)
+}
+
+#' @export
+print.Interface <- function(x, ...) {
+    cat("Interface:", x$interface_name, "\n")
+    cat("Properties:\n")
+    for (prop in names(x$properties)) {
+        prop_type <- x$properties[[prop]]
+        if (inherits(prop_type, "Interface")) {
+            cat(sprintf("  %s: <Interface %s>\n", prop, prop_type$interface_name))
+        } else if (is.function(prop_type)) {
+            cat(sprintf("  %s: <Custom Validator>\n", prop))
+        } else {
+            cat(sprintf("  %s: %s\n", prop, prop_type))
+        }
+    }
+    cat("Default validation on access:", if (x$validate_on_access) "Enabled" else "Disabled", "\n")
+    invisible(x)
+}
+
+#' @export
+summary.Interface <- function(object, ...) {
+    cat("Interface:", object$interface_name, "\n")
+    cat("Number of properties:", length(object$properties), "\n")
+    cat("Default validation on access:", if (object$validate_on_access) "Enabled" else "Disabled", "\n")
+    invisible(object)
+}