tests/testthat/test-centrality.R

In cograph: Analysis and Visualization of Complex Networks

# Tests for centrality functions

skip_on_cran()

test_that("centrality works with adjacency matrix", {
  mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), 3, 3)
  rownames(mat) <- colnames(mat) <- c("A", "B", "C")

  result <- centrality(mat)
  expect_true(is.data.frame(result))
  expect_equal(nrow(result), 3)
  expect_true("node" %in% names(result))
})

test_that("centrality works with specific measures", {
  mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), 3, 3)
  rownames(mat) <- colnames(mat) <- c("A", "B", "C")

  result <- centrality(mat, measures = c("degree", "betweenness"))
  expect_true(is.data.frame(result))
  expect_true("degree_all" %in% names(result))
  expect_true("betweenness" %in% names(result))
})

test_that("centrality_degree works", {
  mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), 3, 3)
  rownames(mat) <- colnames(mat) <- c("A", "B", "C")

  result <- centrality_degree(mat)
  expect_length(result, 3)
  expect_true(is.numeric(result))
})

test_that("centrality_strength works", {
  mat <- matrix(c(0, 0.5, 0.8, 0.5, 0, 0.3, 0.8, 0.3, 0), 3, 3)
  rownames(mat) <- colnames(mat) <- c("A", "B", "C")

  result <- centrality_strength(mat)
  expect_length(result, 3)
  expect_true(is.numeric(result))
})

test_that("centrality_betweenness works", {
  mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), 3, 3)

  result <- centrality_betweenness(mat)
  expect_length(result, 3)
  expect_true(is.numeric(result))
})

test_that("centrality_closeness works", {
  mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), 3, 3)

  result <- centrality_closeness(mat)
  expect_length(result, 3)
  expect_true(is.numeric(result))
})

test_that("centrality_eigenvector works", {
  mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), 3, 3)

  result <- centrality_eigenvector(mat)
  expect_length(result, 3)
  expect_true(is.numeric(result))
})

test_that("centrality_pagerank works", {
  mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), 3, 3)

  result <- centrality_pagerank(mat)
  expect_length(result, 3)
  expect_true(is.numeric(result))
  expect_true(all(result >= 0))
})

test_that("centrality with normalization works", {
  mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), 3, 3)

  result <- centrality(mat, normalized = TRUE)
  expect_true(is.data.frame(result))
  # All normalized values should be <= 1
  numeric_cols <- sapply(result, is.numeric)
  for (col in names(result)[numeric_cols]) {
    expect_true(all(result[[col]] <= 1, na.rm = TRUE))
  }
})

test_that("centrality with directed network works", {
  mat <- matrix(c(0, 1, 0, 0, 0, 1, 1, 0, 0), 3, 3, byrow = TRUE)
  rownames(mat) <- colnames(mat) <- c("A", "B", "C")

  # Use specific measures to avoid alpha centrality singularity on small matrices
  result <- centrality(mat, directed = TRUE, mode = "in",
                       measures = c("degree", "betweenness", "closeness"))
  expect_true(is.data.frame(result))
  expect_true("degree_in" %in% names(result))
})

test_that("centrality with cograph_network works", {
  mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), 3, 3)
  rownames(mat) <- colnames(mat) <- c("A", "B", "C")
  net <- as_cograph(mat)

  result <- centrality(net)
  expect_true(is.data.frame(result))
  expect_equal(nrow(result), 3)
})

test_that("centrality with igraph object works", {
  skip_if_not_installed("igraph")

  g <- igraph::make_ring(5)
  result <- centrality(g)
  expect_true(is.data.frame(result))
  expect_equal(nrow(result), 5)
})

test_that("centrality with sorting works", {
  mat <- matrix(c(0, 1, 1, 0,
                  1, 0, 1, 1,
                  1, 1, 0, 1,
                  0, 1, 1, 0), 4, 4, byrow = TRUE)
  rownames(mat) <- colnames(mat) <- c("A", "B", "C", "D")

  result <- centrality(mat, sort_by = "degree_all")
  expect_true(is.data.frame(result))
  # Check descending order
  expect_true(result$degree_all[1] >= result$degree_all[nrow(result)])
})

test_that("centrality with digits rounding works", {
  mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), 3, 3)

  result <- centrality(mat, digits = 2)
  expect_true(is.data.frame(result))
})

test_that("centrality errors on invalid measures", {
  mat <- matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), 3, 3)

  expect_error(centrality(mat, measures = "invalid_measure"))
})

# ═══════════════════════════════════════════════════════════════════════════════
# Mathematical Equivalence Tests
# ═══════════════════════════════════════════════════════════════════════════════

