tests/testthat/test-term-fuzzynodematch.R

In statnet/EpiModel: Mathematical Modeling of Infectious Disease Dynamics

context("fuzzynodematch")

test_that("fuzzynodematch works as intended", {
  n <- 1000L
  bip <- 400L
  nv <- 10L
  nvm <- 2000L
  prob <- 0.1
  
  for (directed in list(FALSE, TRUE)) {
    for (bipartite in list(FALSE, bip)) {
      for (split in list("|", ".")) {          
        for (binary in list(FALSE, TRUE)) {
          if (directed == TRUE && bipartite == bip) {
            next
          }
      
          vids <- as.character(sample(seq_len(nvm), nv, FALSE))
          vids <- paste0(rep(c("a","b",""), length.out = length(vids)), vids)
          
          vcs <- matrix(as.logical(rbinom(n*nv, 1L, prob)), nrow = n)
          
          duplicate <- sample(c(FALSE, TRUE), n, TRUE)
          
          attr <- character(n)
          for (i in seq_along(attr)) {
            charvec <- vids[vcs[i,]]
            if (duplicate[i] == TRUE) {
              charvec <- c(charvec, sample(charvec, length(charvec), TRUE))
            }
            charvec <- sample(charvec)
            attr[i] <- paste(charvec, collapse = split)
          }
          
          nw <- network.initialize(n, directed = directed, bipartite = bipartite)
          nw %v% "attr" <- attr
          
          el <- as.edgelist(san(nw ~ edges, target = c(n)))
          
          toggles <- rbind(el, el)
          toggles <- toggles[sample(seq_len(NROW(toggles))), , drop = FALSE]
          toggles <- cbind(seq_len(NROW(toggles)), toggles)
          
          changes <- cbind(toggles, 1L)
          for (i in seq_len(NROW(changes))) {
            if(min(which(changes[,2L] == changes[i,2L] & changes[,3L] == changes[i,3L])) < i) {
              changes[i,4L] <- 0L
            }
          }
        
          gf_stats <- tergm.godfather(nw ~ fuzzynodematch(~attr, split = split, binary = binary), toggles = toggles, stats.start = TRUE)
        
          manual_stats <- integer(NROW(toggles))
          for (i in seq_along(manual_stats)) {
            manual_stats[i] <- sum(vcs[toggles[i,2L],]*vcs[toggles[i,3L],])
            if (binary == TRUE) {
              manual_stats[i] <- as.integer(manual_stats[i] > 0)
            }
            if (changes[i,4L] == 0L) {
              manual_stats[i] <- -manual_stats[i]
            }
          }
          manual_stats <- cumsum(c(0L, manual_stats))
          
          expect_identical(manual_stats, as.integer(gf_stats))
        }
      }
    }
  }
})