262 lines
7.3 KiB
R
262 lines
7.3 KiB
R
#' Typed object
|
|
#'
|
|
#' This is the base type for all typed objects. It is not meant to be used directly.
|
|
#'
|
|
#' @param input_type The type of the object that Typescript expect to send to R.
|
|
#' @param return_type The type of the object that Typescript expects to recieve from R.
|
|
#' @param default The default value of the object.
|
|
#' @param check A function that checks the object and returns it if it is valid. This operates on the R side and is mostly for development and debugging purposes. It is up to the developer to ensure that all functions return the correct type of object always.
|
|
#' @param generic logical, if `TRUE` then the object is a generic type.
|
|
#'
|
|
#' @md
|
|
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) {
|
|
e$attributes[[name]] <- value
|
|
}
|
|
|
|
class(e) <- c("ts_object", class(e))
|
|
e
|
|
}
|
|
|
|
#' @export
|
|
print.ts_object <- function(x, ...) {
|
|
# name <- deparse(substitute(x))
|
|
cli::cli_ul()
|
|
cli::cli_h3("Input type: ")
|
|
if (nchar(x$input_type) > 50) {
|
|
cat(js::uglify_reformat(x$input_type, beautify = TRUE), "\n")
|
|
} else {
|
|
cat(x$input_type, "\n")
|
|
}
|
|
cli::cli_h3("Return type: ")
|
|
if (nchar(x$return_type) > 50) {
|
|
cat(js::uglify_reformat(x$return_type, beautify = TRUE), "\n")
|
|
} else {
|
|
cat(x$return_type, "\n")
|
|
}
|
|
cli::cli_end()
|
|
}
|
|
|
|
#' @describeIn object Check if an object is a ts object
|
|
#' @export
|
|
is_ts_object <- function(x) {
|
|
inherits(x, "ts_object")
|
|
}
|
|
|
|
ts_union <- function(...) sprintf("z.union([%s])", paste(..., sep = ", "))
|
|
ts_array <- function(type = c("z.number()", "z.boolean()", "z.string()")) {
|
|
if (type == "z.number()") {
|
|
return("z.instanceof(Float64Array)")
|
|
}
|
|
if (type == "z.boolean()") {
|
|
return("z.instanceof(Uint8Array)")
|
|
}
|
|
return("Robj.character(0)")
|
|
}
|
|
|
|
n_type <- function(n, type, pl = ts_array(type)) {
|
|
if (n == 1) {
|
|
return(type)
|
|
}
|
|
if (n == -1) {
|
|
return(ts_union(type, pl))
|
|
}
|
|
pl
|
|
}
|
|
n_type_fun <- function(n, type) {
|
|
sprintf("%s(%s)", type, ifelse(n < 0, "", n))
|
|
}
|
|
|
|
#' @export
|
|
ts_logical <- function(n = -1L) {
|
|
ts_object(
|
|
n_type(n, "z.boolean()"),
|
|
n_type_fun(n, "Robj.logical"),
|
|
check = function(x) {
|
|
if (!is.logical(x)) stop("Expected a boolean")
|
|
if (n > 0 && length(x) != n) {
|
|
stop("Expected a boolean of length ", n)
|
|
}
|
|
x
|
|
}
|
|
)
|
|
}
|
|
|
|
#' @export
|
|
ts_integer <- function(n = -1L) {
|
|
ts_object(
|
|
n_type(n, "z.number()"),
|
|
n_type_fun(n, "Robj.integer"),
|
|
check = function(x) {
|
|
if (!is.integer(x)) stop("Expected an integer")
|
|
if (n > 0 && length(x) != n) {
|
|
stop("Expected an integer of length ", n)
|
|
}
|
|
x
|
|
}
|
|
)
|
|
}
|
|
|
|
#' @export
|
|
ts_numeric <- function(n = -1L) {
|
|
ts_object(
|
|
n_type(n, "z.number()"),
|
|
n_type_fun(n, "Robj.numeric"),
|
|
check = function(x) {
|
|
if (!is.numeric(x)) stop("Expected a number", call. = FALSE)
|
|
if (n > 0 && length(x) != n) {
|
|
stop("Expected a number of length ", n, , call. = FALSE)
|
|
}
|
|
x
|
|
}
|
|
)
|
|
}
|
|
|
|
#' @export
|
|
ts_character <- function(n = -1L) {
|
|
ts_object(
|
|
n_type(n, "z.string()"),
|
|
n_type_fun(n, "Robj.character"),
|
|
check = function(x) {
|
|
if (!is.character(x)) stop("Expected a string")
|
|
if (n > 0 && length(x) != n) stop("Expected a string of length ", n)
|
|
x
|
|
}
|
|
)
|
|
}
|
|
|
|
vector_as_ts_array <- function(x) {
|
|
paste("[\"", paste(x, collapse = "\", \""), "\"]", sep = "")
|
|
}
|
|
|
|
#' Typed factor
|
|
#'
|
|
#' Factors are integers with labels. On the JS side, these are *always* represented as a string array (even if only one value - yay!).
|
|
#'
|
|
#' @param levels A character vector of levels (optional).
|
|
#'
|
|
#' @export
|
|
#' @md
|
|
ts_factor <- function(levels = NULL) {
|
|
ts_object(
|
|
ifelse(is.null(levels),
|
|
ts_array("z.string()"),
|
|
sprintf("(%s)[]", paste(levels, collapse = " | "))
|
|
),
|
|
if (is.null(levels)) {
|
|
"Robj.factor()"
|
|
} else {
|
|
sprintf("Robj.factor(%s)", vector_as_ts_array(levels))
|
|
},
|
|
check = function(x) {
|
|
if (!is.factor(x)) stop("Expected a factor")
|
|
if (!is.null(levels) && !identical(levels, levels(x))) {
|
|
stop(
|
|
"Expected a factor with levels: ",
|
|
paste(levels, collapse = ", ")
|
|
)
|
|
}
|
|
x
|
|
}
|
|
)
|
|
}
|
|
|
|
# table?
|
|
|
|
#' 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 <- list(...)
|
|
|
|
type <- "z.union([z.object({}), z.array(z.any())])"
|
|
type_fn <- ""
|
|
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))) {
|
|
type <- sprintf(
|
|
"{ %s }",
|
|
paste(names(values), types, sep = ": ", collapse = ", ")
|
|
)
|
|
type_fn <- sprintf(
|
|
"{ %s }",
|
|
paste(names(values), type_funs, sep = ": ", collapse = ", ")
|
|
)
|
|
} else {
|
|
type <- sprintf("[%s]", paste(types, collapse = ", "))
|
|
type_fn <- sprintf("[%s]", paste(type_funs, collapse = ", "))
|
|
}
|
|
}
|
|
|
|
ts_object(
|
|
type,
|
|
ifelse(type_fn == "", "Robj.list()",
|
|
sprintf("Robj.list(%s)", type_fn)
|
|
),
|
|
check = function(x) {
|
|
if (!is.list(x)) stop("Expected a list")
|
|
if (!is.null(values)) {
|
|
if (!is.null(names(values))) {
|
|
if (!identical(names(x), names(values))) {
|
|
stop(
|
|
"Expected a list with names: ",
|
|
paste(names(values), collapse = ", ")
|
|
)
|
|
}
|
|
}
|
|
for (i in seq_along(values)) {
|
|
values[[i]]$check(x[[i]])
|
|
}
|
|
}
|
|
x
|
|
}
|
|
)
|
|
}
|
|
|
|
|
|
#' Typed dataframe
|
|
#'
|
|
#' This is essentially a list, but the elements must have names and are all the same length.
|
|
#'
|
|
#' @export
|
|
#' @md
|
|
ts_dataframe <- function(...) {
|
|
values <- list(...)
|
|
type <- "z.record(z.string(), z.any())"
|
|
type_fn <- ""
|
|
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))) stop("Expected named elements")
|
|
|
|
type <- sprintf(
|
|
"z.object({\n %s\n})",
|
|
paste(names(values), types, sep = ": ", collapse = ",\n ")
|
|
)
|
|
type_fn <- sprintf(
|
|
"{\n %s\n}",
|
|
paste(names(values), type_funs, sep = ": ", collapse = ",\n ")
|
|
)
|
|
}
|
|
|
|
ts_object(
|
|
type,
|
|
sprintf("R.dataframe(%s)", type_fn),
|
|
check = function(x) {
|
|
if (!is.data.frame(x)) stop("Expected a data frame")
|
|
x
|
|
}
|
|
)
|
|
}
|