tests/testthat/test-degree-scaling.R

In fastRG: Sample Generalized Random Dot Product Graphs in Linear Time

library(magrittr)

test_that("expected_degrees() has dimension and correctness", {
  n <- 100
  k <- 5

  set.seed(143)

  X <- matrix(rpois(n = n * k, 1), nrow = n)
  S <- matrix(runif(n = k * k, 0, .1), nrow = k)

  ufm <- undirected_factor_model(X, S)

  # dimensional correctness
  expect_equal(
    length(expected_degrees(ufm)),
    n
  )

  # numerical correctness
  expect_equal(
    expected_degrees(ufm),
    rowSums(ufm$X %*% tcrossprod(ufm$S, ufm$X))
  )
})


test_that("undirected expected degree computed consistently", {

  # see issue 19

  set.seed(27)

  n <- 1000
  pop <- n / 2
  a <- .1
  b <- .05
  B <- matrix(c(a, b, b, a), nrow = 2)

  b_model <- sbm(
    n = n, k = 2,
    B = B,
    poisson_edges = FALSE
  )

  expect_equal(
    expected_degree(b_model), # computed
    pop * a + pop * b,       # expected "undirected edge degree",
    tolerance = 5
  )

  A <- sample_sparse(b_model)

  ### degree computation gotchas

  mean(rowSums(A))  # double counts undirected edges
  #> [1] 156.711
  mean(rowSums(triu(A)))  # right way to count undirected edges in A
  #> [1] 78.413

  expect_equal(
    mean(rowSums(triu(A))), # computed
    pop * a + pop * b,      # expected "undirected edge degree"
    tolerance = 5
  )

  model2 <- sbm(n = n, k = 2, B = B, poisson_edges = FALSE, expected_degree = 75)

  expect_equal(
    expected_degree(model2), # computed
    pop * a + pop * b,       # expected "undirected edge degree",
    tolerance = 5
  )

  A2 <- sample_sparse(model2)

  expect_equal(
    mean(rowSums(triu(A2))), # computed
    pop * a + pop * b,       # expected "undirected edge degree",
    tolerance = 5
  )

})

test_that("undirected density computed consistently", {

  # see issue 19

  set.seed(27)

  n <- 1000
  pop <- n / 2
  a <- .1
  b <- .05
  B <- matrix(c(a, b, b, a), nrow = 2)

  b_model <- sbm(
    n = n, k = 2,
    B = B,
    poisson_edges = FALSE
  )

  expect_equal(
    expected_density(b_model),              # computed
    n * (pop * a + pop * b) / choose(n, 2), # expected undirected degree density, possibly being a little sloppy about the diagonal
    tolerance = 0.05
  )

  A <- sample_sparse(b_model)

  ### density computation gotchas

  # almost correct because double counts UT and LT in num and denom,
  # but diagonal gets too much weight. slight over-estimate of density
  sum(A) / n^2

  sum(triu(A)) / choose(n, 2)  # correct density estimate

  expect_equal(
    sum(triu(A)) / choose(n, 2),            # computed
    n * (pop * a + pop * b) / choose(n, 2), # expected "undirected edge degree",
    tolerance = 0.05
  )

  model2 <- sbm(n = n, k = 2, B = B, expected_density = 0.15)

  expect_equal(
    expected_density(model2),              # computed
    n * (pop * a + pop * b) / choose(n, 2), # expected undirected degree density, possibly being a little sloppy about the diagonal
    tolerance = 0.02
  )

  A2 <- sample_sparse(model2)

  expect_equal(
    sum(triu(A2)) / choose(n, 2),            # computed
    0.15, # expected "undirected edge degree",
    tolerance = 0.05
  )

})

test_that("undirected factor model", {

  library(tidygraph)

  set.seed(7)

  n <- 1000
  k <- 5

  # don't allow self edges at all in these calculations via
  # SBM model with zero on the diagonal of B

  B <- matrix(data = 0.5, nrow = k, ncol = k)
  diag(B) <- 0

  ufm <- sbm(n = n, k = k, B = B, expected_degree = 10)
  expect_equal(expected_degree(ufm), 10)
  expect_equal(expected_density(ufm), 0.02, tolerance = 0.05) # tolerance should be relative here


  el <- sample_edgelist(ufm)
  el_mean_degree <- nrow(el) / n
  expect_lt(9, el_mean_degree)
  expect_lt(el_mean_degree, 11)

  g2 <- igraph::graph_from_data_frame(el, directed = TRUE)
  A <- igraph::as_adj(g2)

  # NOTE: see issue #19 about the following
  #
  # mean(rowSums(A))        # double counts undirected edges
  # mean(rowSums(triu(A)))  # right way to count undirected edges

  A <- sample_sparse(ufm)
  matrix_mean_degree <- mean(rowSums(triu(A)))

  expect_equal(rowSums(A), colSums(A))
  expect_lt(9, matrix_mean_degree)
  expect_lt(matrix_mean_degree, 11)


  graph <- sample_igraph(ufm)
  # igraph doubles edge counts relative to the way we want to count
  igraph_mean_degree <- mean(igraph::degree(graph)) / 2

  expect_lt(9, igraph_mean_degree)
  expect_lt(igraph_mean_degree, 11)


  tbl_graph <- sample_tidygraph(ufm)
  tbl_graph_edges <- tbl_graph %>%
    activate(edges) %>%
    as_tibble() %>%
    nrow()

  tbl_graph_mean_degree <- tbl_graph_edges / n

  expect_lt(9, tbl_graph_mean_degree)
  expect_lt(tbl_graph_mean_degree, 11)

  expect_silent(eigs_sym(ufm))
})

