tests/testthat/test-rewire.R

In srdyal/diffusiontest: Analysis of Diffusion and Contagion Processes on Networks

context("Rewiring algorithms")

# Rewiring ---------------------------------------------------------------------
test_that("Rewiring methods", {
  # Generating the data
  set.seed(1291)

  # Static graphs
  graphdg <- rgraph_ba(t=9)
  graphmt <- as.matrix(graphdg)

  set.seed(123); graphdg <- rewire_graph(graphdg, .3)
  set.seed(123); graphmt <- rewire_graph(graphmt, .3)

  expect_equal(graphdg, graphmt)

  # Dynamic graphs
  graphls <- lapply(1:3, function(x) rgraph_ba(t=9))
  names(graphls) <- 2001:2003
  toa <- sample(c(2001:2003, NA), 10, TRUE)

  graphdn <- as_diffnet(graphls, toa, t0=2001, t1=2003)$graph
  graphar <- lapply(graphls, as.matrix)
  graphar <- array(unlist(graphar), dim=c(10,10,3),
                   dimnames = list(1:10, 1:10, 2001:2003))

  set.seed(123); graphls <- rewire_graph(graphls, .3)
  set.seed(123); graphdn <- rewire_graph(graphdn, .3)
  set.seed(123); graphar <- rewire_graph(graphar, .3)

  expect_equal(graphls, graphdn)
  expect_equal(graphar, graphdn)

})

test_that("Rewiring must hold graph's density", {
  set.seed(1231)

  ntimes <- 5

  # BA model
  test <- NULL
  for (i in 1:ntimes) {
    for (j in 1:ntimes) {
      graph <- rgraph_ba(t=9)
      test <- c(test, sum(graph) == sum(rewire_graph(graph, p=.5, undirected = FALSE)))
    }
  }
  expect_true(all(test))

  # Bernoulli
  test <- NULL
  for (i in 1:ntimes) {
    for (j in 1:ntimes) {
      graph  <- rgraph_er(undirected = TRUE)
      suppressWarnings(graphr <- rewire_graph(graph, p=.5, undirected = TRUE))
      test <- c(test, sum(graph) == sum(graphr))
    }
  }

  expect_true(all(test))
})

test_that("When p=1 in rewiring, Pr(j'=i) = Pr(j'=k) for all (i,k) in V", {
  # Generating seed graph
  set.seed(2991)
  n <- 1e2
  x <- ring_lattice(n, 2)

  # Simulating
  N <- 1e3
  out <- lapply(seq_len(N), function(y) {
    y <- rewire_graph(x, p=1.0, self = TRUE, undirected = FALSE, both.ends = FALSE,
                      multiple = FALSE)
    y <- as.matrix(y)
    colSums(y)/sum(y)
  })

  # # Computing the probability that an j was picked.
  out <- do.call(rbind, out)
  m   <- colMeans(out)

  # Case by case (should be pretty close)
  x <- rep(0, length(m))
  names(x) <- names(m)
  # plot(m-1/n, type="l", ylim=c(-.00025,.00025))
  expect_equal(m - 1/(n), x, tolerance=.00025, check.attributes=FALSE)
})

# Rewiring degree preserve
test_that("rewire_graph_const_cpp should hold degree", {
  set.seed(18231)
  n <- 5e2
  N <- 1e2

  # Function to compute degrees
  dfun <- function(x) cbind(dgr(x, "indegree"), dgr(x, "outdegree"))

  # Directed graph
  out <- vector(length = n)
  for (i in 1:n) {
    x  <- rgraph_ba(t=N-1)
    x  <- netdiffuseR:::sp_diag(x, rep(0, N))
    d0 <- dfun(x)
    y  <- netdiffuseR:::rewire_swap(x, 100)
    d1 <- dfun(y)

    out[i] <- identical(d0, d1)
  }
  expect_equal(out, rep(TRUE, n))

  # Undirected graph
  out <- vector(length = n)
  for (i in 1:n) {
    x  <- rgraph_ws(n=N-1, k=4, p=.3)
    d0 <- dfun(x)
    y  <- netdiffuseR:::rewire_swap(x, 100, undirected = FALSE)
    d1 <- dfun(y)

    out[i] <- identical(d0, d1)
  }
  expect_equal(out, rep(TRUE, n))


  # # Alternating exagons (hold deg seq)
  # out <- vector(length=n)
  # for (i in 1:n) {
  #   g0 <- rgraph_ba(t = 99, self=FALSE)
  #   d0 <- dfun(g0)
  #   g1 <- netdiffuseR:::rewire_swap(g, althexagons = TRUE)
  #   d1 <- dfun(g1)
  #   out[i] <- identical(d0,d1)
  # }
  # expect_true(all(out))



})

