tests/testthat/test-tier2-features.R

In cograph: Analysis and Visualization of Complex Networks

# Tests for Tier 2 network science features
# edge-metrics, vulnerability, core-periphery, fit-distribution, paths, bipartite

skip_on_cran()

# =============================================================================
# SECTION 1: neighborhood_overlap()
# =============================================================================

test_that("neighborhood_overlap: triangle has overlap 1", {
  adj <- matrix(c(0,1,1, 1,0,1, 1,1,0), 3, 3)
  rownames(adj) <- colnames(adj) <- c("A", "B", "C")
  res <- neighborhood_overlap(adj)
  expect_true(is.data.frame(res))
  expect_equal(nrow(res), 3L)
  expect_true(all(res$overlap == 1))
  expect_true(all(res$shared == 1L))
})

test_that("neighborhood_overlap: star has overlap 0 between spokes", {
  star <- matrix(c(0,1,1,1, 1,0,0,0, 1,0,0,0, 1,0,0,0), 4, 4)
  rownames(star) <- colnames(star) <- c("hub", "a", "b", "c")
  res <- neighborhood_overlap(star)
  # Edges from hub to spokes: spokes share no neighbors except hub (excluded)
  spoke_edges <- res[res$from != "hub" | res$to == "hub", ]
  expect_true(all(res$overlap == 0))
})

test_that("neighborhood_overlap: empty graph returns empty df", {
  adj <- matrix(0, 3, 3)
  rownames(adj) <- colnames(adj) <- c("A", "B", "C")
  res <- neighborhood_overlap(adj)
  expect_equal(nrow(res), 0L)
})

test_that("neighborhood_overlap: weighted network includes weight column", {
  adj <- matrix(c(0, 2, 3, 2, 0, 1, 3, 1, 0), 3, 3)
  rownames(adj) <- colnames(adj) <- c("A", "B", "C")
  res <- neighborhood_overlap(adj)
  expect_true("weight" %in% names(res))
})

# =============================================================================
# SECTION 2: simmelian_strength()
# =============================================================================

test_that("simmelian_strength: K4 has 2 triangles per edge", {
  k4 <- matrix(1, 4, 4); diag(k4) <- 0
  rownames(k4) <- colnames(k4) <- LETTERS[1:4]
  res <- simmelian_strength(k4)
  expect_true(all(res$triangles == 2L))
})

test_that("simmelian_strength: path has 0 triangles", {
  path <- matrix(c(0,1,0, 1,0,1, 0,1,0), 3, 3)
  rownames(path) <- colnames(path) <- c("A", "B", "C")
  res <- simmelian_strength(path)
  expect_true(all(res$triangles == 0L))
})

test_that("simmelian_strength: empty graph returns empty df", {
  adj <- matrix(0, 3, 3)
  rownames(adj) <- colnames(adj) <- c("A", "B", "C")
  res <- simmelian_strength(adj)
  expect_equal(nrow(res), 0L)
})

# =============================================================================
# SECTION 3: edge_reciprocity()
# =============================================================================

test_that("edge_reciprocity: detects mutual and non-mutual edges", {
  adj <- matrix(c(0, 0.8, 0, 0.3, 0, 0.5, 0.7, 0, 0), 3, 3, byrow = TRUE)
  rownames(adj) <- colnames(adj) <- c("A", "B", "C")
  res <- edge_reciprocity(adj, directed = TRUE)
  expect_true(is.data.frame(res))
  # A->B and B->A are reciprocal
  ab <- res[res$from == "A" & res$to == "B", ]
  expect_true(ab$reciprocated)
  expect_equal(ab$reverse_weight, 0.3)
  # B->C is not reciprocated
  bc <- res[res$from == "B" & res$to == "C", ]
  expect_false(bc$reciprocated)
  expect_true(is.na(bc$weight_ratio))
})

test_that("edge_reciprocity: errors on undirected network", {
  adj <- matrix(c(0,1,1, 1,0,1, 1,1,0), 3, 3)
  expect_error(edge_reciprocity(adj), "directed")
})

test_that("edge_reciprocity: empty graph returns empty df", {
  adj <- matrix(0, 3, 3)
  rownames(adj) <- colnames(adj) <- c("A", "B", "C")
  res <- edge_reciprocity(adj, directed = TRUE)
  expect_equal(nrow(res), 0L)
})

