added hsbm tests to game tests

tests/testthat/test-games.R

@@ -463,3 +463,144 @@ test_that("permutation works for sample_correlated_gnp", {
   gnp_graph <- permute(gnp_graph, perm)
   expect_equal(gnp_graph[], cor_gnp_graph[])
 })
+
+test_that("HSBM works", {
+  withr::local_seed(42)
+
+  C <- matrix(c(
+    1, 1 / 2, 0,
+    1 / 2, 0, 1 / 2,
+    0, 1 / 2, 1 / 2
+  ), nrow = 3)
+
+  g_hsbm1 <- sample_hierarchical_sbm(100, 10, rho = c(3, 3, 4) / 10, C = C, p = 0)
+  expect_equal(ecount(g_hsbm1), 172)
+  expect_equal(vcount(g_hsbm1), 100)
+  expect_false(is_directed(g_hsbm1))
+
+  withr::local_seed(42)
+
+  g_hsbm2 <- sample_hierarchical_sbm(100, 10, rho = c(3, 3, 4) / 10, C = C, p = 1)
+  expect_equal(ecount(g_hsbm2), ecount(g_hsbm1) + 10 * 9 * (90 + 10) / 2)
+  expect_equal(vcount(g_hsbm2), 100)
+  expect_true(is_simple(g_hsbm2))
+
+  withr::local_seed(42)
+
+  g_hsbm3 <- sample_hierarchical_sbm(100, 10, rho = c(3, 3, 4) / 10, C = C, p = 1e-15)
+  expect_equal(ecount(g_hsbm3), ecount(g_hsbm1))
+  expect_equal(vcount(g_hsbm3), 100)
+  expect_true(is_simple(g_hsbm3))
+
+  withr::local_seed(42)
+
+  g_hsbm4 <- sample_hierarchical_sbm(100, 10, rho = c(3, 3, 4) / 10, C = C, p = 1 - 1e-15)
+  expect_equal(ecount(g_hsbm4), ecount(g_hsbm2))
+  expect_equal(vcount(g_hsbm4), 100)
+  expect_true(is_simple(g_hsbm4))
+})
+
+test_that("HSBM with 1 cluster per block works", {
+  res <- Matrix::Matrix(0, nrow = 10, ncol = 10, doDiag = FALSE)
+  res[6:10, 1:5] <- res[1:5, 6:10] <- 1
+  g_hsbm <- sample_hierarchical_sbm(10, 5, rho = 1, C = matrix(0), p = 1)
+  expect_equal(g_hsbm[], res)
+})
+
+test_that("HSBM with list arguments works", {
+  blocks <- 5
+  C <- matrix(c(
+    1, 1 / 2, 0,
+    1 / 2, 0, 1 / 2,
+    0, 1 / 2, 1 / 2
+  ), nrow = 3)
+  vertices_per_block <- 10
+  rho <- c(3, 3, 4) / 10
+
+  withr::local_seed(42)
+  g_hsbm1 <- sample_hierarchical_sbm(
+    blocks * vertices_per_block,
+    vertices_per_block,
+    rho = rho, C = C, p = 0
+  )
+
+  withr::local_seed(42)
+  g_hsbm2 <- sample_hierarchical_sbm(
+    blocks * vertices_per_block,
+    rep(vertices_per_block, blocks),
+    rho = rho, C = C, p = 0
+  )
+  expect_equal(g_hsbm1[], g_hsbm2[])
+
+  withr::local_seed(42)
+  g_hsbm3 <- sample_hierarchical_sbm(
+    blocks * vertices_per_block,
+    vertices_per_block,
+    rho = replicate(blocks, rho, simplify = FALSE), C = C, p = 0
+  )
+  expect_equal(g_hsbm1[], g_hsbm3[])
+
+  withr::local_seed(42)
+  g_hsbm4 <- sample_hierarchical_sbm(
+    blocks * vertices_per_block,
+    vertices_per_block,
+    rho = rho, C = replicate(blocks, C, simplify = FALSE), p = 0
+  )
+
+  expect_equal(g_hsbm1[], g_hsbm4[])
+
+  expect_error(
+    sample_hierarchical_sbm(
+      blocks * vertices_per_block,
+      rep(vertices_per_block, blocks),
+      rho = list(rho, rho), C = C, p = 0
+    ),
+    "Lengths of `m', `rho' and `C' must match"
+  )
+
+  ###
+
+  n <- function(x) x / sum(x)
+
+  rho1 <- n(c(1, 2))
+  C1 <- matrix(0, nrow = 2, ncol = 2)
+  rho2 <- n(c(3, 3, 4))
+  C2 <- matrix(0, nrow = 3, ncol = 3)
+  rho3 <- 1
+  C3 <- matrix(0)
+  rho4 <- n(c(2, 1))
+  C4 <- matrix(0, nrow = 2, ncol = 2)
+
+  g_hsbm5 <- sample_hierarchical_sbm(21,
+    m = c(3, 10, 5, 3), rho = list(rho1, rho2, rho3, rho4),
+    C = list(C1, C2, C3, C4), p = 1
+  )
+  expect_true(is_simple(g_hsbm5))
+
+  withr::local_seed(42)
+  g_hsbm6 <- sample_hierarchical_sbm(21,
+    m = c(3, 10, 5, 3), rho = list(rho1, rho2, rho3, rho4),
+    C = list(C1, C2, C3, C4), p = 1 - 1e-10
+  )
+  expect_equal(g_hsbm5[], g_hsbm6[])
+
+  rho1 <- n(c(1, 2))
+  C1 <- matrix(1, nrow = 2, ncol = 2)
+  rho2 <- n(c(3, 3, 4))
+  C2 <- matrix(1, nrow = 3, ncol = 3)
+  rho3 <- 1
+  C3 <- matrix(1)
+  rho4 <- n(c(2, 1))
+  C4 <- matrix(1, nrow = 2, ncol = 2)
+  g_hsbm7 <- sample_hierarchical_sbm(21,
+    m = c(3, 10, 5, 3), rho = list(rho1, rho2, rho3, rho4),
+    C = list(C1, C2, C3, C4), p = 0
+  )
+  expect_true(is_simple(g_hsbm7))
+
+  g_hsbm8 <- sample_hierarchical_sbm(21,
+    m = c(3, 10, 5, 3), rho = list(rho1, rho2, rho3, rho4),
+    C = list(C1, C2, C3, C4), p = 1
+  )
+  expect_equal(g_hsbm5[] + g_hsbm7[], g_hsbm8[])
+})