tests/testthat/test-link_significance.R

In gi0na/ghypernet: Fit and Simulate Generalised Hypergeometric Ensembles of Graphs

####################################
####################################
####################################
####################################
####################################
################### pvalues ##########
####################################

test_that("link significance returns correct probability for finding exactly or more edges and mhd case", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- scm(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = FALSE, log.p = FALSE, give_pvals = TRUE)
  
  xi <- fit$xi
  manual_p <- matrix(mapply(FUN = stats::phyper, q = as.vector(adj), m = as.vector(xi), n = fit$m^2 - as.vector(xi), 
                            MoreArgs = list(k = fit$m, lower.tail = FALSE)) + 
           mapply(FUN = stats::dhyper, x = as.vector(adj), m = as.vector(xi), n = fit$m^2 - as.vector(xi), 
                  MoreArgs = list(k = fit$m)),3,3)
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding exactly or more edges and wallenius case", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = FALSE, log.p = FALSE, give_pvals = TRUE)
  
  xi <- fit$xi
  xibar <- fit$m^2 - xi
  omegabar <- (sum(fit$xi*fit$omega)-fit$xi*fit$omega)/xibar
  
  manual_p <- matrix(mapply(FUN = BiasedUrn::pWNCHypergeo, x = as.vector(adj), m1 = as.vector(xi), m2 = fit$m^2 - as.vector(xi), 
                            odds = fit$omega/omegabar, MoreArgs = list(n = fit$m,lower.tail = FALSE)) + 
                       mapply(FUN = BiasedUrn::dWNCHypergeo, x = as.vector(adj), m1 = as.vector(xi), m2 = fit$m^2 - as.vector(xi), 
                              odds = fit$omega/omegabar, MoreArgs = list(n = fit$m)),3,3)
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding exactly or more edges and binomial approx case", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = FALSE, log.p = FALSE, give_pvals = TRUE, binomial.approximation = TRUE)
  
  manual_p <- matrix(mapply(FUN = stats::pbinom, q = as.vector(adj), prob = fit$xi*fit$omega/sum(fit$xi*fit$omega), 
                           MoreArgs = list(size = fit$m,lower.tail = FALSE)) + 
                       mapply(FUN = stats::dbinom, x = as.vector(adj), prob = fit$xi*fit$omega/sum(fit$xi*fit$omega),
                              MoreArgs = list(size = fit$m)),3,3)
  
  expect_equal(pvals_over, manual_p)
})

################

test_that("link significance returns correct probability for finding exactly or less edges and mhd case", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- scm(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = TRUE, log.p = FALSE, give_pvals = TRUE)
  
  xi <- fit$xi
  manual_p <- matrix(mapply(FUN = stats::phyper, q = as.vector(adj), m = as.vector(xi), n = fit$m^2 - as.vector(xi), 
                            MoreArgs = list(k = fit$m, lower.tail = TRUE)),3,3)
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding exactly or less edges and wallenius case", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = TRUE, log.p = FALSE, give_pvals = TRUE)
  
  xi <- fit$xi
  xibar <- fit$m^2 - xi
  omegabar <- (sum(fit$xi*fit$omega)-fit$xi*fit$omega)/xibar
  
  manual_p <- matrix(mapply(FUN = BiasedUrn::pWNCHypergeo, x = as.vector(adj), m1 = as.vector(xi), m2 = fit$m^2 - as.vector(xi), 
                            odds = fit$omega/omegabar, MoreArgs = list(n = fit$m,lower.tail = TRUE)),3,3)
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding exactly or less edges and binomial approx case", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = TRUE, log.p = FALSE, give_pvals = TRUE, binomial.approximation = TRUE)
  
  manual_p <- matrix(mapply(FUN = stats::pbinom, q = as.vector(adj), prob = fit$xi*fit$omega/sum(fit$xi*fit$omega), 
                            MoreArgs = list(size = fit$m,lower.tail = TRUE)),3,3)
  
  expect_equal(pvals_over, manual_p)
})


