tests/testthat/test-compute_pi_d1x0.R

In bigergm: Fit, Simulate, and Diagnose Hierarchical Exponential-Family Models for Big Networks

test_that("computing pi_d1x0 works", {
  # Number of nodes
  N <- 12
  # Number of clusters
  K <- 3

  # Create an adjacency matrix
  edgelist <-
    tibble::tibble(
      tail = 1:N,
      head = 1:N
    ) %>%
    tidyr::expand(tail, head) %>%
    dplyr::filter(tail < head) %>%
    dplyr::mutate(connect = rep(0:1, nrow(.) / 2)) %>%
    dplyr::filter(connect == 1)

  net <- network::network(edgelist, matrix.type = "edgelist", directed = FALSE)
  adj <- network::as.matrix.network.adjacency(net)
  adj <- as(adj, "dgCMatrix")

  # Create feature matrices
  x <- as.integer(unlist(rbinom(size = 1,prob = 0.5,n = N)))
  S <- Matrix::sparseMatrix(i = {}, j = {}, dims = c(N, N))
  S <- as(S, "dgCMatrix")
  for (i in 1:N) {
    for (j in 1:N) {
      if (i != j) {
        s_ij <- ifelse(x[i] == x[j], 1, 0)
        S[i, j] <- s_ij
      }
    }
  }

  y <- as.integer(unlist(rbinom(size = 1,prob = 0.5,n = N)))
  V <- Matrix::sparseMatrix(i = {}, j = {}, dims = c(N, N))
  V <- as(V, "dgCMatrix")
  for (i in 1:N) {
    for (j in 1:N) {
      if (i != j) {
        v_ij <- ifelse(y[i] == y[j], 1, 0)
        V[i, j] <- v_ij
      }
    }
  }

  z <- as.integer(unlist(rbinom(size = 1,prob = 0.5,n = N)))
  W <- Matrix::sparseMatrix(i = {}, j = {}, dims = c(N, N))
  W <- as(W, "dgCMatrix")
  for (i in 1:N) {
    for (j in 1:N) {
      if (i != j) {
        w_ij <- ifelse(z[i] == z[j], 1, 0)
        W[i, j] <- w_ij
      }
    }
  }



  # Create a N x K matrix whose (i, k) element represents the probability that node i belongs to block k.
  tau <-
    matrix(c(
      0.2, 0.5, 0.3,
      0.4, 0.4, 0.2,
      0.1, 0.4, 0.5,
      0.4, 0.4, 0.2,
      0.1, 0.1, 0.8,
      0.05, 0.05, 0.9,
      0.8, 0.1, 0.1,
      0.3, 0.4, 0.3,
      0.1, 0.8, 0.1,
      0.5, 0.4, 0.1,
      0.3, 0.3, 0.4,
      0.8, 0.1, 0.1
    ),
    nrow = K, ncol = N
    )
  tau <- t(tau)

  # Compute the true denominator
  one <- matrix(1, nrow = N, ncol = N)
  mat <- (one - S) * (one - V) * (one - W)
  diag(mat) <- 0
  denom_for_pi0_true <- t(tau) %*% mat %*% tau
  denom_for_pi0_true <- as.matrix(denom_for_pi0_true)

  # Compute the true denominator in a naive way
  denom_for_pi0_naive <- matrix(0, nrow = K, ncol = K)
  for (k in 1:K) {
    for (l in 1:K) {
      for (i in 1:N) {
        for (j in 1:N) {
          if (i != j & S[i, j] == 0 & V[i, j] == 0 & W[i, j] == 0) {
            denom_for_pi0_naive[k, l] <- denom_for_pi0_naive[k, l] + tau[i, k] * tau[j, l]
          }
        }
      }
    }
  }

  # Check if they are the same. This verifies that the formula is correct.
  expect_equal(denom_for_pi0_true, denom_for_pi0_naive, check.attributes = FALSE, tolerance = 1e-10)

  # Compute the denominator using the c++ function
  denom <- get_matrix_for_denominator_R(N, list(S, V, W))
  denom_for_pi0 <- compute_denominator_for_pi_d1x0(N, K, denom, tau, verbose = 0)

  # Check if the computed matrix is correct.
  expect_equal(denom_for_pi0, denom_for_pi0_naive, check.attributes = FALSE, tolerance = 1e-10)


  # Compute true pi1 in a naive way
  pi1 <- matrix(0, nrow = K, ncol = K)
  for (k in 1:K) {
    for (l in 1:K) {
      for (i in 1:N) {
        for (j in 1:N) {
          if (i != j & adj[i, j] == 1 & S[i, j] == 0 & V[i, j] == 0 & W[i, j] == 0) {
            pi1[k, l] <- pi1[k, l] + tau[i, k] * tau[j, l]
          }
        }
      }
    }
  }
  pi1_true <- pi1 / denom_for_pi0_naive

  # Remove extremely small values in pi1
  minPi <- 1e-4
  for (k in 1:K) {
    for (l in 1:K) {
      if (pi1_true[k, l] < minPi) {
        pi1_true[k, l] <- minPi
      }
    }
  }

  # Compute pi0 using the Rcpp function
  list_multiplied_adjmat <- get_elementwise_multiplied_matrices_R(adj, list(S, V, W))
  list_multiplied_adjmat[[1]] <- denom
  list_multiplied_adjmat <- lapply(list_multiplied_adjmat, FUN = function(x) x*1)
  
  pi1 <- compute_pi_d1x0(N, K, list_multiplied_adjmat, tau, verbose = 0)

  # Check if the computed conditional probability is correct.
  expect_equal(pi1, pi1_true, check.attributes = FALSE, tolerance = 1e-10)
})