# Tests for cluster-metrics.R # ============================================================================== # Test Data # ============================================================================== # Create a simple weighted network set.seed(42) n <- 10 mat <- matrix(runif(n * n), n, n) diag(mat) <- 0 # No self-loops rownames(mat) <- colnames(mat) <- paste0("N", 1:n) # Define clusters clusters_list <- list( "A" = c("N1", "N2", "N3"), "B" = c("N4", "N5", "N6"), "C" = c("N7", "N8", "N9", "N10") ) clusters_vec <- c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3) names(clusters_vec) <- paste0("N", 1:n) # ============================================================================== # Test aggregate_weights # ============================================================================== test_that("aggregate_weights works correctly", { w <- c(1, 2, 3, 4, 5) expect_equal(aggregate_weights(w, "sum"), 15) expect_equal(aggregate_weights(w, "mean"), 3) expect_equal(aggregate_weights(w, "median"), 3) expect_equal(aggregate_weights(w, "max"), 5) expect_equal(aggregate_weights(w, "min"), 1) expect_equal(aggregate_weights(w, "prod"), 120) # Density with n_possible expect_equal(aggregate_weights(w, "density", n_possible = 10), 1.5) # Geometric mean expect_equal(aggregate_weights(w, "geomean"), exp(mean(log(w))), tolerance = 1e-10) # Handle empty/NA expect_equal(aggregate_weights(c(), "sum"), 0) expect_equal(aggregate_weights(c(NA, NA), "sum"), 0) expect_equal(aggregate_weights(c(0, 0), "sum"), 0) }) # ============================================================================== # Test cluster_summary # ============================================================================== test_that("cluster_summary works with list input", { # Use type = "raw" to get non-normalized aggregated values result <- cluster_summary(mat, clusters_list, method = "sum", type = "raw") expect_s3_class(result, "cluster_summary") expect_equal(dim(result$macro$weights), c(3, 3)) expect_equal(length(result$clusters), 3) expect_equal(names(result$clusters), c("A", "B", "C")) expect_equal(unname(result$meta$cluster_sizes), c(3, 3, 4)) # Diagonal contains intra-cluster retention expect_true(all(diag(result$macro$weights) >= 0)) # Check a specific between value manually # A -> B = sum of mat[1:3, 4:6] expected_AB <- sum(mat[1:3, 4:6]) expect_equal(result$macro$weights["A", "B"], expected_AB, tolerance = 1e-10) }) test_that("cluster_summary works with vector input", { result <- cluster_summary(mat, clusters_vec, method = "sum") expect_s3_class(result, "cluster_summary") expect_equal(dim(result$macro$weights), c(3, 3)) }) test_that("cluster_summary different methods", { # Use type = "raw" to get non-normalized values for comparison result_sum <- cluster_summary(mat, clusters_list, method = "sum", type = "raw") result_mean <- cluster_summary(mat, clusters_list, method = "mean", type = "raw") result_max <- cluster_summary(mat, clusters_list, method = "max", type = "raw") # Mean should be smaller than sum (for non-single edges) expect_true(all(result_mean$macro$weights <= result_sum$macro$weights)) # Max should be <= sum expect_true(all(result_max$macro$weights <= result_sum$macro$weights)) }) # ============================================================================== # Test cluster_quality # ============================================================================== test_that("cluster_quality computes valid metrics", { result <- cluster_quality(mat, clusters_list) expect_s3_class(result, "cluster_quality") expect_equal(nrow(result$per_cluster), 3) # Check metric ranges expect_true(all(result$per_cluster$internal_density >= 0, na.rm = TRUE)) expect_true(all(result$per_cluster$conductance >= 0 & result$per_cluster$conductance <= 1, na.rm = TRUE)) # Global metrics expect_true(!is.na(result$global$modularity)) expect_true(!is.na(result$global$coverage)) expect_true(result$global$coverage >= 0 && result$global$coverage <= 1) }) # ============================================================================== # Test layer_similarity # ============================================================================== test_that("layer_similarity computes correct values", { # Two identical matrices expect_equal(layer_similarity(mat, mat, "jaccard"), 1) expect_equal(layer_similarity(mat, mat, "cosine"), 1, tolerance = 1e-10) expect_equal(layer_similarity(mat, mat, "pearson"), 1, tolerance = 1e-10) expect_equal(layer_similarity(mat, mat, "hamming"), 0) # Different matrices mat2 <- matrix(runif(n * n), n, n) diag(mat2) <- 0 sim_jaccard <- layer_similarity(mat, mat2, "jaccard") expect_true(sim_jaccard >= 0 && sim_jaccard <= 1) sim_cosine <- layer_similarity(mat, mat2, "cosine") expect_true(sim_cosine >= -1 && sim_cosine <= 1) }) test_that("layer_similarity_matrix is symmetric", { layers <- list(L1 = mat, L2 = mat * 0.5, L3 = mat^2) result <- layer_similarity_matrix(layers, method = "cosine") expect_equal(dim(result), c(3, 3)) expect_equal(unname(diag(result)), c(1, 1, 1)) expect_equal(result[1, 2], result[2, 1]) expect_equal(result[1, 3], result[3, 1]) }) # ============================================================================== # Test supra_adjacency # ============================================================================== test_that("supra_adjacency constructs correct matrix", { layers <- list(L1 = mat, L2 = mat * 2) result <- supra_adjacency(layers, omega = 0.5) expect_s3_class(result, "supra_adjacency") expect_equal(dim(result), c(20, 20)) expect_equal(attr(result, "n_nodes"), 10) expect_equal(attr(result, "n_layers"), 2) # Check diagonal blocks match original layers L1_extracted <- extract_layer(result, 1) L2_extracted <- extract_layer(result, 2) expect_equal(L1_extracted, mat, ignore_attr = TRUE) expect_equal(L2_extracted, mat * 2, ignore_attr = TRUE) # Check inter-layer coupling (diagonal identity * omega) interlayer <- extract_interlayer(result, 1, 2) expect_equal(diag(interlayer), rep(0.5, 10)) expect_equal(sum(interlayer) - sum(diag(interlayer)), 0) # Only diagonal }) test_that("supra_adjacency full coupling", { layers <- list(L1 = mat, L2 = mat) result <- supra_adjacency(layers, omega = 1, coupling = "full") interlayer <- extract_interlayer(result, 1, 2) expect_true(all(interlayer == 1)) }) # ============================================================================== # Test aggregate_layers # ============================================================================== test_that("aggregate_layers works correctly", { layers <- list(L1 = mat, L2 = mat * 2, L3 = mat * 3) result_sum <- aggregate_layers(layers, method = "sum") expect_equal(result_sum, mat * 6, tolerance = 1e-10) result_mean <- aggregate_layers(layers, method = "mean") expect_equal(result_mean, mat * 2, tolerance = 1e-10) result_max <- aggregate_layers(layers, method = "max") expect_equal(result_max, mat * 3, tolerance = 1e-10) # Weighted sum result_weighted <- aggregate_layers(layers, method = "sum", weights = c(1, 2, 0)) expect_equal(result_weighted, mat * 5, tolerance = 1e-10) }) test_that("aggregate_layers union/intersection", { # Create sparse matrices mat1 <- matrix(0, 5, 5) mat1[1, 2] <- mat1[2, 3] <- 1 mat2 <- matrix(0, 5, 5) mat2[2, 3] <- mat2[3, 4] <- 1 result_union <- aggregate_layers(list(mat1, mat2), method = "union") expect_equal(sum(result_union), 3) # 3 unique edges result_intersection <- aggregate_layers(list(mat1, mat2), method = "intersection") expect_equal(sum(result_intersection), 1) # 1 shared edge (2->3) }) # ============================================================================== # Test igraph verification (if available) # ============================================================================== test_that("cluster_summary matches igraph", { skip_if_not_installed("igraph") # verify_with_igraph defaults to type = "raw" for igraph comparison result <- verify_with_igraph(mat, clusters_list, method = "sum") expect_true(result$matches, info = paste("Difference:", result$difference)) }) # ============================================================================== # Edge Cases # ============================================================================== test_that("handles single-node clusters", { clusters_single <- list( "A" = "N1", "B" = c("N2", "N3", "N4", "N5", "N6", "N7", "N8", "N9", "N10") ) result <- cluster_summary(mat, clusters_single, method = "sum") # Single node cluster has no internal edges, so sum of within weights is 0 expect_equal(sum(result$clusters$A$weights), 0) }) test_that("self-loops are preserved in macro diagonal and cluster matrices", { # TNA-style row-stochastic matrix WITH self-loops mat_sl <- matrix(0.1, 5, 5) diag(mat_sl) <- 0.6 # Strong self-loops rownames(mat_sl) <- colnames(mat_sl) <- paste0("N", 1:5) clusters_sl <- list(A = c("N1", "N2"), B = c("N3", "N4", "N5")) result <- cluster_summary(mat_sl, clusters_sl, method = "sum", type = "raw") # Macro diagonal should include self-loops (not zero) expect_true(diag(result$macro$weights)["A"] > 0) expect_true(diag(result$macro$weights)["B"] > 0) # Macro diagonal A = sum of mat_sl[1:2, 1:2] = 0.6+0.1+0.1+0.6 = 1.4 expect_equal(result$macro$weights["A", "A"], sum(mat_sl[1:2, 1:2]), tolerance = 1e-10) # Within-cluster matrices should have self-loops on diagonal expect_true(result$clusters$A$weights[1, 1] > 0) expect_true(result$clusters$B$weights[1, 1] > 0) }) test_that("single-node cluster preserves self-loop", { mat_sl <- matrix(0.1, 5, 5) diag(mat_sl) <- 0.5 rownames(mat_sl) <- colnames(mat_sl) <- paste0("N", 1:5) clusters_sl <- list(A = "N1", B = paste0("N", 2:5)) result <- cluster_summary(mat_sl, clusters_sl, method = "sum", type = "raw") # Single-node cluster A: macro diagonal = self-loop = 0.5 expect_equal(result$macro$weights["A", "A"], 0.5, tolerance = 1e-10) # Within-cluster matrix for A should be 1x1 with self-loop value expect_equal(result$clusters$A$weights[1, 1], 0.5, tolerance = 1e-10) }) test_that("handles empty weights gracefully", { mat_sparse <- matrix(0, 5, 5) mat_sparse[1, 2] <- 1 rownames(mat_sparse) <- colnames(mat_sparse) <- paste0("N", 1:5) clusters <- list(A = c("N1", "N2"), B = c("N3", "N4", "N5")) result <- cluster_summary(mat_sparse, clusters, method = "mean") # Between A and B should be 0 (no edges) expect_equal(result$macro$weights["A", "B"], 0) }) # ============================================================================== # Test sequence data propagation to tna models # ============================================================================== test_that("cluster_summary preserves original tna sequence data in all models", { skip_if_not_installed("tna") seqs <- data.frame( t1 = c("N1", "N4", "N1", "N7"), t2 = c("N2", "N5", "N8", "N8"), t3 = c("N3", "N6", "N9", "N10") ) tna_obj <- tna::tna(seqs) result <- cluster_summary(tna_obj, clusters_list, method = "sum", type = "tna") # Macro and clusters all get the original data, untransformed expect_false(is.null(result$macro$data)) expect_identical(result$macro$data, tna_obj$data) expect_false(is.null(result$clusters$A$data)) expect_identical(result$clusters$A$data, tna_obj$data) expect_false(is.null(result$clusters$B$data)) expect_identical(result$clusters$B$data, tna_obj$data) }) test_that("cluster_summary with matrix input has NULL data in tna models", { result <- cluster_summary(mat, clusters_list, method = "sum", type = "tna") expect_null(result$macro$data) expect_null(result$clusters$A$data) }) # ============================================================================== # Test as_tna() group_tna class # ============================================================================== test_that("as_tna.cluster_summary returns group_tna with macro and cluster elements", { skip_if_not_installed("tna") cs <- cluster_summary(mat, clusters_list, method = "mean", type = "tna") ct <- as_tna(cs) expect_s3_class(ct, "group_tna") expect_s3_class(ct$macro, "tna") # Each cluster element should be a tna object lapply(names(cs$clusters), function(cl) expect_s3_class(ct[[cl]], "tna")) }) # ============================================================================== # Test splot dispatch for cluster objects # ============================================================================== test_that("splot dispatches cluster_summary to plot_mcml", { cs <- cluster_summary(mat, clusters_list, method = "mean", type = "tna") # Should run without error (produces a plot) expect_no_error(splot(cs)) }) test_that("splot dispatches group_tna (macro)", { skip_if_not_installed("tna") cs <- cluster_summary(mat, clusters_list, method = "mean", type = "tna") ct <- as_tna(cs) # Default: plots macro (between-cluster) network expect_no_error(splot(ct)) }) test_that("splot dispatches group_tna with i for within-cluster", { skip_if_not_installed("tna") cs <- cluster_summary(mat, clusters_list, method = "mean", type = "tna") ct <- as_tna(cs) cluster_names <- names(cs$clusters) if (length(cluster_names) > 0) { expect_no_error(splot(ct, i = cluster_names[1])) } }) # ============================================================================== # Test cluster_summary auto-detect clusters from cograph_network # ============================================================================== test_that("cluster_summary auto-detects clusters from cograph_network nodes", { net <- as_cograph(mat) # Add a 'cluster' column to nodes net$nodes$cluster <- c(rep("A", 3), rep("B", 3), rep("C", 4)) result <- cluster_summary(net, method = "sum") expect_s3_class(result, "cluster_summary") expect_equal(dim(result$macro$weights), c(3, 3)) }) test_that("cluster_summary errors when no clusters and plain matrix", { expect_error(cluster_summary(mat, clusters = NULL), "clusters argument is required") }) # ============================================================================== # Test .process_weights default (raw) branch # ============================================================================== test_that("cluster_summary type = raw returns raw weights", { result <- cluster_summary(mat, clusters_list, method = "sum", type = "raw") # "raw" should not normalize expect_true(all(result$macro$weights >= 0)) }) # ============================================================================== # Test as_tna when tna not installed (error branch) # ============================================================================== # Line 679: tna not installed error — skipped since tna IS installed # ============================================================================== # Test .normalize_clusters error paths # ============================================================================== test_that(".normalize_clusters errors on unknown nodes", { bad_clusters <- list(A = c("N1", "UNKNOWN")) expect_error(cluster_summary(mat, bad_clusters, method = "sum"), "Unknown nodes") }) test_that(".normalize_clusters errors on wrong-length membership vector", { expect_error(cluster_summary(mat, c(1, 2, 3), method = "sum"), "must equal number of nodes") }) test_that(".normalize_clusters errors on wrong-length named character vector", { bad_vec <- c("A", "B", "C") names(bad_vec) <- c("N1", "N2", "N3") expect_error(cluster_summary(mat, bad_vec, method = "sum"), "must equal number of nodes") }) test_that(".normalize_clusters errors on unsupported type", { expect_error(cluster_summary(mat, TRUE, method = "sum"), "clusters must be") }) # ============================================================================== # Test cluster_quality with empty cluster (n_S == 0 branch) # ============================================================================== # Line 856: This branch handles empty clusters — hard to trigger since # .normalize_clusters validates. Covered indirectly through edge cases. # ============================================================================== # Test cluster_significance fallback branches # ============================================================================== test_that("cluster_significance else branch for tna input", { skip_if_not_installed("igraph") skip_if_not_installed("tna") # Use a tna object (hits `else { g <- to_igraph(x) }` at line 1057) tna_obj <- tna::tna(mat) comm <- c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3) names(comm) <- paste0("N", 1:10) result <- cluster_significance(tna_obj, comm, n_random = 5, seed = 42) expect_s3_class(result, "cograph_cluster_significance") }) # ============================================================================== # Test supra_adjacency custom coupling fallback # ============================================================================== test_that("supra_adjacency custom coupling with fallback to omega", { layers <- list(L1 = mat, L2 = mat * 2, L3 = mat * 3) # Custom coupling with 2 interlayer matrices for consecutive pairs (1-2, 2-3). # Non-consecutive pair (1,3) falls back to omega * I (line 1425). custom_mat1 <- diag(10) * 0.5 custom_mat2 <- diag(10) * 0.3 result <- supra_adjacency(layers, omega = 0.1, coupling = "custom", interlayer_matrices = list(custom_mat1, custom_mat2)) expect_s3_class(result, "supra_adjacency") expect_equal(dim(result), c(30, 30)) }) # ============================================================================== # Test verify_with_igraph when igraph is missing (line 1595-1596) # ============================================================================== # Lines 1595-1596: igraph not available branch — can't easily trigger since # igraph IS installed. These are defensive guards. # ============================================================================== # Test .create_cograph_network type parameter # ============================================================================== test_that(".create_cograph_network stores type in meta", { nodes <- data.frame(id = 1:3, label = c("A", "B", "C")) edges <- data.frame(from = c(1L, 2L), to = c(2L, 3L), weight = c(1, 1)) net <- .create_cograph_network( nodes = nodes, edges = edges, directed = FALSE, type = "mcml" ) expect_equal(net$meta$type, "mcml") # NULL type should not add meta$type net2 <- .create_cograph_network( nodes = nodes, edges = edges, directed = FALSE ) expect_null(net2$meta$type) }) # ============================================================================== # Summary # ============================================================================== cat("\n=== All Cluster Metrics Tests Passed ===\n")