tests/testthat/test-estimate-params.R

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

set.seed(334)
# Prepare data
edgelist <-
  tibble::tribble(
    ~head, ~tail,
    1, 9,
    2, 6,
    2, 7,
    2, 9,
    3, 5,
    3, 9,
    4, 7,
    4, 11,
    4, 15,
    5, 11,
    5, 15,
    7, 8,
    7, 16,
    9, 13,
    9, 14,
    9, 16,
    10, 14,
    11, 15,
    13, 15,
    13, 16
  )
edgelist <-
  as.matrix(edgelist)
attr(edgelist, "n") <- 16
attr(edgelist, "vnames") <-
  c(
    "Acciaiuoli", "Albizzi", "Barbadori", "Bischeri", "Castellani", "Ginori",
    "Guadagni", "Lamberteschi", "Medici", "Pazzi", "Peruzzi", "Pucci", "Ridolfi",
    "Salviati", "Strozzi", "Tornabuoni"
  )
attr(edgelist, "directed") <- FALSE
attr(edgelist, "bipartite") <- FALSE
attr(edgelist, "loops") <- FALSE
attr(edgelist, "class") <- c("edgelist", "matrix")
g <- network::network(edgelist, matrix.type = "edgelist", directed = FALSE)
g%v%"vertex.names" <- 1:length(g%v%"vertex.names")
x1 <- as.integer(unlist(rbinom(size = 1,prob = 0.5,n = g$gal$n)))
network::set.vertex.attribute(x = g, attrname = "x1", value = x1)

# Cluster
z_memb <- rep(1:4, each = 4)
network::set.vertex.attribute(x = g, attrname = "block", value = z_memb)

# Create dataset for test
g_link <- intergraph::asDF(g)$edges
g_attr <- intergraph::asDF(g)$vertexes



df_g <-
  tibble::tibble(
    head = 1:g$gal$n,
    tail = 1:g$gal$n
  ) %>%
  tidyr::expand(.data$tail, .data$head) %>%
  dplyr::filter(.data$tail < .data$head) %>%
  dplyr::left_join(., g_attr, by = c("tail" = "intergraph_id")) %>%
  dplyr::left_join(., g_attr, by = c("head" = "intergraph_id")) %>%
  dplyr::mutate(
    nodematch.x1 = ifelse(x1.x == x1.y, 1, 0),
    same_block = ifelse(block.x == block.y, 1, 0)
  ) %>%
  dplyr::select("tail", "head", "nodematch.x1":"same_block") %>%
  dplyr::left_join(., g_link, by = c("tail" = "V1", "head" = "V2")) %>%
  dplyr::mutate(connected = ifelse(is.na(na), 0, 1)) %>%
  dplyr::select(-"na")



# Estimate the model
formula <- g ~ edges + nodematch("x1") + triangle + kstar(2)
g %v% "block" <- z_memb

est_between <- est_between(
  formula = formula,
  network = g,
  add_intercepts = FALSE
)

est_within <- est_within(
  formula = g ~ edges + nodematch("x1"),
  network = g, seed = 1,
  method_within = "MPLE", 
  add_intercepts = FALSE
)


test_that("estimating between-block parameters by logit works", {
  # Check if between-block connections are all zero.
  g_logit <- g
  edgelist <- intergraph::asDF(g_logit)$edges

  true_edgelist <-
    df_g %>%
    dplyr::filter(same_block == 0 & connected == 1) %>%
    dplyr::select("tail", "head") %>%
    dplyr::arrange(tail, head)
  
  # Check if estimates for between-block parameters are the same.
  param_est <- stats::coef(est_between)
  
  logit_true_between <- glm(
    formula = connected ~ nodematch.x1,
    data = df_g[df_g$same_block ==0,],
    family = "binomial"
  )
  logit_true_within <- glm(
    formula = connected ~ nodematch.x1,
    data = df_g[df_g$same_block ==1,],
    family = "binomial"
  )
  
  # Does it work?
  expect_equal(est_within$coefficients, 
               logit_true_within$coefficients,
               check.attributes = FALSE, tolerance = 1e-7)
  expect_equal(est_between$coefficients, 
               logit_true_between$coefficients, 
               check.attributes = FALSE, tolerance = 1e-7)
  
})