################################################################################ # edgelist_to_adjmat <--> adjmat_to_edgelist ################################################################################ context("Read/Write graphs edgelist to adjmat and vice-versa") # Directed graph with attributes edgelist <- cbind( c(2:4,1), 1:4 ) w <- rowMeans(edgelist) suppressWarnings(RNGversion("3.5.0")) set.seed(123) tim <- sample(1:4, 4, TRUE) EL_digraph <- list(`edgelist matrix` = edgelist, `edgelist data.frame` = as.data.frame(edgelist)) # Undirected graph, generating the data edgelist <- cbind( c(2,1,4,3), c(1,2,3,4) ) EL_graph <- list(`edgelist matrix` = edgelist, `edgelist data.frame` = as.data.frame(edgelist)) #-Loop over classes for (g in names(EL_digraph)) { # Arguments length test_that(paste0("Length of inputs in edgelist_adjmat should match (detecting error) - ",g), { expect_error(edgelist_to_adjmat(EL_digraph[[g]], w = w[-1], undirected=FALSE), "should have the same length") expect_error(edgelist_to_adjmat(EL_digraph[[g]], t0 = tim[-1], undirected=FALSE), "should have the same length") expect_error(edgelist_to_adjmat(EL_digraph[[g]], t0 = tim, w = w[-1], undirected=FALSE), "should have the same length") }) #----------------------------------------------------------------------------- # Comparing back and forth using matrices #----------------------------------------------------------------------------- # Data adjmat <- edgelist_to_adjmat(EL_digraph[[g]], undirected = FALSE) edgelist_recovered <- adjmat_to_edgelist(adjmat , undirected = FALSE) # Comparing edgelists # EL_digraph[[g]] <- EL_digraph[[g]][order(EL_digraph[[g]][,1]),] test_that(paste0("Undirected static edgelist-adjmat-edgelist (should hold) - ",g), { expect_equivalent(edgelist_recovered[,1:2], as.matrix(EL_digraph[[g]])) }) # Comparing adjmatrices test_that(paste0("Undirected static adjmat-edgelist-adjmat (should hold) - ",g), { expect_equivalent(edgelist_recovered, adjmat_to_edgelist(as.matrix(adjmat))) }) # ---------------------------------------------------------------------------- # Dynamic graphs (explicitly): As lists # ---------------------------------------------------------------------------- # Creating the output graph edgelist_recovered <- adjmat_to_edgelist( edgelist_to_adjmat(EL_digraph[[g]], t0 = tim, undirected = FALSE), undirected = FALSE) # Collapsing edgelist_recovered <- unique(edgelist_recovered[,1:2]) edgelist_recovered <- edgelist_recovered[order(edgelist_recovered[,1]),] EL_digraph[[g]] <- EL_digraph[[g]][order(EL_digraph[[g]][,1]),] test_that(paste0("Undirected dynamic edgelist-adjmat-edgelist (should hold) - ",g), { expect_equivalent(edgelist_recovered, as.matrix(EL_digraph[[g]])) }) # ---------------------------------------------------------------------------- # Dynamic graphs (explicitly): As arrays # ---------------------------------------------------------------------------- array_recovered <- lapply(edgelist_to_adjmat(EL_digraph[[g]], t0 = tim, undirected = FALSE), as.matrix) dn <- list(rownames(array_recovered[[1]]), colnames(array_recovered[[1]]), names(array_recovered)) array_recovered <- array( unlist(array_recovered), dim=c(dim(array_recovered[[1]]), length(array_recovered)), dimnames = dn) edgelist_recovered <- adjmat_to_edgelist(array_recovered, undirected = FALSE) times <- edgelist_recovered[,"time"] edgelist_recovered <- unique(edgelist_recovered[,1:2]) edgelist_recovered <- edgelist_recovered[order(edgelist_recovered[,1]),] test_that(paste0("Undirected dynamic edgelist-adjmat-edgelist (should hold) - ", g), { expect_equivalent(edgelist_recovered, as.matrix(EL_digraph[[g]])) # expect_equivalent(edgelist_recovered$times, tim) }) } ################################################################################ # Time of adoption ################################################################################ context("Time of Adoption (toa_mat, toa_diff)") times <- c(2001L, 2004L, 2003L, 2008L) graph <- lapply(2001:2008, function(x) rgraph_er(4)) diffnet <- new_diffnet(graph, times) test_that("Should warn about -times- not been integer", { expect_warning(toa_mat(as.numeric(times)), "will be coersed to integer") }) test_that("Dimensions of TOA mat should be ok", { toa <- toa_mat(times) cumadopt <- apply(toa$adopt, 2, cumsum) expect_equal(dim(toa$adopt), c(4, length(min(times):max(times)))) expect_equal(dim(toa$adopt), dim(toa$cumadopt), info = "adopt and cumadopt are equal dim") expect_equal(t(apply(toa$adopt, 1, cumsum)), toa$cumadopt, info = "cumadopt is the cumsum") }) test_that("Passing labels should work", { labs <- letters[1:length(times)] toa <- toa_mat(times, labels=labs) expect_equal(rownames(toa$adopt), labs) expect_equal(rownames(toa$cumadopt), labs) }) test_that("In toa_diff, its dim should be equal to the input mat", { expect_equal(dim(toa_diff(times)), c(4,4)) expect_equal(dim(toa_diff(as.integer(times))), c(4,4)) expect_equal(toa_diff(times), toa_diff(as.integer(times))) expect_equal(toa_diff(diffnet), toa_diff(times)) }) test_that("Checking toa_mat output", { # Manual calc mat <- matrix(0, nrow=4, ncol=8) dimnames(mat) <- list(1:4, 2001:2008) amat <- list(adopt=mat, cumadopt=mat) for (i in 1:4) { amat$adopt[i,times[i] - 2000] <- 1 amat$cumadopt[i,] <- cumsum(amat$adopt[i,]) } expect_equal(amat, toa_mat(diffnet)) }) ################################################################################ # Time of adoption (multiple) ################################################################################ context("Time of Adoption -multiple- (toa_mat, toa_dif)") times_1 <- c(2001L, 2004L, 2003L, 2008L) times_2 <- c(2001L, 2005L, 2006L, 2008L) times <- matrix(c(times_1, times_2), nrow = 4, ncol = 2) toa <- toa_mat(times) test_that("Dimensions of TOA mat should be ok. -multiple-.", { for (q in 1:length(toa)) { cumadopt <- t(apply(toa[[q]]$adopt, 1, cumsum)) expect_equal(dim(toa[[q]]$adopt), c(4, length(min(times[,q]):max(times[,q])))) expect_equal(dim(toa[[q]]$adopt), dim(toa[[q]]$cumadopt), info = "adopt and cumadopt are equal dim") expect_equal(t(apply(toa[[q]]$adopt, 1, cumsum)), toa[[q]]$cumadopt, info = "cumadopt is the cumsum") } }) test_that("Passing labels should work. -multiple-.", { for (q in 1:length(toa)) { labs <- letters[1:length(times[,q])] toa_q <- toa_mat(times[,q], labels=labs) expect_equal(rownames(toa_q$adopt), labs) expect_equal(rownames(toa_q$cumadopt), labs) } }) graph <- lapply(2001:2008, function(x) rgraph_er(4)) diffnet <- new_diffnet(graph, times) test_that("In toa_diff, its dim should be equal to the input mat. -multiple-.", { expect_equal(length(toa_diff(times)), 2) expect_equal(dim(toa_diff(times)[[1]]), c(4,4)) expect_equal(length(toa_diff(diffnet)), 2) expect_equal(dim(toa_diff(diffnet)[[1]]), c(4,4)) expect_equal(toa_diff(times), toa_diff(diffnet)) }) test_that("Checking toa_mat output. -multiple-.", { # Manual calc mat <- matrix(0, nrow=4, ncol=8) mat <- array(rep(mat,2), dim = c(nrow(mat), ncol(mat), 2)) dimnames(mat) <- list(1:4, 2001:2008) amat_tot <- list() for (q in 1:dim(mat)[3]) { amat <- list(adopt=mat[,,q], cumadopt=mat[,,q]) for (i in 1:4) { amat$adopt[i,times[i,q] - 2000] <- 1 amat$cumadopt[i,] <- cumsum(amat$adopt[i,]) } amat_tot[[q]] <- amat } expect_equal(amat_tot, toa_mat(diffnet)) }) ################################################################################ # Isolated ################################################################################ context("Isolated vertices (isolated, drop_isolated)") # Preparing data --------------------------------------------------------------- edgelist <- cbind( c(2:4,1), 1:4 ) suppressWarnings(RNGversion("3.5.0")) set.seed(123) tim <- sample(1:4, 4, TRUE) adjmat <- edgelist_to_adjmat(edgelist) dynadjmat <- edgelist_to_adjmat(edgelist, t0=tim) diffnet <- as_diffnet(dynadjmat, tim) test_that("Finding isolated nodes", { # Static graphs -------------------------------------------------------------- # Test with dgCMatrix iso23<-iso2<-adjmat iso2[2,1:4] <- 0 iso2[1:4,2] <- 0 iso23[c(2,3),1:4] <- 0 iso23[1:4,c(2,3)] <- 0 expect_equal(which(isolated(iso2)), c(2,3), info = "only one (dgCMatrix)") expect_equal(which(isolated(iso23)), 2:4, info = "two (dgCMatrix)") # Test with sparse matrix iso2 <- methods::as(iso2, "dgCMatrix") iso23 <- methods::as(iso23, "dgCMatrix") expect_equal(which(isolated(iso2)), c(2,3), info = "only one (dgCMatrix)") expect_equal(which(isolated(iso23)), 2:4, info = "two (dgCMatrix)") # Dynamic graphs ------------------------------------------------------------- # Test with lists iso2 <- lapply(dynadjmat, "[<-", i=2, j=1:4, value=0) iso2 <- lapply(iso2, "[<-", i=1:4, j=2, value=0) iso23 <- lapply(dynadjmat, "[<-", i=c(2,3), j=1:4, value=0) iso23 <- lapply(iso23, "[<-", i=1:4, j=c(2,3), value=0) expect_equal(which(isolated(iso2)), 2:3, info = "only one (list)") expect_equal(which(isolated(iso23)), 2:4, info = "two (list)") dn <- new_diffnet(iso23, sample(1:3, 4, TRUE), t0=1, t1=3) expect_equal(isolated(dn), isolated(iso23)) }) test_that("Dropping isolated nodes", { # Static graphs -------------------------------------------------------------- # Test with matrix iso23<-iso2<-adjmat iso2[2,1:4] <- 0 iso2[1:4,2] <- 0 iso23[c(2,3),1:4] <- 0 iso23[1:4,c(2,3)] <- 0 expect_equal(dim(drop_isolated(iso2)), c(2,2)) expect_equal(dim(drop_isolated(iso23)), c(1,1)) # Test with sparse matrix iso2 <- as(iso2, "dgCMatrix") iso23 <- as(iso23, "dgCMatrix") # Dynamic graphs ------------------------------------------------------------- # Test with lists iso2 <- lapply(dynadjmat, "[<-", i=2, j=1:4, value=0) iso2 <- lapply(iso2, "[<-", i=1:4, j=2, value=0) iso23 <- lapply(dynadjmat, "[<-", i=c(2,3), j=1:4, value=0) iso23 <- lapply(iso23, "[<-", i=1:4, j=c(2,3), value=0) expect_equal(dim(drop_isolated(iso2)[[1]]), c(2,2)) expect_equal(dim(drop_isolated(iso23)[[1]]), c(1,1)) # Test with array iso2 <- array(unlist(lapply(iso2, as.matrix)), dim=c(4,4,3), dimnames=list(1:4,1:4, names(iso2))) iso23 <- array(unlist(lapply(iso23, as.matrix)), dim=c(4,4,3), dimnames=list(1:4,1:4, names(iso2))) dim_list <- function(x) { d <- dim(x[[1]]) c(d[1],d[2], length(x)) } expect_equal(dim(drop_isolated(iso2)), c(2,2,3)) expect_equal(dim(drop_isolated(iso23)), c(1,1,3)) })