Merge pull request #9 from eoda-dev/dev

Dev

DESCRIPTION

@@ -22,6 +22,7 @@ Imports:
     rlang
 RoxygenNote: 7.3.2
 Suggests:
+    jsonlite,
     knitr,
     rmarkdown,
     testthat (>= 3.0.0)

NAMESPACE

@@ -9,6 +9,7 @@ export(check_args)
 export(is_any)
 export(is_rdantic_model)
 export(model_config)
+export(model_dump)
 export(model_field)
 export(model_validate)
 export(names_to_camel_case)

R/base-model.R

@@ -20,6 +20,7 @@ model_field <- function(fn, default = NA, alias = NULL, ...) {
 #' @param str_to_lower Convert all strings to lower case.
 #' @param ... **not used** at the moment
 #' @returns A model config object that can be used in [base_model()].
+#' @example examples/api/model-config.R
 #' @export
 model_config <- function(allow_extra = FALSE,
                          str_to_lower = FALSE, ...) {
@@ -226,36 +227,18 @@ check_assignment <- function(x, name, value) {
 # }
 
 # ---
-# TODO: Deprecated?, use single functions as 'model_exclude_na'
-model_dump <- function(obj,
-                       exclude = NULL,
-                       include = NULL,
-                       exclude_na = FALSE,
-                       exclude_null = FALSE,
-                       by_alias = FALSE) {
-  fields <- model_fields(obj)
-
-  if (is_not_null(exclude)) {
-    obj <- purrr::discard_at(obj, exclude)
-  }
-
-  if (is_not_null(include)) {
-    obj <- purrr::keep_at(obj, include)
-  }
-
-  if (isTRUE(exclude_na)) {
-    obj <- discard_this(obj, rlang::is_na)
-  }
-
-  if (isTRUE(exclude_null)) {
-    obj <- discard_this(obj, rlang::is_null)
-  }
-
+#' Convert model to base list
+#' @param obj An rdantic model object
+#' @param by_alias Use aliases for names.
+#' @param ... **not used** at the moment.
+#' @returns base list object
+#' @export
+model_dump <- function(obj, by_alias = FALSE, ...) {
   if (isTRUE(by_alias)) {
-    obj <- dump_by_alias(obj, fields)
+    return(dump_by_alias(obj))
   }
 
-  return(obj)
+  return(model_to_list(obj))
 }
 
 # ---

R/experimental.R

@@ -0,0 +1,34 @@
+# ---
+# TODO: Deprecated?, use single functions as 'model_exclude_na'
+model_dump_ <- function(obj,
+                       exclude = NULL,
+                       include = NULL,
+                       exclude_na = FALSE,
+                       exclude_null = FALSE,
+                       by_alias = FALSE) {
+  fields <- model_fields(obj)
+
+  if (is_not_null(exclude)) {
+    obj <- purrr::discard_at(obj, exclude)
+  }
+
+  if (is_not_null(include)) {
+    obj <- purrr::keep_at(obj, include)
+  }
+
+  if (isTRUE(exclude_na)) {
+    obj <- discard_this(obj, rlang::is_na)
+  }
+
+  if (isTRUE(exclude_null)) {
+    obj <- discard_this(obj, rlang::is_null)
+  }
+
+  if (isTRUE(by_alias)) {
+    obj <- dump_by_alias(obj, fields)
+  } else {
+    obj <- model_to_list(obj)
+  }
+
+  return(obj)
+}

R/helpers.R

@@ -91,17 +91,31 @@ dump_by_alias <- function(obj, fields = NULL) {
     fields <- model_fields(obj)
   }
 
-  l = list()
+  l <- list()
   for (name in names(obj)) {
     alias <- fields[[name]]$alias
     value <- obj[[name]]
     new_name <- ifelse(is.null(alias), name, alias)
     if (inherits(value, CLASS_RDANTIC)) {
-      l[[new_name]] <- by_alias(value)
+      l[[new_name]] <- dump_by_alias(value)
     } else {
       l[[new_name]] <- value
     }
   }
 
   return(l)
 }
+
+# ---
+model_to_list <- function(obj) {
+  l <- list()
+  for (name in names(obj)) {
+    value <- obj[[name]]
+    if (is.list(value)) {
+      l[[name]] <- model_to_list(value)
+    } else {
+      l[[name]] <- unclass(value)
+    }
+  }
+  return(l)
+}

examples/advanced-json.R

@@ -0,0 +1,21 @@
+json_str <- '{
+  "statusCode": 200,
+  "df": [
+    {"aA": 1, "b": 2.2},
+    {"aA": 4, "b": 4.5}
+  ]
+}'
+
+df_model <- base_model(
+  a_a = is.integer,
+  b = is.double
+)
+
+my_model <- base_model(
+  status_code = is.integer,
+  df = ~ is.data.frame(df_model(.x = .x))
+)
+
+jsonlite::fromJSON(json_str) |>
+  names_to_snake_case() |>
+  model_validate(my_model)

examples/api/model-config.R

@@ -0,0 +1,9 @@
+cfg <- model_config(str_to_lower = TRUE)
+
+my_model <- base_model(
+  bar = is.character,
+  foo = is.character,
+  .model_config = cfg
+)
+
+my_model(bar = "FOO", foo = "BAR")

vignettes/rdantic.Rmd

@@ -27,10 +27,12 @@ person_model <- base_model(
   age = is_scalar_integer
 )
 
-person_model(
+(m <- person_model(
   name = "Lee",
   age = 100L
-)
+))
+
+try(m$age <- 100)
 
 try(person_model(name = "Lee", age = 100))
 
@@ -112,6 +114,44 @@ external_data |>
   model_validate(api_model)
 ```
 
+## From JSON
+
+```{r}
+json_str <- '
+{
+  "a": 10,
+  "b": 20,
+  "l": [1, 2, 3]
+}'
+
+json_model <- base_model(
+  a = is_scalar_integer,
+  b = is_scalar_integer,
+  l = is.integer
+)
+
+jsonlite::fromJSON(json_str) |>
+  model_validate(json_model)
+
+json_str <- '{"a": 10, "b": 20.5, "l": [1, 2, 3]}'
+
+try(jsonlite::fromJSON(json_str) |> model_validate(json_model))
+```
+
+## To JSON
+
+```{r}
+my_model <- base_model(
+  status_code = model_field(is_scalar_integer, alias = "statusCode"),
+  x = ~ is.integer(.x) && length(.x) == 3,
+  y = ~ is.integer(.x) && length(.x) == 3
+)
+
+my_model(status_code = 200L, x = 1:3, y = 4:6) |>
+  model_dump(by_alias = TRUE) |>
+  jsonlite::toJSON(auto_unbox = TRUE)
+```
+
 ## Type safety of function arguments
 
 ```{r}