diff --git a/R/function.R b/R/function.R index 37fa9fb..e328d0b 100644 --- a/R/function.R +++ b/R/function.R @@ -51,7 +51,7 @@ ts_result <- function(type, value) { #' @export ts_function <- function(f, ..., result = NULL) { args <- list(...) - if (!is.null(result) && !is_object(result)) { + if (!is.null(result) && !is_ts_object(result)) { stop("Invalid return type") } diff --git a/R/types.R b/R/types.R index 0e77ca0..3dd65c2 100644 --- a/R/types.R +++ b/R/types.R @@ -9,11 +9,11 @@ #' @param generic logical, if `TRUE` then the object is a generic type. #' #' @md -object <- function(input_type = "any", - return_type = "any", - default = NULL, - check = function() stop("Not implemented"), - generic = FALSE) { +ts_object <- function(input_type = "any", + return_type = "any", + default = NULL, + check = function() stop("Not implemented"), + generic = FALSE) { e <- environment() e$attr <- function(name, value) { @@ -43,7 +43,9 @@ print.ts_object <- function(x, ...) { cli::cli_end() } -is_object <- function(x) { +#' @describeIn object Check if an object is a ts object +#' @export +is_ts_object <- function(x) { inherits(x, "ts_object") } @@ -73,7 +75,7 @@ n_type_fun <- function(n, type) { #' @export ts_logical <- function(n = -1L) { - object( + ts_object( n_type(n, "z.boolean()"), n_type_fun(n, "Robj.logical"), check = function(x) { @@ -88,7 +90,7 @@ ts_logical <- function(n = -1L) { #' @export ts_integer <- function(n = -1L) { - object( + ts_object( n_type(n, "z.number()"), n_type_fun(n, "Robj.integer"), check = function(x) { @@ -103,7 +105,7 @@ ts_integer <- function(n = -1L) { #' @export ts_numeric <- function(n = -1L) { - object( + ts_object( n_type(n, "z.number()"), n_type_fun(n, "Robj.numeric"), check = function(x) { @@ -118,7 +120,7 @@ ts_numeric <- function(n = -1L) { #' @export ts_character <- function(n = -1L) { - object( + ts_object( n_type(n, "z.string()"), n_type_fun(n, "Robj.character"), check = function(x) { @@ -142,7 +144,7 @@ vector_as_ts_array <- function(x) { #' @export #' @md ts_factor <- function(levels = NULL) { - object( + ts_object( ifelse(is.null(levels), ts_array("z.string()"), sprintf("(%s)[]", paste(levels, collapse = " | ")) @@ -170,13 +172,16 @@ ts_factor <- function(levels = NULL) { #' Typed list #' #' A list is a vector of other robjects, which may or may not be named. +#' @param ... A list of types, named or unnamed. #' #' @export #' @md -ts_list <- function(values = NULL) { +ts_list <- function(...) { + values <- list(...) + type <- "z.union([z.object({}), z.array(z.any())])" type_fn <- "" - if (!is.null(values)) { + if (length(values)) { types <- sapply(values, function(x) x$input_type) type_funs <- sapply(values, function(x) x$return_type) if (!is.null(names(values))) { @@ -194,7 +199,7 @@ ts_list <- function(values = NULL) { } } - object( + ts_object( type, ifelse(type_fn == "", "Robj.list()", sprintf("Robj.list(%s)", type_fn) @@ -245,7 +250,7 @@ ts_dataframe <- function(...) { ) } - object( + ts_object( type, sprintf("R.dataframe(%s)", type_fn), check = function(x) { diff --git a/tests/testthat/test-basic-types.R b/tests/testthat/test-basic-types.R index 88a5e7f..7570524 100644 --- a/tests/testthat/test-basic-types.R +++ b/tests/testthat/test-basic-types.R @@ -84,17 +84,17 @@ test_that("list type - default", { }) test_that("list type - named", { - x <- ts_list(list(a = ts_integer(1), b = ts_numeric(1))) + x <- ts_list(a = ts_integer(1), b = ts_numeric(1)) expect_equal(x$check(list(a = 1L, b = 2)), list(a = 1L, b = 2)) expect_error(x$check(1)) expect_error(x$check(list())) }) test_that("list type - unnamed", { - x <- ts_list(list( + x <- ts_list( ts_integer(1), ts_character(1), - ts_list(list(a = ts_integer(1))) - )) + ts_list(a = ts_integer(1)) + ) expect_equal(x$check(list( 1L, "a", list(a = 1L)