# =============================================================================
# SECTION 4: vulnerability()
# =============================================================================

test_that("vulnerability: star hub has max vulnerability", {
  star <- matrix(c(0,1,1,1, 1,0,0,0, 1,0,0,0, 1,0,0,0), 4, 4)
  rownames(star) <- colnames(star) <- c("hub", "a", "b", "c")
  v <- vulnerability(star)
  expect_s3_class(v, "cograph_vulnerability")
  expect_equal(v$node[1], "hub")
  expect_equal(v$vulnerability[v$node == "hub"], 1.0)
})

test_that("vulnerability: K4 all nodes equal", {
  k4 <- matrix(1, 4, 4); diag(k4) <- 0
  rownames(k4) <- colnames(k4) <- LETTERS[1:4]
  v <- vulnerability(k4)
  expect_equal(length(unique(round(v$vulnerability, 10))), 1L)
})

test_that("vulnerability: normalized vs raw", {
  adj <- create_test_matrix(10, density = 0.3)
  v_norm <- vulnerability(adj, normalized = TRUE)
  v_raw <- vulnerability(adj, normalized = FALSE)
  expect_true(all(is.numeric(v_norm$vulnerability)))
  expect_true(all(is.numeric(v_raw$vulnerability)))
  expect_equal(nrow(v_norm), 10L)
})

test_that("vulnerability: single node returns NA", {
  adj <- matrix(0, 1, 1)
  rownames(adj) <- colnames(adj) <- "A"
  v <- vulnerability(adj)
  expect_true(is.na(v$vulnerability[v$node == "A"]))
})

test_that("vulnerability: plot method works", {
  adj <- create_test_matrix(10, density = 0.3)
  v <- vulnerability(adj)
  pdf(NULL)
  expect_no_error(plot(v))
  expect_no_error(plot(v, top = 5))
  dev.off()
})

test_that("core_periphery: plot method works", {
  adj <- create_test_matrix(10, density = 0.3)
  rownames(adj) <- colnames(adj) <- paste0("N", 1:10)
  cp <- core_periphery(adj)
  pdf(NULL)
  expect_no_error(plot(cp))
  dev.off()
})

# =============================================================================
# SECTION 5: core_periphery()
# =============================================================================

test_that("core_periphery: continuous returns correct structure", {
  adj <- matrix(c(
    0,1,1,1,0,
    1,0,1,1,0,
    1,1,0,1,1,
    1,1,1,0,1,
    0,0,1,1,0
  ), 5, 5)
  rownames(adj) <- colnames(adj) <- LETTERS[1:5]
  cp <- core_periphery(adj)
  expect_s3_class(cp, "cograph_core_periphery")
  expect_true(all(cp$coreness >= 0 & cp$coreness <= 1))
  expect_true(all(cp$role %in% c("core", "periphery")))
  expect_true(is.numeric(attr(cp, "fitness")))
  expect_true(attr(cp, "core_density") >= 0)
})

test_that("core_periphery: discrete refines assignment", {
  adj <- matrix(c(
    0,1,1,1,0,0,
    1,0,1,1,0,0,
    1,1,0,1,1,0,
    1,1,1,0,1,1,
    0,0,1,1,0,0,
    0,0,0,1,0,0
  ), 6, 6)
  rownames(adj) <- colnames(adj) <- LETTERS[1:6]
  cp <- core_periphery(adj, method = "discrete")
  expect_true(sum(cp$role == "core") > 0)
  expect_true(sum(cp$role == "periphery") > 0)
})

test_that("core_periphery: print method works", {
  adj <- create_test_matrix(8, density = 0.4)
  cp <- core_periphery(adj)
  expect_output(print(cp), "Core-Periphery")
})

# =============================================================================
# SECTION 6: fit_degree_distribution()
# =============================================================================

test_that("fit_degree_distribution: returns correct structure", {
  mat <- create_test_matrix(50, density = 0.15)
  fit <- fit_degree_distribution(mat,
    distributions = c("exponential", "poisson"))
  expect_s3_class(fit, "cograph_degree_fit")
  expect_true(is.data.frame(fit$comparison))
  expect_equal(nrow(fit$comparison), 2L)
  expect_true(fit$best %in% c("exponential", "poisson"))
  expect_true(all(c("aic", "bic", "ks_stat") %in% names(fit$comparison)))
})