####################################
################### log.p ##########
####################################

test_that("link significance returns correct probability for finding exactly or more edges and mhd case, log value", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- scm(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = FALSE, log.p = TRUE, give_pvals = TRUE)
  
  xi <- fit$xi
  manual_p <- log(matrix(mapply(FUN = stats::phyper, q = as.vector(adj), m = as.vector(xi), n = fit$m^2 - as.vector(xi), 
                            MoreArgs = list(k = fit$m, lower.tail = FALSE)) + 
                       mapply(FUN = stats::dhyper, x = as.vector(adj), m = as.vector(xi), n = fit$m^2 - as.vector(xi), 
                              MoreArgs = list(k = fit$m)),3,3))
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding exactly or more edges and wallenius case, log value", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = FALSE, log.p = TRUE, give_pvals = TRUE)
  
  xi <- fit$xi
  xibar <- fit$m^2 - xi
  omegabar <- (sum(fit$xi*fit$omega)-fit$xi*fit$omega)/xibar
  
  manual_p <- log(matrix(mapply(FUN = BiasedUrn::pWNCHypergeo, x = as.vector(adj), m1 = as.vector(xi), m2 = fit$m^2 - as.vector(xi), 
                            odds = fit$omega/omegabar, MoreArgs = list(n = fit$m,lower.tail = FALSE)) + 
                       mapply(FUN = BiasedUrn::dWNCHypergeo, x = as.vector(adj), m1 = as.vector(xi), m2 = fit$m^2 - as.vector(xi), 
                              odds = fit$omega/omegabar, MoreArgs = list(n = fit$m)),3,3))
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding exactly or more edges and binomial approx case, log value", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = FALSE, log.p = TRUE, give_pvals = TRUE, binomial.approximation = TRUE)
  
  manual_p <- log(matrix(mapply(FUN = stats::pbinom, q = as.vector(adj), prob = fit$xi*fit$omega/sum(fit$xi*fit$omega), 
                            MoreArgs = list(size = fit$m,lower.tail = FALSE)) + 
                       mapply(FUN = stats::dbinom, x = as.vector(adj), prob = fit$xi*fit$omega/sum(fit$xi*fit$omega),
                              MoreArgs = list(size = fit$m)),3,3))
  
  expect_equal(pvals_over, manual_p)
})

################

test_that("link significance returns correct probability for finding exactly or less edges and mhd case, log value", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- scm(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = TRUE, log.p = TRUE, give_pvals = TRUE)
  
  xi <- fit$xi
  manual_p <- matrix(mapply(FUN = stats::phyper, q = as.vector(adj), m = as.vector(xi), n = fit$m^2 - as.vector(xi), 
                            MoreArgs = list(k = fit$m, lower.tail = TRUE, log = TRUE)),3,3)
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding exactly or less edges and wallenius case, log value", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = TRUE, log.p = TRUE, give_pvals = TRUE)
  
  xi <- fit$xi
  xibar <- fit$m^2 - xi
  omegabar <- (sum(fit$xi*fit$omega)-fit$xi*fit$omega)/xibar
  
  manual_p <- log(matrix(mapply(FUN = BiasedUrn::pWNCHypergeo, x = as.vector(adj), m1 = as.vector(xi), m2 = fit$m^2 - as.vector(xi), 
                            odds = fit$omega/omegabar, MoreArgs = list(n = fit$m,lower.tail = TRUE)),3,3))
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding exactly or less edges and binomial approx case, log value", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = TRUE, log.p = TRUE, give_pvals = TRUE, binomial.approximation = TRUE)
  
  manual_p <- matrix(mapply(FUN = stats::pbinom, q = as.vector(adj), prob = fit$xi*fit$omega/sum(fit$xi*fit$omega), 
                            MoreArgs = list(size = fit$m,lower.tail = TRUE, log = TRUE)),3,3)
  
  expect_equal(pvals_over, manual_p)
})

