From 7f8ca0e68e111ca4350118e9e26f416398397642 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ma=C3=ABlle=20Salmon?= Date: Thu, 20 Feb 2025 10:26:11 +0100 Subject: [PATCH 1/3] test: improve test-dot.product.game --- tests/testthat/test-dot.product.game.R | 30 ++++++++++++++++++++------ 1 file changed, 24 insertions(+), 6 deletions(-) diff --git a/tests/testthat/test-dot.product.game.R b/tests/testthat/test-dot.product.game.R index 2f3056abf0b..9ce2644cd35 100644 --- a/tests/testthat/test-dot.product.game.R +++ b/tests/testthat/test-dot.product.game.R @@ -9,10 +9,6 @@ test_that("Dot product rng works", { g0 <- graph_from_literal(1:2:3 - 4) expect_equal(as.matrix(g[]), as.matrix(g0[]), ignore_attr = TRUE) - g2 <- sample_dot_product(vecs, directed = TRUE) - g20 <- graph_from_literal(1:2:3:4, 1 -+ 3, 1 -+ 4, 3 -+ 4, 4 +- 1, 4 +- 3) - expect_true(all.equal(g20[], g[], check.attributes = FALSE)) - vecs <- replicate(5, rep(1 / 2, 4)) g <- sample_dot_product(vecs) expect_equal(g[], make_full_graph(5)[], ignore_attr = TRUE) @@ -22,10 +18,32 @@ test_that("Dot product rng works", { vecs <- replicate(100, rep(sqrt(1 / 8), 4)) g <- sample_dot_product(vecs) - expect_ecount(g, 2454) + expect_ecount(g, 2451) g2 <- sample_dot_product(vecs, directed = TRUE) - expect_ecount(g2, 4938) + expect_ecount(g2, 4941) +}) + +test_that("MISSING TITLE", { + withr::local_seed(42) + latent_features <- cbind( + c(0, 1, 1, 1, 0) / 3, c(0, 1, 1, 0, 1) / 3, c(1, 1, 1, 1, 0) / 4, + c(0, 1, 1, 1, 0) + ) + expected_probs <- t(latent_features)%*%latent_features + diag(expected_probs) <- 0 + num_graphs <- 1000 + edge_counts <- matrix(0, nrow = 4, ncol = 4) + + for (i in seq_len(num_graphs)) { + g <- sample_dot_product(latent_features) + adj_matrix <- as_adjacency_matrix(g, sparse = FALSE) + edge_counts <- edge_counts + adj_matrix + } + empirical_probs <- edge_counts / num_graphs + diag(empirical_probs) <- 0 + tolerance <- 0.05 + expect_true(all(abs(empirical_probs - expected_probs) < tolerance)) }) test_that("Dot product rng gives warnings", { From f7d5b6bd78b443f1987b0f2dda89de42db1dfbe5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ma=C3=ABlle=20Salmon?= Date: Thu, 20 Feb 2025 13:05:57 +0100 Subject: [PATCH 2/3] Update tests/testthat/test-dot.product.game.R Co-authored-by: David Schoch --- tests/testthat/test-dot.product.game.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-dot.product.game.R b/tests/testthat/test-dot.product.game.R index 9ce2644cd35..8e5743c1209 100644 --- a/tests/testthat/test-dot.product.game.R +++ b/tests/testthat/test-dot.product.game.R @@ -24,7 +24,7 @@ test_that("Dot product rng works", { expect_ecount(g2, 4941) }) -test_that("MISSING TITLE", { +test_that("sample_dot_product generates edges with correct probabilities", { withr::local_seed(42) latent_features <- cbind( c(0, 1, 1, 1, 0) / 3, c(0, 1, 1, 0, 1) / 3, c(1, 1, 1, 1, 0) / 4, From b4e421ee42d4add1bf8bd0385d40a6b4ad0c563e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ma=C3=ABlle=20Salmon?= Date: Thu, 20 Feb 2025 13:08:55 +0100 Subject: [PATCH 3/3] test: fold --- tests/testthat/test-dot.product.game.R | 61 ------------------------- tests/testthat/test-games.R | 62 ++++++++++++++++++++++++++ 2 files changed, 62 insertions(+), 61 deletions(-) delete mode 100644 tests/testthat/test-dot.product.game.R diff --git a/tests/testthat/test-dot.product.game.R b/tests/testthat/test-dot.product.game.R deleted file mode 100644 index 8e5743c1209..00000000000 --- a/tests/testthat/test-dot.product.game.R +++ /dev/null @@ -1,61 +0,0 @@ -test_that("Dot product rng works", { - withr::local_seed(42) - vecs <- cbind( - c(0, 1, 1, 1, 0) / 3, c(0, 1, 1, 0, 1) / 3, c(1, 1, 1, 1, 0) / 4, - c(0, 1, 1, 1, 0) - ) - - g <- sample_dot_product(vecs) - g0 <- graph_from_literal(1:2:3 - 4) - expect_equal(as.matrix(g[]), as.matrix(g0[]), ignore_attr = TRUE) - - vecs <- replicate(5, rep(1 / 2, 4)) - g <- sample_dot_product(vecs) - expect_equal(g[], make_full_graph(5)[], ignore_attr = TRUE) - - g2 <- sample_dot_product(vecs, directed = TRUE) - expect_equal(g2[], make_full_graph(5, directed = TRUE)[], ignore_attr = TRUE) - - vecs <- replicate(100, rep(sqrt(1 / 8), 4)) - g <- sample_dot_product(vecs) - expect_ecount(g, 2451) - - g2 <- sample_dot_product(vecs, directed = TRUE) - expect_ecount(g2, 4941) -}) - -test_that("sample_dot_product generates edges with correct probabilities", { - withr::local_seed(42) - latent_features <- cbind( - c(0, 1, 1, 1, 0) / 3, c(0, 1, 1, 0, 1) / 3, c(1, 1, 1, 1, 0) / 4, - c(0, 1, 1, 1, 0) - ) - expected_probs <- t(latent_features)%*%latent_features - diag(expected_probs) <- 0 - num_graphs <- 1000 - edge_counts <- matrix(0, nrow = 4, ncol = 4) - - for (i in seq_len(num_graphs)) { - g <- sample_dot_product(latent_features) - adj_matrix <- as_adjacency_matrix(g, sparse = FALSE) - edge_counts <- edge_counts + adj_matrix - } - empirical_probs <- edge_counts / num_graphs - diag(empirical_probs) <- 0 - tolerance <- 0.05 - expect_true(all(abs(empirical_probs - expected_probs) < tolerance)) -}) - -test_that("Dot product rng gives warnings", { - vecs <- cbind(c(1, 1, 1) / 3, -c(1, 1, 1) / 3) - expect_warning( - g <- sample_dot_product(vecs), - "Negative connection probability in dot-product graph" - ) - - vecs <- cbind(c(1, 1, 1), c(1, 1, 1)) - expect_warning( - g <- sample_dot_product(vecs), - paste0("Greater than 1 connection probability ", "in dot-product graph") - ) -}) diff --git a/tests/testthat/test-games.R b/tests/testthat/test-games.R index 0ebd2d92750..ff1f7e5e199 100644 --- a/tests/testthat/test-games.R +++ b/tests/testthat/test-games.R @@ -603,3 +603,65 @@ test_that("HSBM with list arguments works", { ) expect_equal(g_hsbm5[] + g_hsbm7[], g_hsbm8[]) }) + +test_that("Dot product rng works", { + withr::local_seed(42) + vecs <- cbind( + c(0, 1, 1, 1, 0) / 3, c(0, 1, 1, 0, 1) / 3, c(1, 1, 1, 1, 0) / 4, + c(0, 1, 1, 1, 0) + ) + + g <- sample_dot_product(vecs) + g0 <- graph_from_literal(1:2:3 - 4) + expect_equal(as.matrix(g[]), as.matrix(g0[]), ignore_attr = TRUE) + + vecs <- replicate(5, rep(1 / 2, 4)) + g <- sample_dot_product(vecs) + expect_equal(g[], make_full_graph(5)[], ignore_attr = TRUE) + + g2 <- sample_dot_product(vecs, directed = TRUE) + expect_equal(g2[], make_full_graph(5, directed = TRUE)[], ignore_attr = TRUE) + + vecs <- replicate(100, rep(sqrt(1 / 8), 4)) + g <- sample_dot_product(vecs) + expect_ecount(g, 2451) + + g2 <- sample_dot_product(vecs, directed = TRUE) + expect_ecount(g2, 4941) +}) + +test_that("sample_dot_product generates edges with correct probabilities", { + withr::local_seed(42) + latent_features <- cbind( + c(0, 1, 1, 1, 0) / 3, c(0, 1, 1, 0, 1) / 3, c(1, 1, 1, 1, 0) / 4, + c(0, 1, 1, 1, 0) + ) + expected_probs <- t(latent_features)%*%latent_features + diag(expected_probs) <- 0 + num_graphs <- 1000 + edge_counts <- matrix(0, nrow = 4, ncol = 4) + + for (i in seq_len(num_graphs)) { + g <- sample_dot_product(latent_features) + adj_matrix <- as_adjacency_matrix(g, sparse = FALSE) + edge_counts <- edge_counts + adj_matrix + } + empirical_probs <- edge_counts / num_graphs + diag(empirical_probs) <- 0 + tolerance <- 0.05 + expect_true(all(abs(empirical_probs - expected_probs) < tolerance)) +}) + +test_that("Dot product rng gives warnings", { + vecs <- cbind(c(1, 1, 1) / 3, -c(1, 1, 1) / 3) + expect_warning( + g <- sample_dot_product(vecs), + "Negative connection probability in dot-product graph" + ) + + vecs <- cbind(c(1, 1, 1), c(1, 1, 1)) + expect_warning( + g <- sample_dot_product(vecs), + paste0("Greater than 1 connection probability ", "in dot-product graph") + ) +})