test_that("fit_degree_distribution: all four distributions", {
  mat <- create_test_matrix(50, density = 0.15)
  fit <- fit_degree_distribution(mat)
  expect_equal(length(fit$fits), 4L)
  expect_equal(nrow(fit$comparison), 4L)
})

test_that("fit_degree_distribution: print method works", {
  mat <- create_test_matrix(30, density = 0.2)
  fit <- fit_degree_distribution(mat,
    distributions = c("exponential", "poisson"))
  expect_output(print(fit), "Degree Distribution Fit")
})

test_that("fit_degree_distribution: plot method works", {
  mat <- create_test_matrix(50, density = 0.15)
  fit <- fit_degree_distribution(mat,
    distributions = c("exponential", "poisson"))
  pdf(NULL)
  expect_no_error(plot(fit))
  dev.off()
})

test_that("fit_degree_distribution: errors on unknown distribution", {
  mat <- create_test_matrix(20, density = 0.3)
  expect_error(fit_degree_distribution(mat, distributions = "gamma"),
               "Unknown")
})

# =============================================================================
# SECTION 7: shortest_paths()
# =============================================================================

test_that("shortest_paths: all-pairs returns matrix", {
  adj <- matrix(c(0,1,0,0, 1,0,1,0, 0,1,0,1, 0,0,1,0), 4, 4)
  rownames(adj) <- colnames(adj) <- LETTERS[1:4]
  d <- shortest_paths(adj)
  expect_true(is.matrix(d))
  expect_equal(dim(d), c(4L, 4L))
  expect_equal(d["A", "D"], 3)
})

test_that("shortest_paths: single source returns vector", {
  adj <- matrix(c(0,1,0,0, 1,0,1,0, 0,1,0,1, 0,0,1,0), 4, 4)
  rownames(adj) <- colnames(adj) <- LETTERS[1:4]
  d <- shortest_paths(adj, from = "A")
  expect_true(is.numeric(d))
  expect_equal(length(d), 4L)
  expect_equal(unname(d["D"]), 3)
})

test_that("shortest_paths: point to point returns scalar", {
  adj <- matrix(c(0,1,0,0, 1,0,1,0, 0,1,0,1, 0,0,1,0), 4, 4)
  rownames(adj) <- colnames(adj) <- LETTERS[1:4]
  d <- shortest_paths(adj, from = "A", to = "D")
  expect_equal(d, 3)
})

test_that("shortest_paths: weights = NA forces unweighted", {
  adj <- matrix(c(0,5,0, 5,0,1, 0,1,0), 3, 3)
  rownames(adj) <- colnames(adj) <- c("A", "B", "C")
  d <- shortest_paths(adj, from = "A", to = "C", weights = NA)
  expect_equal(d, 2)  # 2 hops regardless of weight
})

test_that("shortest_paths: error on invalid node", {
  adj <- matrix(c(0,1, 1,0), 2, 2)
  rownames(adj) <- colnames(adj) <- c("A", "B")
  expect_error(shortest_paths(adj, from = "Z"), "not found")
})

# =============================================================================
# SECTION 8: k_shortest_paths()
# =============================================================================

test_that("k_shortest_paths: finds correct paths", {
  adj <- matrix(c(
    0,1,1,0,0,
    0,0,1,1,0,
    0,0,0,1,1,
    0,0,0,0,1,
    0,0,0,0,0
  ), 5, 5, byrow = TRUE)
  rownames(adj) <- colnames(adj) <- LETTERS[1:5]
  kp <- k_shortest_paths(adj, from = "A", to = "E", k = 3)
  expect_s3_class(kp, "cograph_k_paths")
  expect_equal(length(kp$paths), 3L)
  expect_equal(kp$distances[1], 2)  # shortest: A->C->E
  expect_true(all(vapply(kp$paths, function(p) p[1] == "A" && p[length(p)] == "E",
                         logical(1))))
})

test_that("k_shortest_paths: returns fewer if not enough paths", {
  adj <- matrix(c(0,1, 0,0), 2, 2, byrow = TRUE)
  rownames(adj) <- colnames(adj) <- c("A", "B")
  kp <- k_shortest_paths(adj, from = "A", to = "B", k = 5)
  expect_equal(length(kp$paths), 1L)
})