####################################
####################################
####################################
####################################
####################################
################### not pvalues ##########
####################################

test_that("link significance returns correct probability for finding strictly more edges and mhd case", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- scm(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = FALSE, log.p = FALSE, give_pvals = FALSE)
  
  xi <- fit$xi
  manual_p <- matrix(mapply(FUN = stats::phyper, q = as.vector(adj), m = as.vector(xi), n = fit$m^2 - as.vector(xi), 
                            MoreArgs = list(k = fit$m, lower.tail = FALSE)),3,3)
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding strictly more edges and wallenius case", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = FALSE, log.p = FALSE, give_pvals = FALSE)
  
  xi <- fit$xi
  xibar <- fit$m^2 - xi
  omegabar <- (sum(fit$xi*fit$omega)-fit$xi*fit$omega)/xibar
  
  manual_p <- matrix(mapply(FUN = BiasedUrn::pWNCHypergeo, x = as.vector(adj), m1 = as.vector(xi), m2 = fit$m^2 - as.vector(xi), 
                            odds = fit$omega/omegabar, MoreArgs = list(n = fit$m,lower.tail = FALSE)),3,3)
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding strictly more edges and binomial approx case", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = FALSE, log.p = FALSE, give_pvals = FALSE, binomial.approximation = TRUE)
  
  manual_p <- matrix(mapply(FUN = stats::pbinom, q = as.vector(adj), prob = fit$xi*fit$omega/sum(fit$xi*fit$omega), 
                            MoreArgs = list(size = fit$m,lower.tail = FALSE)),3,3)
  
  expect_equal(pvals_over, manual_p)
})

################

test_that("link significance returns correct probability for finding strictly less edges and mhd case", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- scm(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = TRUE, log.p = FALSE, give_pvals = FALSE)
  
  xi <- fit$xi
  manual_p <- matrix(mapply(FUN = stats::phyper, q = as.vector(adj), m = as.vector(xi), n = fit$m^2 - as.vector(xi), 
                            MoreArgs = list(k = fit$m, lower.tail = TRUE)) -
                       mapply(FUN = stats::dhyper, x = as.vector(adj), m = as.vector(xi), n = fit$m^2 - as.vector(xi), 
                              MoreArgs = list(k = fit$m)),3,3)
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding stricly less edges and wallenius case", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = TRUE, log.p = FALSE, give_pvals = FALSE)
  
  xi <- fit$xi
  xibar <- fit$m^2 - xi
  omegabar <- (sum(fit$xi*fit$omega)-fit$xi*fit$omega)/xibar
  
  manual_p <- matrix(mapply(FUN = BiasedUrn::pWNCHypergeo, x = as.vector(adj), m1 = as.vector(xi), m2 = fit$m^2 - as.vector(xi), 
                            odds = fit$omega/omegabar, MoreArgs = list(n = fit$m,lower.tail = TRUE)) -
                       mapply(FUN = BiasedUrn::dWNCHypergeo, x = as.vector(adj), m1 = as.vector(xi), m2 = fit$m^2 - as.vector(xi), 
                              odds = fit$omega/omegabar, MoreArgs = list(n = fit$m)),3,3)
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding stricly less edges and binomial approx case", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = TRUE, log.p = FALSE, give_pvals = FALSE, binomial.approximation = TRUE)
  
  manual_p <- matrix(mapply(FUN = stats::pbinom, q = as.vector(adj), prob = fit$xi*fit$omega/sum(fit$xi*fit$omega), 
                            MoreArgs = list(size = fit$m,lower.tail = TRUE)) -
                       mapply(FUN = stats::dbinom, x = as.vector(adj), prob = fit$xi*fit$omega/sum(fit$xi*fit$omega), 
                              MoreArgs = list(size = fit$m)),3,3)
  
  expect_equal(pvals_over, manual_p)
})


####################################
################### log.p ##########
####################################

