tests/testthat/test-fix-FIX3.R

In Nestimate: Network Estimation, Bootstrap, and Higher-Order Analysis

# =========================================================================
# Regression tests for FIX-3 (audit A04 — simplicial / hypergraph)
#
# Confirmed findings fixed:
#   A04-F01  build_simplicial(type="vr") was byte-identical to "clique"
#            (no real Vietoris-Rips filtration existed). Initial honest-enum
#            decision: type="vr"/"rips" stop() with a clear message rather
#            than silently aliasing. Resolved (2026-05-20): a genuine VR
#            filtration is now implemented (input is a non-negative distance
#            matrix; k-simplex enters at max pairwise distance in σ). The
#            regression these tests guard is the *silent-alias* one: VR
#            must produce structurally distinct output from clique and must
#            attach a $filtration vector.
#   A04-F02  build_hypergraph(method="vr") inherited the same dead alias.
#            Same honest fix (errors before reaching build_simplicial()).
#   A04-F03  build_simplicial(max_dim<0) silently behaved like the default
#            (igraph treats max=0 as unbounded). Now stopifnot() guarded.
#   A04-F04  persistent_homology(n_steps=0) silently returned a degenerate
#            object. Now stopifnot(n_steps >= 1L).
#   A04-F05  build_simplicial(threshold<0) silently accepted. Now guarded.
#
# Data: a netobject derived from bundled group_regulation_long, plus
# simulate_hypergraph_incidence() for hypergraph-shaped inputs.
# =========================================================================

# --- shared fixtures ----------------------------------------------------

.fix3_net <- function() {
  e <- new.env()
  utils::data("group_regulation_long", package = "Nestimate", envir = e)
  build_network(e$group_regulation_long, actor = "Actor", time = "Time",
                action = "Action", method = "relative")
}

.fix3_incidence_adj <- function(seed = 42L) {
  hgi <- simulate_hypergraph_incidence(n_nodes = 10, n_edges = 14,
                                       edge_size_range = c(2L, 3L),
                                       density = 0.85, seed = seed)
  inc <- hgi$incidence
  # node x node co-membership adjacency from the incidence matrix
  adj <- inc %*% t(inc)
  diag(adj) <- 0
  adj[adj > 0] <- 1
  storage.mode(adj) <- "double"
  adj
}

# =========================================================================
# A04-F01 — build_simplicial(type="vr") must error, not alias "clique"
# =========================================================================

test_that("build_simplicial(type='vr') is a real VR filtration, not clique", {
  net <- .fix3_net()
  # Use the netobject's weights as similarities; convert to distances.
  w <- abs(net$weights); diag(w) <- 0
  d <- max(w) - w
  diag(d) <- 0

  sc_vr     <- build_simplicial(d,   type = "vr",     max_scale = max(d))
  sc_clique <- build_simplicial(net, type = "clique", threshold = 0.05)
  expect_s3_class(sc_vr, "simplicial_complex")
  expect_identical(sc_vr$type, "vr")
  expect_identical(sc_clique$type, "clique")

  # VR carries a filtration vector; clique does not.
  expect_true(is.numeric(sc_vr$filtration))
  expect_equal(length(sc_vr$filtration), length(sc_vr$simplices))
  expect_null(sc_clique$filtration)

  # The silent-alias regression: VR must be distinguishable from clique on
  # the same node set. With a non-uniform similarity matrix the simplex
  # filtrations differ even when the underlying simplex sets coincide.
  if (length(sc_vr$simplices) == length(sc_clique$simplices)) {
    # Both reached the same max_dim and adjacency; filtration distinguishes.
    expect_true(any(sc_vr$filtration > 0))
  } else {
    expect_true(TRUE)  # different simplex counts is its own proof
  }
})

test_that("type='rips' aliases 'vr' (no silent clique fallback)", {
  d <- matrix(c(0, 0.2, 0.3,
                0.2, 0, 0.4,
                0.3, 0.4, 0), 3, 3, byrow = TRUE)
  rownames(d) <- colnames(d) <- c("A","B","C")
  sc_vr   <- build_simplicial(d, type = "vr",   max_scale = 0.5)
  sc_rips <- build_simplicial(d, type = "rips", max_scale = 0.5)
  expect_identical(sc_vr$type, sc_rips$type)
  expect_equal(sc_vr$filtration, sc_rips$filtration)
})

