tom/ts
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

renaming; change from values to ... for list()

Browse Source
This commit is contained in:
Tom Elliott 2025-01-09 15:11:03 +13:00
parent 1a3d6de032
commit 9be1c72a03
3 changed files with 25 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
R/function.R
View File

@ -51,7 +51,7 @@ ts_result <- function(type, value) {
#' @export #' @export
ts_function <- function(f, ..., result = NULL) { ts_function <- function(f, ..., result = NULL) {
args <- list(...) args <- list(...)
if (!is.null(result) && !is_object(result)) { if (!is.null(result) && !is_ts_object(result)) {
stop("Invalid return type") stop("Invalid return type")
} }

35
R/types.R
View File

@ -9,11 +9,11 @@
#' @param generic logical, if `TRUE` then the object is a generic type. #' @param generic logical, if `TRUE` then the object is a generic type.
#' #'
#' @md #' @md
object <- function(input_type = "any", ts_object <- function(input_type = "any",
return_type = "any", return_type = "any",
default = NULL, default = NULL,
check = function() stop("Not implemented"), check = function() stop("Not implemented"),
generic = FALSE) { generic = FALSE) {
e <- environment() e <- environment()
e$attr <- function(name, value) { e$attr <- function(name, value) {
@ -43,7 +43,9 @@ print.ts_object <- function(x, ...) {
cli::cli_end() 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") inherits(x, "ts_object")
} }
@ -73,7 +75,7 @@ n_type_fun <- function(n, type) {
#' @export #' @export
ts_logical <- function(n = -1L) { ts_logical <- function(n = -1L) {
object( ts_object(
n_type(n, "z.boolean()"), n_type(n, "z.boolean()"),
n_type_fun(n, "Robj.logical"), n_type_fun(n, "Robj.logical"),
check = function(x) { check = function(x) {
@ -88,7 +90,7 @@ ts_logical <- function(n = -1L) {
#' @export #' @export
ts_integer <- function(n = -1L) { ts_integer <- function(n = -1L) {
object( ts_object(
n_type(n, "z.number()"), n_type(n, "z.number()"),
n_type_fun(n, "Robj.integer"), n_type_fun(n, "Robj.integer"),
check = function(x) { check = function(x) {
@ -103,7 +105,7 @@ ts_integer <- function(n = -1L) {
#' @export #' @export
ts_numeric <- function(n = -1L) { ts_numeric <- function(n = -1L) {
object( ts_object(
n_type(n, "z.number()"), n_type(n, "z.number()"),
n_type_fun(n, "Robj.numeric"), n_type_fun(n, "Robj.numeric"),
check = function(x) { check = function(x) {
@ -118,7 +120,7 @@ ts_numeric <- function(n = -1L) {
#' @export #' @export
ts_character <- function(n = -1L) { ts_character <- function(n = -1L) {
object( ts_object(
n_type(n, "z.string()"), n_type(n, "z.string()"),
n_type_fun(n, "Robj.character"), n_type_fun(n, "Robj.character"),
check = function(x) { check = function(x) {
@ -142,7 +144,7 @@ vector_as_ts_array <- function(x) {
#' @export #' @export
#' @md #' @md
ts_factor <- function(levels = NULL) { ts_factor <- function(levels = NULL) {
object( ts_object(
ifelse(is.null(levels), ifelse(is.null(levels),
ts_array("z.string()"), ts_array("z.string()"),
sprintf("(%s)[]", paste(levels, collapse = " | ")) sprintf("(%s)[]", paste(levels, collapse = " | "))
@ -170,13 +172,16 @@ ts_factor <- function(levels = NULL) {
#' Typed list #' Typed list
#' #'
#' A list is a vector of other robjects, which may or may not be named. #' A list is a vector of other robjects, which may or may not be named.
#' @param ... A list of types, named or unnamed.
#' #'
#' @export #' @export
#' @md #' @md
ts_list <- function(values = NULL) { ts_list <- function(...) {
values <- list(...)
type <- "z.union([z.object({}), z.array(z.any())])" type <- "z.union([z.object({}), z.array(z.any())])"
type_fn <- "" type_fn <- ""
if (!is.null(values)) { if (length(values)) {
types <- sapply(values, function(x) x$input_type) types <- sapply(values, function(x) x$input_type)
type_funs <- sapply(values, function(x) x$return_type) type_funs <- sapply(values, function(x) x$return_type)
if (!is.null(names(values))) { if (!is.null(names(values))) {
@ -194,7 +199,7 @@ ts_list <- function(values = NULL) {
} }
} }
object( ts_object(
type, type,
ifelse(type_fn == "", "Robj.list()", ifelse(type_fn == "", "Robj.list()",
sprintf("Robj.list(%s)", type_fn) sprintf("Robj.list(%s)", type_fn)
@ -245,7 +250,7 @@ ts_dataframe <- function(...) {
) )
} }
object( ts_object(
type, type,
sprintf("R.dataframe(%s)", type_fn), sprintf("R.dataframe(%s)", type_fn),
check = function(x) { check = function(x) {

8
tests/testthat/test-basic-types.R
View File

@ -84,17 +84,17 @@ test_that("list type - default", {
}) })
test_that("list type - named", { 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_equal(x$check(list(a = 1L, b = 2)), list(a = 1L, b = 2))
expect_error(x$check(1)) expect_error(x$check(1))
expect_error(x$check(list())) expect_error(x$check(list()))
}) })
test_that("list type - unnamed", { test_that("list type - unnamed", {
x <- ts_list(list( x <- ts_list(
ts_integer(1), ts_character(1), ts_integer(1), ts_character(1),
ts_list(list(a = ts_integer(1))) ts_list(a = ts_integer(1))
)) )
expect_equal(x$check(list( expect_equal(x$check(list(
1L, "a", 1L, "a",
list(a = 1L) list(a = 1L)