tests/testthat/test-models_utils.R

In gipsDA: Training DA Models Utilizing 'gips'

# ==============================================================================
# Global Setup for this file
# ==============================================================================

setup_data <- function() {
  data(iris)
  local_iris <- iris
  local_iris$Species <- as.numeric(local_iris$Species)
  groups <- split(local_iris[, 1:4], local_iris$Species)

  covs <- lapply(groups, cov)
  ns <- sapply(groups, nrow)

  return(list(covs = covs, ns = ns))
}

# ==============================================================================
# GROUP 1: Serialization Tests (JSON Logic)
# ==============================================================================

test_that("recursive_length calculates depth correctly", {
  expect_equal(recursive_length(c(1, 2, 3)), 3)

  nested <- list(a = 1, b = list(c = 2, d = 3), e = 4)
  expect_equal(recursive_length(nested), 4)
  expect_equal(recursive_length(list()), 0)

  func <- function(x) {
    x + 1
  }
  expect_equal(recursive_length(func), 0)
})

test_that("Serialization handles basic types (Matrix, Formula)", {
  original_data <- list(
    mat = matrix(1:4, nrow = 2),
    form = Species ~ Sepal.Length
  )

  serialized <- serialize_for_json(original_data)
  restored <- deserialize_from_json(serialized)

  expect_true(is.matrix(restored$mat))
  expect_equal(restored$mat, original_data$mat)
  expect_equal(format(restored$form), format(original_data$form))
})

test_that("serialize_for_json works with gips_perm class and formulas", {
  fake_perm <- list(1L, 2L, 3L)
  class(fake_perm) <- "gips_perm"

  attr(fake_perm, "size") <- 3L

  result <- serialize_for_json(fake_perm)

  expect_equal(result$`__type`, "gips_perm")
  expect_equal(result$size, 3)

  fake_formula <- list("x", "y")
  class(fake_formula) <- "formula"

  result <- serialize_for_json(fake_formula)

  expect_equal(result$`__type`, "formula")
})

test_that("deserialize_from_json works with gips_perm class and formulas", {
  json_input_perm <- list(
    `__type` = "gips_perm",
    value = "(1)(2)",
    size = 2L
  )

  real_perm_obj <- deserialize_from_json(json_input_perm)
  expect_s3_class(real_perm_obj, "gips_perm")

  json_input_form <- list(
    `__type` = "formula",
    value = "Species ~ ."
  )

  real_form_obj <- deserialize_from_json(json_input_form)
  expect_s3_class(real_form_obj, "formula")
})

test_that("gipsDA_to_json and gipsDA_from_json perform full file round-trip", {
  temp_file <- tempfile(fileext = ".json")
  # Ensure cleanup happens even if test fails
  on.exit(unlink(temp_file))

  complex_obj <- list(
    covs = list(matrix(rnorm(4), 2, 2)),
    model_formula = y ~ x + z,
    meta = list(version = 1.0)
  )
  class(complex_obj) <- "my_gips_DA"

  gipsDA_to_json(complex_obj, temp_file)

  expect_true(file.exists(temp_file))

  restored_obj <- gipsDA_from_json(temp_file, classname = "my_gips_DA")

  expect_s3_class(restored_obj, "my_gips_DA")
  expect_type(restored_obj$covs, "list")
  expect_true(is.matrix(restored_obj$covs[[1]]))
})


# ==============================================================================
# GROUP 2: Projection Logic Tests
# ==============================================================================

test_that("project_matrix_multiperm returns weighted average matrix", {
  emp_cov <- matrix(c(
    4, 2, 0, 1,
    2, 3, 1, 0,
    0, 1, 2, 1,
    1, 0, 1, 5
  ), nrow = 4, byrow = TRUE)
  probs <- c("(1,2,3)" = 0.5, "(2,3,4)" = 0.5)

  res <- project_matrix_multiperm(emp_cov, probs)

  expect_true(is.matrix(res))
  expect_equal(dim(res), dim(emp_cov))
})

test_that("project_covs (MAP=TRUE) returns correct structure using Iris data", {
  d <- setup_data()

  res <- project_covs(d$covs, d$ns, MAP = TRUE, optimizer = "BF", max_iter = 10)

  expect_type(res, "list")
  # expect_named checks names directly
  expect_named(res, c("covs", "opt_info"))

  expect_type(res$covs, "list")
  # expect_length checks list size directly
  expect_length(res$covs, 3)

  expect_equal(dim(res$covs[[1]]), c(4, 4))
  expect_true(is.matrix(res$covs[[1]]))
  expect_false(is.null(res$opt_info))
})

test_that("project_covs (MAP=FALSE) handles probabilities using Iris data", {
  d <- setup_data()

  res <- project_covs(d$covs, d$ns, MAP = FALSE, optimizer = "BF", max_iter = 10)

  expect_type(res, "list")
  expect_named(res, c("covs", "opt_info"))

  # Check if numeric OR list (simple OR logic logic)
  expect_true(is.numeric(res$opt_info) || is.list(res$opt_info))

  expect_length(res$covs, 3)
  expect_equal(dim(res$covs[[2]]), c(4, 4))
})

test_that("project_covs warns if all probabilities are below tolerance", {
  d <- setup_data()

  expect_warning(
    project_covs(d$covs, d$ns, MAP = FALSE, optimizer = "MH", max_iter = 5, tol = 2.0),
    regexp = "There are no perms with estimated probability above threshold"
  )
})