test_that("print.simplicial_complex labels VR honestly", {
  net <- .fix3_net()
  sc_clique <- build_simplicial(net, type = "clique", threshold = 0.05)
  out_c <- capture.output(print(sc_clique))
  expect_true(any(grepl("Clique Complex", out_c)))
  expect_false(any(grepl("Vietoris-Rips", out_c)))

  w <- abs(net$weights); diag(w) <- 0
  d <- max(w) - w; diag(d) <- 0
  sc_vr <- build_simplicial(d, type = "vr", max_scale = max(d))
  out_v <- capture.output(print(sc_vr))
  expect_true(any(grepl("Vietoris-Rips Complex", out_v)))
  expect_false(any(grepl("Clique Complex", out_v)))
})

# =========================================================================
# A04-F02 — build_hypergraph(method="vr") inherits the honest fix
# =========================================================================

test_that("build_hypergraph(method='vr') errors and is NOT silently clique", {
  net <- .fix3_net()

  expect_error(
    build_hypergraph(net, method = "vr", max_size = 3L),
    "not implemented",
    fixed = TRUE
  )
  expect_error(
    build_hypergraph(net, method = "rips", max_size = 3L),
    "not implemented",
    fixed = TRUE
  )

  msg <- tryCatch(build_hypergraph(net, method = "vr"),
                  error = function(e) conditionMessage(e))
  expect_false(grepl("'arg' should be one of", msg))
  expect_true(grepl("Vietoris-Rips", msg, fixed = TRUE))

  # clique still works.
  hg <- build_hypergraph(net, method = "clique", max_size = 3L)
  expect_s3_class(hg, "net_hypergraph")
  expect_identical(hg$params$method, "clique")
})

test_that("build_hypergraph(method='vr') errors on incidence-derived adj", {
  adj <- .fix3_incidence_adj(seed = 7L)
  expect_error(
    build_hypergraph(adj, method = "vr", max_size = 4L, threshold = 0),
    "not implemented",
    fixed = TRUE
  )
  hg <- build_hypergraph(adj, method = "clique", max_size = 4L,
                         threshold = 0)
  expect_s3_class(hg, "net_hypergraph")
  expect_gt(hg$n_hyperedges, 0L)
})

# =========================================================================
# A04-F03 — build_simplicial(max_dim < 0) must error (was silent default)
# =========================================================================

test_that("build_simplicial rejects negative / non-integer max_dim", {
  net <- .fix3_net()

  expect_error(build_simplicial(net, max_dim = -1L), "max_dim")
  expect_error(build_simplicial(net, max_dim = -5L), "max_dim")
  expect_error(build_simplicial(net, max_dim = 2.5), "max_dim")
  expect_error(build_simplicial(net, max_dim = c(1L, 2L)), "max_dim")
  expect_error(build_simplicial(net, max_dim = NA_integer_), "max_dim")

  # Valid non-negative integers still work and still cap dimension.
  sc0 <- build_simplicial(net, type = "clique", threshold = 0,
                          max_dim = 0L)
  expect_identical(sc0$dimension, 0L)
  sc2 <- build_simplicial(net, type = "clique", threshold = 0,
                          max_dim = 2L)
  expect_lte(sc2$dimension, 2L)
})

# =========================================================================
# A04-F04 — persistent_homology(n_steps < 1) must error (was silent)
# =========================================================================

test_that("persistent_homology rejects n_steps < 1 and bad max_dim", {
  net <- .fix3_net()

  expect_error(persistent_homology(net, n_steps = 0L), "n_steps")
  expect_error(persistent_homology(net, n_steps = -3L), "n_steps")
  expect_error(persistent_homology(net, n_steps = 2.5), "n_steps")
  expect_error(persistent_homology(net, n_steps = NA_integer_), "n_steps")
  expect_error(persistent_homology(net, n_steps = 5L, max_dim = -1L),
               "max_dim")

  # Valid call still produces the documented shape.
  ph <- persistent_homology(net, n_steps = 5L, max_dim = 2L)
  expect_s3_class(ph, "persistent_homology")
  expect_length(ph$thresholds, 5L)
  expect_true(all(c("threshold", "dimension", "betti") %in%
                    names(ph$betti_curve)))
})

# =========================================================================
# A04-F05 — build_simplicial(threshold < 0) must error (was silent)
# =========================================================================

test_that("build_simplicial rejects negative / malformed threshold", {
  net <- .fix3_net()

  expect_error(build_simplicial(net, threshold = -5), "threshold")
  expect_error(build_simplicial(net, threshold = -0.001), "threshold")
  expect_error(build_simplicial(net, threshold = c(0, 1)), "threshold")
  expect_error(build_simplicial(net, threshold = NA_real_), "threshold")

  # threshold = 0 (documented default domain boundary) still works.
  sc <- build_simplicial(net, type = "clique", threshold = 0)
  expect_s3_class(sc, "simplicial_complex")
  expect_gt(sc$n_simplices, 0L)
})