# ------------------------------------------------------------------------------
test_that("rewire_permute", {
  set.seed(12313123)
  N <- 10
  g <- rgraph_ba(m=4, t=9)

  # Shouldn't change density
  ans <- vector("logical", N)
  for (i in 1:10)
    ans[i] <- nlinks(permute_graph(g)) == nlinks(g)
  expect_true(all(ans))

  # Shouldn't change value
  ans <- vector("logical", N)
  for (i in 1:10)
    ans[i] <- sum(permute_graph(g)) == sum(g)
  expect_true(all(ans))

  # Should be equivalent
  set.seed(1); ans0 <- permute_graph(g)
  set.seed(1); ans1 <- permute_graph(as.matrix(g))
  set.seed(1); ans2 <- permute_graph(list(g))
  set.seed(1); ans3 <- permute_graph(as.array(as.matrix(g), dim=c(10,10,1)))

  expect_equal(ans0, ans1)
  expect_equal(ans0, ans2[[1]])
  expect_equal(ans0, ans3)

  # Checking diffnet
  g <- lapply(1:5, function(x) g)
  dn <- as_diffnet(g, toa=rep(1:5, 2))

  set.seed(1); ans0 <- permute_graph(g)
  set.seed(1); ans1 <- permute_graph(dn)
  expect_equivalent(ans0, dn$graph)
})

# ------------------------------------------------------------------------------
test_that("rewire_qap", {
  set.seed(12313123)
  N <- 10
  g <- rgraph_ba(m=4, t=9)

  # Shouldn't change density
  ans <- vector("logical", N)
  for (i in 1:10)
    ans[i] <- nlinks(rewire_qap(g)) == nlinks(g)
  expect_true(all(ans))

  # Shouldn't change value
  ans <- vector("logical", N)
  for (i in 1:10)
    ans[i] <- sum(rewire_qap(g)) == sum(g)
  expect_true(all(ans))

  # Should be equivalent
  set.seed(1); ans0 <- rewire_qap(g)
  set.seed(1); ans1 <- rewire_qap(as.matrix(g))
  set.seed(1); ans2 <- rewire_qap(list(g))
  set.seed(1); ans3 <- rewire_qap(as.array(as.matrix(g), dim=c(10,10,1)))

  # Checking diffnet
  g <- lapply(1:5, function(x) g)
  dn <- as_diffnet(g, toa=rep(1:5, 2))
  dn[["dynatt"]]    <- lapply(1:5, function(x) runif(10))
  dn[["staticatt"]] <- rnorm(10)

  set.seed(1); ans0 <- rewire_qap(dn)
  set.seed(1); ans1 <- rewire_qap(dn$graph)

  expect_equivalent(ans0$graph, ans1)

  # Checking attributes ordering
  ans0 <- dn$vertex.dyn.attrs
  ans1 <- rewire_qap(dn)
  ids  <- match(nodes(dn), nodes(ans1))
  ans1 <- Map(function(x) x[ids,,drop=FALSE], ans1$vertex.dyn.attrs)
  expect_equivalent(ans0,ans1)

  ans0 <- dn$vertex.static.attrs
  ans1 <- rewire_qap(dn)
  ids  <- match(nodes(dn), nodes(ans1))
  ans1 <- ans1$vertex.static.attrs[ids,,drop=FALSE]
  expect_equivalent(ans0,ans1)

  # Toamat ordering
  ans0 <- dn$cumadopt
  ans1 <- rewire_qap(dn)
  ids  <- match(nodes(dn), nodes(ans1))
  ans1 <- ans1$cumadopt[ids,,drop=FALSE]
  expect_equivalent(ans0,ans1)

  ans0 <- dn$adopt
  ans1 <- rewire_qap(dn)
  ids  <- match(nodes(dn), nodes(ans1))
  ans1 <- ans1$adopt[ids,,drop=FALSE]
  expect_equivalent(ans0,ans1)

  ans0 <- dn$toa
  ans1 <- rewire_qap(dn)
  ids  <- match(nodes(dn), nodes(ans1))
  ans1 <- ans1$toa[ids]
  expect_equivalent(ans0,ans1)

})