tests/tests.R

In sakura: Extension to R Serialization

# minitest - a minimal testing framework v0.0.2 --------------------------------
test_library <- function(package) library(package = package, character.only = TRUE)
test_true <- function(x) invisible(isTRUE(x) || {print(x); stop("the above was returned instead of TRUE")})
test_null <- function(x) invisible(is.null(x) || {print(x); stop("the above was returned instead of NULL")})
test_notnull <- function(x) invisible(!is.null(x) || stop("returns NULL when expected to be not NULL"))
test_zero <- function(x) invisible(x == 0L || {print(x); stop("the above was returned instead of 0L")})
test_type <- function(type, x) invisible(typeof(x) == type || {stop("object of type '", typeof(x), "' was returned instead of '", type, "'")})
test_class <- function(class, x) invisible(inherits(x, class) || {stop("object of class '", paste(class(x), collapse = ", "), "' was returned instead of '", class, "'")})
test_equal <- function(a, b) invisible(a == b || {print(a); print(b); stop("the above expressions were not equal")})
test_identical <- function(a, b) invisible(identical(a, b) || {print(a); print(b); stop("the above expressions were not identical")})
test_print <- function(x) invisible(is.character(capture.output(print(x))) || stop("print output of expression cannot be captured as a character value"))
test_error <- function(x, containing = "") invisible(inherits(x <- tryCatch(x, error = identity), "error") && grepl(containing, x[["message"]], fixed = TRUE) || stop("Expected error message containing: ", containing, "\nActual error message: ", x[["message"]]))
# ------------------------------------------------------------------------------

test_library("sakura")
df <- data.frame(a = 1, b = "a")
test_type("raw", serialize(df))
test_class("data.frame", unserialize(serialize(df)))
test_identical(unserialize(serialize(df)), df)
test_error(unserialize(raw(1)), "data could not be unserialized")

# mock torch serialization
torch_serialize <- function(x) {
  lapply(x, charToRaw)
}
torch_load <- function(x) {
  lapply(x, rawToChar)
}
cfg <- serial_config(
  class = "torch_tensor",
  sfunc = torch_serialize,
  ufunc = torch_load,
  vec = TRUE
)
test_type("pairlist", cfg)
obj <- list(tensor = "a very long tensor", vector = runif(1000L))
class(obj) <- "torch_tensor"
vec <- serialize(obj, cfg)
test_type("raw", vec)
test_true(identical(unserialize(vec, cfg), obj))

if (requireNamespace("arrow", quietly = TRUE)) {
  cfga <- serial_config(
    "ArrowTabular",
    arrow::write_to_raw,
    function(x) arrow::read_ipc_stream(x, as_data_frame = FALSE)
  )
  test_type("pairlist", cfga)
  test_type("raw", serialize(obj, cfga))
  x <- list(arrow::as_arrow_table(iris), arrow::as_arrow_table(mtcars))
  vec <- serialize(x, cfga)
  test_type("raw", vec)
  test_true(all.equal(unserialize(vec, cfga), x))
}