test_that("link significance returns correct probability for finding strictly more edges and mhd case, log", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- scm(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = FALSE, log.p = TRUE, give_pvals = FALSE)
  
  xi <- fit$xi
  manual_p <- matrix(mapply(FUN = stats::phyper, q = as.vector(adj), m = as.vector(xi), n = fit$m^2 - as.vector(xi), 
                            MoreArgs = list(k = fit$m, lower.tail = FALSE, log=TRUE)),3,3)
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding strictly more edges and wallenius case, log", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = FALSE, log.p = TRUE, give_pvals = FALSE)
  
  xi <- fit$xi
  xibar <- fit$m^2 - xi
  omegabar <- (sum(fit$xi*fit$omega)-fit$xi*fit$omega)/xibar
  
  manual_p <- log(matrix(mapply(FUN = BiasedUrn::pWNCHypergeo, x = as.vector(adj), m1 = as.vector(xi), m2 = fit$m^2 - as.vector(xi), 
                            odds = fit$omega/omegabar, MoreArgs = list(n = fit$m,lower.tail = FALSE)),3,3))
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding strictly more edges and binomial approx case, log", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = FALSE, log.p = TRUE, give_pvals = FALSE, binomial.approximation = TRUE)
  
  manual_p <- matrix(mapply(FUN = stats::pbinom, q = as.vector(adj), prob = fit$xi*fit$omega/sum(fit$xi*fit$omega), 
                            MoreArgs = list(size = fit$m,lower.tail = FALSE, log = TRUE)),3,3)
  
  expect_equal(pvals_over, manual_p)
})

################

test_that("link significance returns correct probability for finding strictly less edges and mhd case, log", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- scm(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = TRUE, log.p = TRUE, give_pvals = FALSE)
  
  xi <- fit$xi
  manual_p <- log(matrix(mapply(FUN = stats::phyper, q = as.vector(adj), m = as.vector(xi), n = fit$m^2 - as.vector(xi), 
                            MoreArgs = list(k = fit$m, lower.tail = TRUE)) -
                       mapply(FUN = stats::dhyper, x = as.vector(adj), m = as.vector(xi), n = fit$m^2 - as.vector(xi), 
                              MoreArgs = list(k = fit$m)),3,3))
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding stricly less edges and wallenius case, log", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = TRUE, log.p = TRUE, give_pvals = FALSE)
  
  xi <- fit$xi
  xibar <- fit$m^2 - xi
  omegabar <- (sum(fit$xi*fit$omega)-fit$xi*fit$omega)/xibar
  
  manual_p <- log(matrix(mapply(FUN = BiasedUrn::pWNCHypergeo, x = as.vector(adj), m1 = as.vector(xi), m2 = fit$m^2 - as.vector(xi), 
                            odds = fit$omega/omegabar, MoreArgs = list(n = fit$m,lower.tail = TRUE)) -
                       mapply(FUN = BiasedUrn::dWNCHypergeo, x = as.vector(adj), m1 = as.vector(xi), m2 = fit$m^2 - as.vector(xi), 
                              odds = fit$omega/omegabar, MoreArgs = list(n = fit$m)),3,3))
  
  expect_equal(pvals_over, manual_p)
})

test_that("link significance returns correct probability for finding stricly less edges and binomial approx case, log", {
  adj <- matrix(c(0,4,0,2,0,0,3,0,0),3,3)
  fit <- ghype(adj,T,T)
  pvals_over <- link_significance(graph = adj, model = fit, under = TRUE, log.p = TRUE, give_pvals = FALSE, binomial.approximation = TRUE)
  
  manual_p <- log(matrix(mapply(FUN = stats::pbinom, q = as.vector(adj), prob = fit$xi*fit$omega/sum(fit$xi*fit$omega), 
                            MoreArgs = list(size = fit$m,lower.tail = TRUE)) -
                       mapply(FUN = stats::dbinom, x = as.vector(adj), prob = fit$xi*fit$omega/sum(fit$xi*fit$omega), 
                              MoreArgs = list(size = fit$m)),3,3))
  
  expect_equal(pvals_over, manual_p)
})