# Test network used for validation
.test_mat <- matrix(c(
  0, 1, 1, 0, 0,
  1, 0, 1, 1, 0,
  1, 1, 0, 1, 1,
  0, 1, 1, 0, 1,
  0, 0, 1, 1, 0
), 5, 5, byrow = TRUE)
rownames(.test_mat) <- colnames(.test_mat) <- LETTERS[1:5]
.test_g <- igraph::graph_from_adjacency_matrix(.test_mat, mode = "undirected")

# --- igraph-backed measures ---

test_that("degree matches igraph", {
  expect_equal(
    unname(centrality_degree(.test_mat)),
    unname(igraph::degree(.test_g))
  )
})

test_that("betweenness matches igraph", {
  expect_equal(
    unname(centrality_betweenness(.test_mat)),
    unname(igraph::betweenness(.test_g))
  )
})

test_that("closeness matches igraph", {
  expect_equal(
    unname(centrality_closeness(.test_mat)),
    unname(igraph::closeness(.test_g))
  )
})

test_that("eigenvector matches igraph", {
  expect_equal(
    unname(centrality_eigenvector(.test_mat)),
    unname(igraph::eigen_centrality(.test_g)$vector)
  )
})

test_that("pagerank matches igraph", {
  expect_equal(
    unname(centrality_pagerank(.test_mat)),
    unname(igraph::page_rank(.test_g)$vector)
  )
})

test_that("harmonic matches igraph", {
  expect_equal(
    unname(centrality_harmonic(.test_mat)),
    unname(igraph::harmonic_centrality(.test_g))
  )
})

test_that("alpha (Katz) matches igraph", {
  expect_equal(
    unname(centrality_alpha(.test_mat)),
    unname(igraph::alpha_centrality(.test_g, exo = 1)),
    tolerance = 1e-6
  )
})

test_that("subgraph matches igraph", {
  expect_equal(
    unname(centrality_subgraph(.test_mat)),
    unname(igraph::subgraph_centrality(.test_g, diag = FALSE)),
    tolerance = 1e-6
  )
})

test_that("power (Bonacich) matches igraph", {
  expect_equal(
    unname(centrality_power(.test_mat)),
    unname(igraph::power_centrality(.test_g, exponent = 1)),
    tolerance = 1e-6
  )
})

test_that("edge_betweenness matches igraph", {
  expect_equal(
    unname(edge_centrality(.test_mat)$betweenness),
    unname(igraph::edge_betweenness(.test_g)),
    tolerance = 1e-6
  )
})

# --- centiserve package comparison ---

test_that("laplacian matches centiserve", {
  skip_if_not_installed("centiserve")
  expect_equal(
    unname(centrality_laplacian(.test_mat)),
    unname(centiserve::laplacian(.test_g)),
    tolerance = 1e-6
  )
})

test_that("current_flow_closeness matches centiserve", {
  skip_if_not_installed("centiserve")
  expect_equal(
    unname(centrality_current_flow_closeness(.test_mat)),
    unname(centiserve::closeness.currentflow(.test_g)),
    tolerance = 1e-6
  )
})

# --- sna package comparison ---

test_that("load matches sna::loadcent", {
  skip_if_not_installed("sna")
  sna_load <- sna::loadcent(.test_mat, gmode = "graph")
  expect_equal(
    unname(centrality_load(.test_mat)),
    unname(sna_load),
    tolerance = 1e-6
  )
})

test_that("diffusion matches centiserve", {
  skip_if_not_installed("centiserve")
  expect_equal(
    unname(centrality_diffusion(.test_mat)),
    unname(centiserve::diffusion.degree(.test_g)),
    tolerance = 1e-6
  )
})

test_that("leverage matches centiserve", {
  skip_if_not_installed("centiserve")
  expect_equal(
    unname(centrality_leverage(.test_mat)),
    unname(centiserve::leverage(.test_g)),
    tolerance = 1e-6
  )
})

test_that("kreach matches centiserve::geokpath", {
  skip_if_not_installed("centiserve")
  expect_equal(
    unname(centrality_kreach(.test_mat, k = 3)),
    unname(centiserve::geokpath(.test_g, k = 3)),
    tolerance = 1e-6
  )
})

# --- NetworkX package comparison (via reticulate) ---

test_that("current_flow_betweenness matches NetworkX", {
  skip_if_not_installed("reticulate")
  skip_if_not(reticulate::py_module_available("networkx"), "NetworkX not available")

  nx <- reticulate::import("networkx")
  G <- nx$Graph()
  G$add_nodes_from(LETTERS[1:5])
  G$add_edges_from(list(
    c("A", "B"), c("A", "C"), c("B", "C"), c("B", "D"),
    c("C", "D"), c("C", "E"), c("D", "E")
  ))

  nx_cfb <- nx$current_flow_betweenness_centrality(G)
  nx_cfb_vec <- sapply(LETTERS[1:5], function(x) nx_cfb[[x]])

  expect_equal(
    unname(centrality_current_flow_betweenness(.test_mat)),
    unname(nx_cfb_vec),
    tolerance = 1e-5
  )
})

