tests/utils_tests.R

In networkDynamic: Dynamic Extensions for Network Objects

# tests for utilities functions
require(networkDynamic)
require(testthat)
# ------- test for adjust.activity -----

test<-network.initialize(3)
activate.vertices(test,onset=0,terminus=3,v=1:2)
add.edges.active(test,tail=1:2,head=2:3,onset=0,terminus=3)
add.edge(test,tail=3,head=1)
activate.vertex.attribute(test,'fruit','apple',v=1:2,onset=0,terminus=3)
activate.edge.attribute(test,'veggie','carrot',e=1:2,onset=0,terminus=3)
activate.network.attribute(test,'meat','pork',onset=0,terminus=3)
test%n%'net.obs.period'<-list(observations=list(c(0,1),c(1,2),c(2,3)),mode="discrete", time.increment=1,time.unit="step")

# test offset and return value
test2<-adjust.activity(test,offset=5)

expect_equal(test2$val[[1]]$active,matrix(c(5,8),ncol=2))
expect_equal(test2$val[[3]]$active,NULL)
expect_equal(test2$mel[[1]]$atl$active,matrix(c(5,8),ncol=2))
expect_equal(test2$mel[[3]]$atl$active,NULL)
expect_equal(test2$val[[1]]$'fruit.active'[[2]],matrix(c(5,8),ncol=2))
expect_equal(test2$val[[3]]$'fruit.active'[[2]],NULL)
expect_equal(test2$mel[[1]]$atl$'veggie.active'[[2]],matrix(c(5,8),ncol=2))
expect_equal(test2$mel[[3]]$atl$'veggie.active'[[2]],NULL)
expect_equal(test2$gal$'meat.active'[[2]],matrix(c(5,8),ncol=2))
expect_equal(unlist((test2%n%'net.obs.period')$observations),c(5,6,6,7,7,8))
expect_equal((test2%n%'net.obs.period')$time.increment,1)

# test factor and modify-in-place
adjust.activity(test,factor=.5)

expect_equal(test$val[[1]]$active,matrix(c(2.5,4),ncol=2))
expect_equal(test$val[[3]]$active,NULL)
expect_equal(test$mel[[1]]$atl$active,matrix(c(2.5,4),ncol=2))
expect_equal(test$mel[[3]]$atl$active,NULL)
expect_equal(test$val[[1]]$'fruit.active'[[2]],matrix(c(2.5,4),ncol=2))
expect_equal(test$val[[3]]$'fruit.active'[[2]],NULL)
expect_equal(test$mel[[1]]$atl$'veggie.active'[[2]],matrix(c(2.5,4),ncol=2))
expect_equal(test$mel[[3]]$atl$'veggie.active'[[2]],NULL)
expect_equal(test$mel[[1]]$atl$'veggie.active'[[2]],matrix(c(2.5,4),ncol=2))
expect_equal(unlist((test%n%'net.obs.period')$observations),c(2.5,3,3,3.5,3.5,4))
expect_equal((test%n%'net.obs.period')$time.increment,0.5)

# ---- test for add.vertices.active -----
net<-network.initialize(3)
# test for adding zero vertices
add.vertices.active(net,nv=0)
expect_equal(network.size(net),3)
expect_true(is.networkDynamic(net))

add.vertices.active(net,nv=2, onset=1,terminus=2)
expect_equal(network.size(net),5)
expect_true(is.networkDynamic(net))
expect_equal(unlist(get.vertex.activity(net,as.spellList=TRUE)[4:5,1:2]),c(1,1,2,2),check.names=FALSE)


# ---- tests for get.dyads.active ----
test_that("get.dyads.active works",{
  
  expect_error( get.dyads.active(network.initialize(3,hyper=TRUE),at=1),regexp="does not currently support hypergraphic",info="error on hyper")
  expect_equal( nrow(get.dyads.active(network.initialize(0),at=1)),0,info="network size zero case")
  expect_equal( nrow(get.dyads.active(network.initialize(3),at=1)),0,info="zero edges case")
  
  test<-network.initialize(5)
  add.edges.active(test,tail=1,head=2,onset=0,terminus=1)
  add.edges.active(test,tail=2,head=3,onset=1,terminus=2)
  add.edges.active(test,tail=3,head=4,onset=1,terminus=3)
  activate.edges(test,e=1,onset=2,terminus=3)
  as.data.frame(test)
  expect_equal(get.dyads.active(test,at=0),rbind(1:2))
  expect_equal(get.dyads.active(test,at=1),cbind(2:3,3:4))
  expect_equal(get.dyads.active(test,onset=0,terminus=4),rbind(1:2,2:3,3:4))
  
  # test with no (default) dynamics
  test2<-network.initialize(3)
  test2[1,2]<-1
  expect_equal(get.dyads.active(test2,onset=0,terminus=4),rbind(1:2))
  # test active default
  expect_equal(get.dyads.active(test2,onset=0,terminus=4,active.default=FALSE),cbind(list(),list()), info='test active default arg')
  
  # deleted edges
  test2<-network.initialize(3)
  test2[1,2]<-1
  test2[2,3]<-1
  test2[3,1]<-1
  delete.edges(test2,eid=2)
  expect_equal(get.dyads.active(test2,at=1),rbind(1:2,c(3,1)),info='deleted edge case')
  
})

test_that("conversions between network, networkLite, and networkDynamic behave as expected", {
  library(networkLite)

  m <- matrix(rbinom(20*20, 1, 1/10), nrow = 20, ncol = 20)
  m[lower.tri(m, diag = TRUE)] <- FALSE
  el <- which(m > 0, arr.ind = TRUE)
  el <- el[order(el[,1], el[,2]),,drop=FALSE]
  attr(el, "n") <- 20

  nw <- network(el, directed = FALSE, bipartite = FALSE, matrix.type = "edgelist")
  nwL <- as.networkLite(nw)
  nwLD <- as.networkDynamic(nwL)
  nwD <- as.networkDynamic(nw)
  nwDL <- as.networkLite(nwD)
  expect_identical(nwD, nwLD)
  expect_identical(nwDL, nwL)

  nwL <- networkLite(el)
  nw <- to_network_networkLite(nwL)
  nwD <- as.networkDynamic(nw)
  nwLD <- as.networkDynamic(nwL)
  nwDL <- as.networkLite(nwD)
  expect_identical(nwD, nwLD)
  expect_identical(nwDL, nwL)
})