test_that("k_shortest_paths: no path returns empty", {
  adj <- matrix(0, 3, 3)
  rownames(adj) <- colnames(adj) <- LETTERS[1:3]
  kp <- k_shortest_paths(adj, from = "A", to = "C", k = 2)
  expect_equal(length(kp$paths), 0L)
})

test_that("k_shortest_paths: print method works", {
  adj <- matrix(c(0,1,1, 0,0,1, 0,0,0), 3, 3, byrow = TRUE)
  rownames(adj) <- colnames(adj) <- c("A", "B", "C")
  kp <- k_shortest_paths(adj, from = "A", to = "C", k = 2)
  expect_output(print(kp), "K Shortest Paths")
})

# =============================================================================
# SECTION 9: project_bipartite()
# =============================================================================

test_that("project_bipartite: sum projection correct", {
  inc <- matrix(c(1,1,0, 1,0,1, 0,1,1, 1,1,1), 4, 3, byrow = TRUE)
  rownames(inc) <- paste0("S", 1:4)
  colnames(inc) <- paste0("C", 1:3)
  res <- project_bipartite(inc, mode = "rows", method = "sum")
  expect_equal(dim(res), c(4L, 4L))
  expect_true(all(diag(res) == 0))
  expect_equal(res["S1", "S4"], 2)
})

test_that("project_bipartite: column mode works", {
  inc <- matrix(c(1,1,0, 1,0,1, 0,1,1), 3, 3, byrow = TRUE)
  rownames(inc) <- paste0("S", 1:3)
  colnames(inc) <- paste0("C", 1:3)
  res <- project_bipartite(inc, mode = "columns", method = "binary")
  expect_equal(dim(res), c(3L, 3L))
  expect_equal(rownames(res), paste0("C", 1:3))
})

test_that("project_bipartite: jaccard values in [0,1]", {
  inc <- matrix(c(1,1,0, 1,0,1, 0,1,1, 1,1,1), 4, 3, byrow = TRUE)
  rownames(inc) <- paste0("S", 1:4)
  colnames(inc) <- paste0("C", 1:3)
  res <- project_bipartite(inc, method = "jaccard")
  expect_true(all(res >= 0 & res <= 1))
})

test_that("project_bipartite: cosine values in [0,1]", {
  inc <- matrix(c(1,1,0, 1,0,1, 0,1,1), 3, 3, byrow = TRUE)
  rownames(inc) <- paste0("S", 1:3)
  colnames(inc) <- paste0("C", 1:3)
  res <- project_bipartite(inc, method = "cosine")
  expect_true(all(res >= -1e-10 & res <= 1 + 1e-10))
})

test_that("project_bipartite: newman projection works", {
  inc <- matrix(c(1,1,0, 1,0,1, 0,1,1, 1,1,1), 4, 3, byrow = TRUE)
  rownames(inc) <- paste0("S", 1:4)
  colnames(inc) <- paste0("C", 1:3)
  res <- project_bipartite(inc, method = "newman")
  expect_equal(dim(res), c(4L, 4L))
  expect_true(all(diag(res) == 0))
})

test_that("project_bipartite: data.frame input works", {
  df <- data.frame(
    type1 = c("S1", "S1", "S2", "S3"),
    type2 = c("C1", "C2", "C1", "C2")
  )
  res <- project_bipartite(df, method = "binary")
  expect_true(is.matrix(res))
  expect_equal(res["S1", "S2"], 1)
})

# =============================================================================
# SECTION 10: is_bipartite()
# =============================================================================

test_that("is_bipartite: non-square is TRUE", {
  inc <- matrix(c(1,0,1, 1,1,0), 2, 3)
  expect_true(is_bipartite(inc))
})

test_that("is_bipartite: triangle is FALSE", {
  tri <- matrix(c(0,1,1, 1,0,1, 1,1,0), 3, 3)
  expect_false(is_bipartite(tri))
})

test_that("is_bipartite: bipartite square is TRUE", {
  bp <- matrix(c(0,0,1,1, 0,0,1,0, 1,1,0,0, 1,0,0,0), 4, 4, byrow = TRUE)
  expect_true(is_bipartite(bp))
})