test_that("percolation matches NetworkX", {
  skip_if_not_installed("reticulate")
  skip_if_not(reticulate::py_module_available("networkx"), "NetworkX not available")

  nx <- reticulate::import("networkx")
  G <- nx$Graph()
  G$add_nodes_from(LETTERS[1:5])
  G$add_edges_from(list(
    c("A", "B"), c("A", "C"), c("B", "C"), c("B", "D"),
    c("C", "D"), c("C", "E"), c("D", "E")
  ))

  states <- reticulate::py_dict(LETTERS[1:5], rep(1.0, 5))
  nx_perc <- nx$percolation_centrality(G, states = states)
  nx_perc_vec <- sapply(LETTERS[1:5], function(x) nx_perc[[x]])

  expect_equal(
    unname(centrality_percolation(.test_mat)),
    unname(nx_perc_vec),
    tolerance = 1e-6
  )
})

test_that("laplacian matches NetworkX", {
  skip_if_not_installed("reticulate")
  skip_if_not(reticulate::py_module_available("networkx"), "NetworkX not available")

  nx <- reticulate::import("networkx")
  G <- nx$Graph()
  G$add_nodes_from(LETTERS[1:5])
  G$add_edges_from(list(
    c("A", "B"), c("A", "C"), c("B", "C"), c("B", "D"),
    c("C", "D"), c("C", "E"), c("D", "E")
  ))

  nx_lap <- nx$laplacian_centrality(G, normalized = FALSE)
  nx_lap_vec <- sapply(LETTERS[1:5], function(x) nx_lap[[x]])

  expect_equal(
    unname(centrality_laplacian(.test_mat)),
    unname(nx_lap_vec),
    tolerance = 1e-6
  )
})

test_that("voterank matches NetworkX ordering", {
  skip_if_not_installed("reticulate")
  skip_if_not(reticulate::py_module_available("networkx"), "NetworkX not available")

  nx <- reticulate::import("networkx")
  G <- nx$Graph()
  G$add_nodes_from(LETTERS[1:5])
  G$add_edges_from(list(
    c("A", "B"), c("A", "C"), c("B", "C"), c("B", "D"),
    c("C", "D"), c("C", "E"), c("D", "E")
  ))

  nx_vr <- unlist(nx$voterank(G))
  cg_vr <- centrality_voterank(.test_mat)
  cg_order <- names(sort(cg_vr, decreasing = TRUE))

  # Top spreaders should match in order
  expect_equal(cg_order[1:length(nx_vr)], nx_vr)
})

# --- Manual verification (for current_flow_closeness) ---

test_that("current_flow_closeness matches manual pseudoinverse calculation", {
  n <- 5
  L <- igraph::laplacian_matrix(.test_g, sparse = FALSE)
  J <- matrix(1, n, n)
  L_tilde <- L - J / n
  svd_result <- svd(L_tilde)
  tol <- max(dim(L_tilde)) * max(svd_result$d) * .Machine$double.eps
  positive <- svd_result$d > tol
  L_pinv <- svd_result$v[, positive, drop = FALSE] %*%
    diag(1 / svd_result$d[positive], nrow = sum(positive)) %*%
    t(svd_result$u[, positive, drop = FALSE])
  diag_L_pinv <- diag(L_pinv)

  manual_cfc <- numeric(n)
  for (i in 1:n) {
    total_resistance <- 0
    for (j in 1:n) {
      if (i != j) {
        R_ij <- diag_L_pinv[i] + diag_L_pinv[j] - 2 * L_pinv[i, j]
        total_resistance <- total_resistance + R_ij
      }
    }
    manual_cfc[i] <- (n - 1) / total_resistance
  }

  expect_equal(
    unname(centrality_current_flow_closeness(.test_mat)),
    manual_cfc,
    tolerance = 1e-6
  )
})

# --- Property-based tests (fallback when NetworkX unavailable) ---

test_that("percolation equals betweenness with uniform states", {
  # When all states are 1, percolation should equal normalized betweenness
  perc <- centrality_percolation(.test_mat)
  betw <- centrality_betweenness(.test_mat)

  # Percolation should be 0 where betweenness is 0
  expect_true(all(perc[betw == 0] == 0))

  # Should equal normalized betweenness (correlation = 1)
  expect_equal(cor(perc, betw), 1, tolerance = 1e-6)
})

test_that("voterank returns valid scores", {
  vr <- centrality_voterank(.test_mat)

  # Node C has highest degree (4), should rank highest
  expect_equal(unname(vr["C"]), max(vr))

  # All values should be in [0, 1]
  expect_true(all(vr >= 0 & vr <= 1))
})