test_that("directed factor model", {

  set.seed(8)

  library(dplyr)

  n <- 5000
  d <- 800

  k1 <- 5
  k2 <- 3

  X <- matrix(rpois(n = n * k1, 1), nrow = n)
  Y <- matrix(rpois(n = d * k2, 1), nrow = d)
  S <- matrix(runif(n = k1 * k2, 0, .1), nrow = k1)

  dfm <- directed_factor_model(X = X, S = S, Y = Y, expected_in_degree = 10)
  expect_equal(expected_in_degree(dfm), 10)

  dfm2 <- directed_factor_model(X = X, S = S, Y = Y, expected_out_degree = 100)
  expect_equal(expected_out_degree(dfm2), 100)

  dfm3 <- directed_factor_model(X = X, S = S, Y = Y, expected_density = 0.1)
  expect_equal(expected_density(dfm3), 0.1)


  ### edgelist tests -----------------------------------------------------------

  el <- sample_edgelist(dfm)

  el_mean_in_degree <- el %>%
    count(to) %>%
    pull(n) %>%
    mean()

  expect_lt(9, el_mean_in_degree)
  expect_lt(el_mean_in_degree, 11)



  el2 <- sample_edgelist(dfm2)

  el2_mean_out_degree <- el2 %>%
    count(from) %>%
    pull(n) %>%
    mean()

  expect_lt(95, el2_mean_out_degree)
  expect_lt(el2_mean_out_degree, 105)



  el3 <- sample_edgelist(dfm3)

  el3_density <- nrow(el3) / as.numeric(n * d)

  expect_lt(0.08, el3_density)
  expect_lt(el3_density, 0.12)


  ### sparse matrix tests ------------------------------------------------------

  A <- sample_sparse(dfm)
  matrix_mean_in_degree <- mean(colSums(A))

  expect_lt(9, matrix_mean_in_degree)
  expect_lt(matrix_mean_in_degree, 11)


  A2 <- sample_sparse(dfm2)
  matrix_mean_out_degree <- mean(rowSums(A2))

  expect_lt(95, matrix_mean_out_degree)
  expect_lt(matrix_mean_out_degree, 105)


  A3 <- sample_sparse(dfm3)
  A3_density <- mean(A3)

  expect_lt(0.08, A3_density)
  expect_lt(A3_density, 0.12)

  ### igraph tests --------------------------------------------------------------

  ig <- sample_igraph(dfm)
  A_ig <- igraph::as_incidence_matrix(ig, sparse = TRUE, names = FALSE)
  ig_mean_in_degree <- mean(colSums(A_ig))

  expect_lt(9, ig_mean_in_degree)
  expect_lt(ig_mean_in_degree, 11)


  ig2 <- sample_igraph(dfm2)
  A2_ig <- igraph::as_incidence_matrix(ig2, sparse = TRUE, names = FALSE)
  ig2_mean_out_degree <- mean(rowSums(A2_ig))


  expect_lt(95, ig2_mean_out_degree)
  expect_lt(ig2_mean_out_degree, 105)


  ig3 <- sample_igraph(dfm3)
  ig3_density <- igraph::ecount(ig3) / as.numeric(n * d)

  expect_lt(0.08, ig3_density)
  expect_lt(ig3_density, 0.12)


  ### tidygraph tests ----------------------------------------------------------

  tg <- sample_tidygraph(dfm)
  A_tg <- igraph::as_incidence_matrix(tg, sparse = TRUE, names = FALSE)
  tg_mean_in_degree <- mean(colSums(A_tg))

  expect_lt(9, tg_mean_in_degree)
  expect_lt(tg_mean_in_degree, 11)


  tg2 <- sample_tidygraph(dfm2)
  A2_tg <- igraph::as_incidence_matrix(tg2, sparse = TRUE, names = FALSE)
  tg2_mean_out_degree <- mean(rowSums(A2_tg))


  expect_lt(95, tg2_mean_out_degree)
  expect_lt(tg2_mean_out_degree, 105)


  tg3 <- sample_tidygraph(dfm3)
  tg3_density <- igraph::ecount(tg3) / as.numeric(n * d)

  expect_lt(0.08, tg3_density)
  expect_lt(tg3_density, 0.12)


  ### decomposition sanity check -----------------------------------------------

  expect_silent(svds(dfm))
})