From 5cc9525346f4362438e77bd5d64a2d18099da17d Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Mon, 5 Sep 2022 11:10:22 -0700 Subject: [PATCH 01/49] remove dependency on networkDynamic, ergm, tergm, EpiModel and update as.network.networkLite --- DESCRIPTION | 19 +++---------------- NAMESPACE | 2 -- R/networkLite.R | 18 +++++++++--------- man/networkLitemethods.Rd | 9 +++++---- 4 files changed, 17 insertions(+), 31 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 670b3c1..39a5d5b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -28,24 +28,11 @@ BugReports: https://github.com/EpiModel/networkLite/issues Depends: R (>= 3.5) Imports: - statnet.common, - network, - networkDynamic, + statnet.common (>= 4.6.0), + network (>= 1.17.2), tibble, dplyr Suggests: - testthat, - ergm, - tergm, - EpiModel + testthat RoxygenNote: 7.2.1 Encoding: UTF-8 -Remotes: - github::statnet/rle@master, - github::statnet/statnet.common@master, - github::statnet/network@master, - github::statnet/networkDynamic@master, - github::EpiModel/networkLite@main, - github::statnet/ergm@master, - github::statnet/tergm@master, - github::EpiModel/EpiModel@main diff --git a/NAMESPACE b/NAMESPACE index 4fc88c3..7d25253 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,7 +8,6 @@ S3method(add.vertices,networkLite) S3method(as.edgelist,networkLite) S3method(as.matrix,networkLite) S3method(as.network,networkLite) -S3method(as.networkDynamic,networkLite) S3method(as.networkLite,network) S3method(as.networkLite,networkLite) S3method(as_tibble,networkLite) @@ -41,7 +40,6 @@ export(to_network_networkLite) import(network) importFrom(dplyr,bind_cols) importFrom(dplyr,bind_rows) -importFrom(networkDynamic,as.networkDynamic) importFrom(statnet.common,NVL) importFrom(statnet.common,NVL2) importFrom(stats,na.omit) diff --git a/R/networkLite.R b/R/networkLite.R index b470d90..9c6eff8 100644 --- a/R/networkLite.R +++ b/R/networkLite.R @@ -1,7 +1,6 @@ #' @import network #' @importFrom statnet.common NVL NVL2 -#' @importFrom networkDynamic as.networkDynamic #' @importFrom tibble tibble as_tibble is_tibble #' @importFrom dplyr bind_rows bind_cols #' @importFrom stats na.omit @@ -551,9 +550,16 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, } #' @rdname networkLitemethods +#' @param allow.networkLite logical; if \code{TRUE}, return the +#' \code{networkLite} unmodified; if \code{FALSE}, convert to a +#' \code{network} class object #' @export -as.network.networkLite <- function(x, ...) { - x +as.network.networkLite <- function(x, ..., allow.networkLite = FALSE) { + if (allow.networkLite == TRUE) { + return(x) + } else { + return(to_network_networkLite(x)) + } } #' @rdname networkLitemethods @@ -632,12 +638,6 @@ to_network_networkLite <- function(x, ...) { nw } -#' @rdname networkLitemethods -#' @export -as.networkDynamic.networkLite <- function(object, ...) { - as.networkDynamic(to_network_networkLite(object)) -} - #' @rdname networkLitemethods #' @param attrnames vector specifying edge attributes to include in the tibble; #' may be logical, integer, or character vector, the former two being diff --git a/man/networkLitemethods.Rd b/man/networkLitemethods.Rd index 375fb85..144561a 100644 --- a/man/networkLitemethods.Rd +++ b/man/networkLitemethods.Rd @@ -24,7 +24,6 @@ \alias{as.networkLite} \alias{as.networkLite.network} \alias{as.networkLite.networkLite} -\alias{as.networkDynamic.networkLite} \alias{as_tibble.networkLite} \alias{as.matrix.networkLite} \alias{is.na.networkLite} @@ -90,7 +89,7 @@ \method{add.edges}{networkLite}(x, tail, head, names.eval = NULL, vals.eval = NULL, ...) -\method{as.network}{networkLite}(x, ...) +\method{as.network}{networkLite}(x, ..., allow.networkLite = FALSE) as.networkLite(x, ...) @@ -98,8 +97,6 @@ as.networkLite(x, ...) \method{as.networkLite}{networkLite}(x, ...) -\method{as.networkDynamic}{networkLite}(object, ...) - \method{as_tibble}{networkLite}(x, attrnames = NULL, na.rm = TRUE, ...) \method{as.matrix}{networkLite}( @@ -161,6 +158,10 @@ present?} \item{vals.eval}{value(s) of edge attributes} +\item{allow.networkLite}{logical; if \code{TRUE}, return the +\code{networkLite} unmodified; if \code{FALSE}, convert to a +\code{network} class object} + \item{attrnames}{vector specifying edge attributes to include in the tibble; may be logical, integer, or character vector, the former two being used to select attribute names from \code{list.edge.attributes(x)}, From 7affd540fdf09b6e41e30c4d31217bf761d072c9 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Mon, 5 Sep 2022 13:56:58 -0700 Subject: [PATCH 02/49] restore original behavior of as.network.networkLite --- R/networkLite.R | 11 ++--------- man/networkLitemethods.Rd | 6 +----- 2 files changed, 3 insertions(+), 14 deletions(-) diff --git a/R/networkLite.R b/R/networkLite.R index 9c6eff8..94ac0bd 100644 --- a/R/networkLite.R +++ b/R/networkLite.R @@ -550,16 +550,9 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, } #' @rdname networkLitemethods -#' @param allow.networkLite logical; if \code{TRUE}, return the -#' \code{networkLite} unmodified; if \code{FALSE}, convert to a -#' \code{network} class object #' @export -as.network.networkLite <- function(x, ..., allow.networkLite = FALSE) { - if (allow.networkLite == TRUE) { - return(x) - } else { - return(to_network_networkLite(x)) - } +as.network.networkLite <- function(x, ...) { + return(x) } #' @rdname networkLitemethods diff --git a/man/networkLitemethods.Rd b/man/networkLitemethods.Rd index 144561a..caee2e6 100644 --- a/man/networkLitemethods.Rd +++ b/man/networkLitemethods.Rd @@ -89,7 +89,7 @@ \method{add.edges}{networkLite}(x, tail, head, names.eval = NULL, vals.eval = NULL, ...) -\method{as.network}{networkLite}(x, ..., allow.networkLite = FALSE) +\method{as.network}{networkLite}(x, ...) as.networkLite(x, ...) @@ -158,10 +158,6 @@ present?} \item{vals.eval}{value(s) of edge attributes} -\item{allow.networkLite}{logical; if \code{TRUE}, return the -\code{networkLite} unmodified; if \code{FALSE}, convert to a -\code{network} class object} - \item{attrnames}{vector specifying edge attributes to include in the tibble; may be logical, integer, or character vector, the former two being used to select attribute names from \code{list.edge.attributes(x)}, From 9a42256dac238e0d4d3e26b6228eaa107d60aae3 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Mon, 5 Sep 2022 15:44:07 -0700 Subject: [PATCH 03/49] update tests for removal of dependence on ergm, tergm, EpiModel --- tests/testthat/test-networkLite.R | 550 +++--------------------------- 1 file changed, 38 insertions(+), 512 deletions(-) diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index 7ef5aaa..1274b47 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -1,219 +1,29 @@ -## test_that("network and networkLite behave identically in ergm and gof", { -## skip_on_cran() -## options(ergm.loglik.warn_dyads=FALSE) -## -## net_size <- 100 -## bip_size <- 40 -## -## for(directed in list(FALSE, TRUE)) { -## for(bipartite in list(FALSE, bip_size)) { -## if(directed && bipartite) { -## next -## } -## -## set.seed(0) -## nw <- network.initialize(net_size, directed = directed, bipartite = bipartite) -## nw %v% "a" <- rep(letters[1:5], length.out = net_size) -## nw %v% "b" <- runif(net_size) -## nw %v% "sex" <- rep(c("M","F"), length.out=net_size) -## -## nwL <- as.networkLite(nw) -## -## di_constraints <- ~blocks(~sex, levels2=diag(TRUE,2)) -## dd_constraints <- ~bd(maxout=2) + blocks(~sex, levels2=diag(TRUE,2)) -## dm_constraints <- ~bd(maxout=2, minout = 0) + blocks(~sex, levels2=diag(TRUE,2)) -## -## target_stats <- c(750, 300, 315, 285, 295, 1250)/10 -## -## set.seed(0) -## nw_di_ergm <- ergm(nw ~ edges + nodefactor("a") + nodecov(~b^2 + b), target.stats = target_stats, constraints = di_constraints, eval.loglik = FALSE) -## set.seed(0) -## nwL_di_ergm <- ergm(nwL ~ edges + nodefactor("a") + nodecov(~b^2 + b), target.stats = target_stats, constraints = di_constraints, eval.loglik = FALSE) -## expect_equal(coef(nw_di_ergm), coef(nwL_di_ergm)) -## -## set.seed(0) -## nw_di_gof <- gof(nw_di_ergm) -## set.seed(0) -## nwL_di_gof <- gof(nwL_di_ergm) -## expect_equal(nw_di_gof, nwL_di_gof) -## -## set.seed(0) -## nw_di_predict <- predict(nw_di_ergm) -## set.seed(0) -## nwL_di_predict <- predict(nwL_di_ergm) -## expect_identical(nw_di_predict, nwL_di_predict) -## -## set.seed(0) -## nw_dd_ergm <- ergm(nw ~ edges + nodefactor("a") + nodecov(~b^2 + b), target.stats = target_stats, constraints = dd_constraints, control = list(init.method="MPLE"), eval.loglik = FALSE) -## set.seed(0) -## nwL_dd_ergm <- ergm(nwL ~ edges + nodefactor("a") + nodecov(~b^2 + b), target.stats = target_stats, constraints = dd_constraints, control = list(init.method="MPLE"), eval.loglik = FALSE) -## expect_equal(coef(nw_dd_ergm), coef(nwL_dd_ergm)) -## -## set.seed(0) -## nw_dd_gof <- gof(nw_dd_ergm) -## set.seed(0) -## nwL_dd_gof <- gof(nwL_dd_ergm) -## expect_equal(nw_dd_gof, nwL_dd_gof) -## -## set.seed(0) -## nw_dd_predict <- predict(nw_dd_ergm) -## set.seed(0) -## nwL_dd_predict <- predict(nwL_dd_ergm) -## expect_identical(nw_dd_predict, nwL_dd_predict) -## -## set.seed(0) -## nw_dm_ergm <- ergm(nw ~ edges + nodefactor("a") + nodecov(~b^2 + b), target.stats = target_stats, constraints = dm_constraints, eval.loglik = FALSE) -## set.seed(0) -## nwL_dm_ergm <- ergm(nwL ~ edges + nodefactor("a") + nodecov(~b^2 + b), target.stats = target_stats, constraints = dm_constraints, eval.loglik = FALSE) -## expect_equal(coef(nw_dm_ergm), coef(nwL_dm_ergm)) -## -## set.seed(0) -## nw_dm_gof <- gof(nw_dm_ergm) -## set.seed(0) -## nwL_dm_gof <- gof(nwL_dm_ergm) -## expect_equal(nw_dm_gof, nwL_dm_gof) -## -## set.seed(0) -## nw_dm_predict <- predict(nw_dm_ergm) -## set.seed(0) -## nwL_dm_predict <- predict(nwL_dm_ergm) -## expect_identical(nw_dm_predict, nwL_dm_predict) -## -## ## simpler dyad-independent case where we can hit targets exactly -## set.seed(0) -## nw_mple_ergm <- ergm(nw ~ edges + nodefactor("a"), target.stats = as.integer(target_stats[-length(target_stats)]), constraints = di_constraints) -## set.seed(0) -## nwL_mple_ergm <- ergm(nwL ~ edges + nodefactor("a"), target.stats = as.integer(target_stats[-length(target_stats)]), constraints = di_constraints) -## expect_equal(coef(nw_mple_ergm), coef(nwL_mple_ergm)) -## -## set.seed(0) -## nw_mple_gof <- gof(nw_mple_ergm) -## set.seed(0) -## nwL_mple_gof <- gof(nwL_mple_ergm) -## expect_equal(nw_mple_gof, nwL_mple_gof) -## -## set.seed(0) -## nw_mple_predict <- predict(nw_mple_ergm) -## set.seed(0) -## nwL_mple_predict <- predict(nwL_mple_ergm) -## expect_identical(nw_mple_predict, nwL_mple_predict) -## -## } -## } -## }) - -library(ergm) -library(tergm) -library(EpiModel) - -test_that("network and networkLite simulate equally in ergm", { - net_size <- 100 - bip_size <- 40 - - ffdir <- ~nodemix(~a) + absdiff(~b) + odegrange(2) + idegrange(2) + gwesp + gwnsp(0.3, fixed=TRUE) - ffundir <- ~nodemix(~a) + absdiff(~b) + concurrent + gwesp + gwnsp(0.3, fixed=TRUE) - - for(directed in list(FALSE, TRUE)) { - for(bipartite in list(FALSE, bip_size)) { - if(directed && bipartite) { - next - } - - set.seed(0) - nw <- network.initialize(net_size, directed = directed, bipartite = bipartite) - nw %v% "a" <- rep(letters[1:5], length.out = net_size) - nw %v% "b" <- runif(net_size) - - nwL <- as.networkLite(nw) - - coef <- c(-4, 1, 1.5, 0.5, -1, 0.5) - - set.seed(0) - nw_1 <- simulate(nw ~ edges + nodefactor("a") + nodecov(~b^2 + b), coef = coef, output = "network", dynamic = FALSE) - set.seed(0) - nwL_1 <- simulate(nwL ~ edges + nodefactor("a") + nodecov(~b^2 + b), coef = coef, output = "network", dynamic = FALSE) - - expect_equal(as.edgelist(nw_1), as.edgelist(nwL_1)) - if(directed) { - expect_identical(summary(ffdir, basis = nw_1), - summary(ffdir, basis = nwL_1)) - } else { - expect_identical(summary(ffundir, basis = nw_1), - summary(ffundir, basis = nwL_1)) - } - - set.seed(0) - nw_2 <- simulate(nw_1 ~ edges + nodefactor("a") + nodecov(~b^2 + b), coef = coef, output = "network", dynamic = FALSE) - set.seed(0) - nwL_2 <- simulate(nwL_1 ~ edges + nodefactor("a") + nodecov(~b^2 + b), coef = coef, output = "network", dynamic = FALSE) - - expect_equal(as.edgelist(nw_2), as.edgelist(nwL_2)) - if(directed) { - expect_identical(summary(ffdir, basis = nw_2), - summary(ffdir, basis = nwL_2)) - } else { - expect_identical(summary(ffundir, basis = nw_2), - summary(ffundir, basis = nwL_2)) - } - } +create_random_edgelist <- function(n_nodes, directed, bipartite, target_n_edges) { + if (directed == TRUE) { + ## directed unipartite + adj <- matrix(rbinom(n_nodes*n_nodes, 1, target_n_edges/(n_nodes*(n_nodes - 1))), nrow = n_nodes, ncol = n_nodes) + diag(adj) <- 0 + } else if (bipartite > 0) { + ## undirected bipartite + bip <- matrix(rbinom(bipartite*(n_nodes - bipartite), 1, target_n_edges/(bipartite*(n_nodes - bipartite))), nrow = bipartite, ncol = n_nodes - bipartite) + adj <- matrix(0, nrow = n_nodes, ncol = n_nodes) + adj[seq_len(bipartite), -seq_len(bipartite)] <- bip + } else { + ## undirected unipartite + adj <- matrix(rbinom(n_nodes*n_nodes, 1, 2*target_n_edges/(n_nodes*(n_nodes - 1))), nrow = n_nodes, ncol = n_nodes) + adj[lower.tri(adj, diag = TRUE)] <- 0 } -}) - -test_that("network and networkLite simulate equally in san", { - net_size <- 100 - bip_size <- 40 - - ffdir <- ~nodemix(~a) + absdiff(~b) + odegrange(2) + idegrange(2) + gwesp + gwnsp(0.3, fixed=TRUE) - ffundir <- ~nodemix(~a) + absdiff(~b) + concurrent + gwesp + gwnsp(0.3, fixed=TRUE) - - for(directed in list(FALSE, TRUE)) { - for(bipartite in list(FALSE, bip_size)) { - if(directed && bipartite) { - next - } - - set.seed(0) - nw <- network.initialize(net_size, directed = directed, bipartite = bipartite) - nw %v% "a" <- rep(letters[1:5], length.out = net_size) - nw %v% "b" <- runif(net_size) - - nwL <- as.networkLite(nw) - - set.seed(0) - nw_1 <- san(nw ~ edges + nodefactor("a") + nodecov(~b^2 + b), target.stats = c(1000, 500, 300, 200, 600, 1500)) - set.seed(0) - nwL_1 <- san(nwL ~ edges + nodefactor("a") + nodecov(~b^2 + b), target.stats = c(1000, 500, 300, 200, 600, 1500)) - - expect_equal(as.edgelist(nw_1), as.edgelist(nwL_1)) - if(directed) { - expect_identical(summary(ffdir, basis = nw_1), - summary(ffdir, basis = nwL_1)) - } else { - expect_identical(summary(ffundir, basis = nw_1), - summary(ffundir, basis = nwL_1)) - } - - set.seed(0) - nw_2 <- san(nw_1 ~ edges + nodefactor("a") + nodecov(~b^2 + b), target.stats = c(800, 400, 200, 100, 600, 1200)) - set.seed(0) - nwL_2 <- san(nwL_1 ~ edges + nodefactor("a") + nodecov(~b^2 + b), target.stats = c(800, 400, 200, 100, 600, 1200)) - - expect_equal(as.edgelist(nw_2), as.edgelist(nwL_2)) - if(directed) { - expect_identical(summary(ffdir, basis = nw_2), - summary(ffdir, basis = nwL_2)) - } else { - expect_identical(summary(ffundir, basis = nw_2), - summary(ffundir, basis = nwL_2)) - } - } - } -}) + el <- which(adj > 0, arr.ind = TRUE) + el <- el[order(el[,1], el[,2]),,drop=FALSE] + colnames(el) <- c(".tail", ".head") + structure(el, n = n_nodes, directed = directed, bipartite = bipartite) +} test_that("direct conversion between network and networkLite functions as expected", { net_size <- 100 bip_size <- 40 + edges_target <- net_size for(directed in list(FALSE, TRUE)) { for(bipartite in list(FALSE, bip_size)) { @@ -224,9 +34,8 @@ test_that("direct conversion between network and networkLite functions as expect for(last.mode in list(FALSE, TRUE)) { for(delete in list(FALSE)) { set.seed(0) - nw <- network.initialize(net_size, directed = directed, bipartite = bipartite) + nw <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") nw %v% "b" <- runif(net_size) - nw <- san(nw ~ edges, target.stats = c(100)) nw %e% "eattr" <- runif(network.edgecount(nw)) nw %n% "nattr" <- "attr" # nainds <- sample(valid.eids(nw), as.integer(network.size(nw)/2), FALSE) @@ -245,9 +54,8 @@ test_that("direct conversion between network and networkLite functions as expect nw %n% "n" <- as.numeric(nw %n% "n") set.seed(0) - nwL <- networkLite(net_size, directed = directed, bipartite = bipartite) + nwL <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) nwL %v% "b" <- runif(net_size) - nwL <- san(nwL ~ edges, target.stats = c(100)) set.edge.attribute(nwL, "eattr", runif(network.edgecount(nwL))) nwL %n% "nattr" <- "attr" # nainds <- sample(seq_len(network.edgecount(nwL)), as.integer(network.size(nwL)/2), FALSE) @@ -279,205 +87,6 @@ test_that("direct conversion between network and networkLite functions as expect } }) -## test_that("network and networkLite estimate equally in (EGMME) tergm", { -## skip_on_cran() -## net_size <- 50 -## bip_size <- 20 -## -## for(directed in list(FALSE, TRUE)) { -## for(bipartite in list(FALSE, bip_size)) { -## if(directed && bipartite) { -## next -## } -## -## set.seed(0) -## nw <- network.initialize(net_size, directed = directed, bipartite = bipartite) -## nw %v% "a" <- rep(letters[1:5], length.out = net_size) -## nw %v% "b" <- runif(net_size) -## -## nwL <- as.networkLite(nw) -## -## set.seed(0) -## tergm_nw <- tergm(nw ~ Form(~edges) + Diss(~edges), targets = ~edges + mean.age, target.stats = c(30, 5), estimate = "EGMME") -## set.seed(0) -## tergm_nwL <- tergm(nwL ~ Form(~edges) + Diss(~edges), targets = ~edges + mean.age, target.stats = c(30, 5), estimate = "EGMME") -## expect_equal(coef(tergm_nw), coef(tergm_nwL)) -## } -## } -## }) - -test_that("network and networkLite simulate equally in tergm", { - net_size <- 100 - bip_size <- 40 - - ffdir <- ~nodemix(~a) + absdiff(~b) + odegrange(2) + idegrange(2) + gwesp + mean.age + edge.ages + nodemix.mean.age(~a) + gwnsp(0.3, fixed=TRUE) - ffundir <- ~nodemix(~a) + absdiff(~b) + concurrent + gwesp + mean.age + edge.ages + nodemix.mean.age(~a) + gwnsp(0.3, fixed=TRUE) - - for(directed in list(FALSE, TRUE)) { - for(bipartite in list(FALSE, bip_size)) { - if(directed && bipartite) { - next - } - - set.seed(0) - nw <- network.initialize(net_size, directed = directed, bipartite = bipartite) - nw %v% "a" <- rep(letters[1:5], length.out = net_size) - nw %v% "b" <- runif(net_size) - - nwL <- as.networkLite(nw) - - coef <- c(-4, 1, 1.5, 0.5, -1, 0.5, 3) - - set.seed(0) - nw_1 <- simulate(nw ~ Form(~edges + nodefactor("a") + nodecov(~b^2 + b)) + Persist(~edges), coef = coef, output = "final", dynamic = TRUE) - set.seed(0) - nwL_1 <- simulate(nwL ~ Form(~edges + nodefactor("a") + nodecov(~b^2 + b)) + Persist(~edges), coef = coef, output = "final", dynamic = TRUE) - - expect_equal(as.edgelist(nw_1), as.edgelist(nwL_1)) - expect_identical(nw_1 %n% "lasttoggle", nwL_1 %n% "lasttoggle") - expect_identical(nw_1 %n% "time", nwL_1 %n% "time") - if(directed) { - expect_identical(summary(ffdir, basis = nw_1), - summary(ffdir, basis = nwL_1)) - } else { - expect_identical(summary(ffundir, basis = nw_1), - summary(ffundir, basis = nwL_1)) - } - - set.seed(0) - nw_2 <- simulate(nw_1 ~ Form(~edges + nodefactor("a") + nodecov(~b^2 + b)) + Persist(~edges), coef = coef, output = "final", dynamic = TRUE) - set.seed(0) - nwL_2 <- simulate(nwL_1 ~ Form(~edges + nodefactor("a") + nodecov(~b^2 + b)) + Persist(~edges), coef = coef, output = "final", dynamic = TRUE) - - expect_equal(as.edgelist(nw_2), as.edgelist(nwL_2)) - expect_identical(nw_2 %n% "lasttoggle", nwL_2 %n% "lasttoggle") - expect_identical(nw_2 %n% "time", nwL_2 %n% "time") - if(directed) { - expect_identical(summary(ffdir, basis = nw_2), - summary(ffdir, basis = nwL_2)) - } else { - expect_identical(summary(ffundir, basis = nw_2), - summary(ffundir, basis = nwL_2)) - } - - set.seed(0) - nw_3 <- simulate(nw_2 ~ Form(~edges + nodefactor("a") + nodecov(~b^2 + b)) + Persist(~edges), coef = coef, output = "final", dynamic = TRUE) - set.seed(0) - nwL_3 <- simulate(nwL_2 ~ Form(~edges + nodefactor("a") + nodecov(~b^2 + b)) + Persist(~edges), coef = coef, output = "final", dynamic = TRUE) - - expect_equal(as.edgelist(nw_3), as.edgelist(nwL_3)) - expect_identical(nw_3 %n% "lasttoggle", nwL_3 %n% "lasttoggle") - expect_identical(nw_3 %n% "time", nwL_3 %n% "time") - if(directed) { - expect_identical(summary(ffdir, basis = nw_3), - summary(ffdir, basis = nwL_3)) - } else { - expect_identical(summary(ffundir, basis = nw_3), - summary(ffundir, basis = nwL_3)) - } - - set.seed(0) - nw_4 <- simulate(nw_3 ~ Form(~edges + nodefactor("a") + nodecov(~b^2 + b)) + Persist(~edges), coef = coef, dynamic = TRUE) - set.seed(0) - nwL_4 <- simulate(nwL_3 ~ Form(~edges + nodefactor("a") + nodecov(~b^2 + b)) + Persist(~edges), coef = coef, dynamic = TRUE) - - # comparison of networkDynamics - expect_equal(nw_4, nwL_4) - - - ## for completeness, also get stats and changes as output - set.seed(0) - s <- simulate(nw_3 ~ Form(~edges + nodefactor("a") + nodecov(~b^2 + b)) + Persist(~edges), coef = coef, dynamic = TRUE, output = "stats", stats = TRUE, monitor = if(directed) ~edges + idegree(0:10) + odegree(0:10) + mean.age + Form(~odegree(0:2)) else ~edges + degree(0:10) + mean.age + Form(~degree(0:2))) - set.seed(0) - sL <- simulate(nwL_3 ~ Form(~edges + nodefactor("a") + nodecov(~b^2 + b)) + Persist(~edges), coef = coef, dynamic = TRUE, output = "stats", stats = TRUE, monitor = if(directed) ~edges + idegree(0:10) + odegree(0:10) + mean.age + Form(~odegree(0:2)) else ~edges + degree(0:10) + mean.age + Form(~degree(0:2))) - - # comparison of stats - expect_equal(s, sL) - - set.seed(0) - c <- simulate(nw_3 ~ Form(~edges + nodefactor("a") + nodecov(~b^2 + b)) + Persist(~edges), coef = coef, dynamic = TRUE, output = "changes") - set.seed(0) - cL <- simulate(nwL_3 ~ Form(~edges + nodefactor("a") + nodecov(~b^2 + b)) + Persist(~edges), coef = coef, dynamic = TRUE, output = "changes") - - # comparison of changes - expect_equal(c, cL) - - # again, without lasttoggle - nw_3 %n% "lasttoggle" <- NULL - nwL_3 %n% "lasttoggle" <- NULL - - set.seed(0) - nw_4 <- simulate(nw_3 ~ Form(~edges + nodefactor("a") + nodecov(~b^2 + b)) + Persist(~edges), coef = coef, dynamic = TRUE) - set.seed(0) - nwL_4 <- simulate(nwL_3 ~ Form(~edges + nodefactor("a") + nodecov(~b^2 + b)) + Persist(~edges), coef = coef, dynamic = TRUE) - - # comparison of networkDynamics - expect_equal(nw_4, nwL_4) - } - } -}) - -test_that("network and networkLite work equally in netest, netdx, and netsim", { - net_size <- 100 - bip_size <- 40 - - ffdir <- ~odegree(1) + idegree(1) - ffundir <- ~degree(1) - - for(directed in list(FALSE, TRUE)) { - for(bipartite in list(FALSE, bip_size)) { - if(directed && bipartite) { - next - } - - nw <- network.initialize(n = 100, directed = directed, bipartite = bipartite) - nw <- set_vertex_attribute(nw, "race", rbinom(50, 1, 0.5)) - - set.seed(0) - est <- netest(nw, formation = ~edges + nodematch("race"), - target.stats = c(50, 20), - coef.diss = dissolution_coefs(~offset(edges), c(10)), - verbose = FALSE - ) - dxs <- netdx(est, nsims = 20, verbose = FALSE, - dynamic = FALSE, nwstats.formula = if(directed) ffdir else ffundir) - - dxd <- netdx(est, nsims = 2, nsteps = 10, verbose = FALSE, - dynamic = TRUE) - - param <- param.net(inf.prob = 0.3, act.rate = 0.5) - init <- init.net(i.num = 10) - control <- control.net(type = "SI", nsims = 2, nsteps = 5, verbose = FALSE) - sim <- netsim(est, param, init, control) - - nwL <- as.networkLite(nw) - set.seed(0) - estL <- netest(nwL, formation = ~edges + nodematch("race"), - target.stats = c(50, 20), - coef.diss = dissolution_coefs(~offset(edges), c(10)), - verbose = FALSE - ) - dxsL <- netdx(estL, nsims = 20, verbose = FALSE, - dynamic = FALSE, nwstats.formula = if(directed) ffdir else ffundir) - - dxdL <- netdx(estL, nsims = 2, nsteps = 10, verbose = FALSE, - dynamic = TRUE) - - simL <- netsim(estL, param, init, control) - - # convert networks to networkLites - dxs$nw <- as.networkLite(dxs$nw) - dxd$nw <- as.networkLite(dxd$nw) - - # the rest should be equal, including coefs, stats, etc. - expect_equal(trim_netest(est), trim_netest(estL)) - expect_equal(dxs, dxsL) - expect_equal(dxd, dxdL) - expect_equal(sim, simL) - } - } -}) - test_that("network and networkLite produce identical matrices, edgelists, and tibbles", { net_size <- 100 bip_size <- 40 @@ -490,15 +99,13 @@ test_that("network and networkLite produce identical matrices, edgelists, and ti } set.seed(0) - nw <- network.initialize(net_size, directed = directed, bipartite = bipartite) - nw <- san(nw ~ edges, target.stats = c(edges_target)) + nw <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") nw %e% "eattr" <- runif(network.edgecount(nw)) # nainds <- sample(valid.eids(nw), as.integer(length(valid.eids(nw))/2), FALSE) # set.edge.attribute(nw, "na", TRUE, nainds) set.seed(0) - nwL <- networkLite(net_size, directed = directed, bipartite = bipartite) - nwL <- san(nwL ~ edges, target.stats = c(edges_target)) + nwL <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) set.edge.attribute(nwL, "eattr", runif(network.edgecount(nwL))) # nainds <- sample(valid.eids(nwL), as.integer(length(valid.eids(nwL))/2), FALSE) # set.edge.attribute(nwL, "na", TRUE, nainds) @@ -523,82 +130,6 @@ test_that("network and networkLite produce identical matrices, edgelists, and ti } }) -## test_that("network and networkLite fit and simulate equal missing-data ergms", { -## net_size <- 50 -## bip_size <- 20 -## -## for(directed in list(FALSE, TRUE)) { -## for(bipartite in list(FALSE, bip_size)) { -## if(directed && bipartite) { -## next -## } -## -## set.seed(0) -## nwL <- networkLite(net_size, directed = directed, bipartite = bipartite) -## nwL <- san(nwL ~ edges, target.stats = network.dyadcount(nwL)/10) -## nwL %v% "age" <- runif(net_size) -## na <- sample(c(FALSE,TRUE),network.edgecount(nwL),TRUE) -## -## set.seed(0) -## eL <- ergm(nwL ~ absdiff("age"), control = list(MCMLE.effectiveSize = NULL)) -## nwL %e% "na" <- na -## set.seed(0) -## eLna <- ergm(nwL ~ absdiff("age"), control = list(MCMLE.effectiveSize = NULL)) -## eL2 <- simulate(eLna) -## -## set.seed(0) -## nw <- network.initialize(net_size, directed = directed, bipartite = bipartite) -## nw <- san(nw ~ edges, target.stats = network.dyadcount(nw)/10) -## nw %v% "age" <- runif(net_size) -## na <- sample(c(FALSE,TRUE),network.edgecount(nw),TRUE) -## -## set.seed(0) -## e <- ergm(nw ~ absdiff("age"), control = list(MCMLE.effectiveSize = NULL)) -## nw %e% "na" <- na -## set.seed(0) -## ena <- ergm(nw ~ absdiff("age"), control = list(MCMLE.effectiveSize = NULL)) -## e2 <- simulate(ena) -## -## expect_equal(coef(e), coef(eL)) -## expect_equal(coef(ena), coef(eLna)) -## expect_equal(as.edgelist(e2), as.edgelist(eL2)) -## expect_equal(as.edgelist(e2, attrname = "na"), as.edgelist(eL2, attrname = "na")) -## } -## } -## }) - -## test_that("network and networkLite fit and simulate equal valued ergms", { -## net_size <- 50 -## bip_size <- 20 -## -## for(directed in list(FALSE, TRUE)) { -## for(bipartite in list(FALSE, bip_size)) { -## if(directed && bipartite) { -## next -## } -## -## set.seed(0) -## nwL <- networkLite(net_size, directed = directed, bipartite = bipartite) -## nwL <- san(nwL ~ edges, target.stats = network.dyadcount(nwL)) -## nwL %v% "age" <- runif(net_size) -## nwL %e% "w" <- runif(network.edgecount(nwL)) -## eL <- ergm(nwL ~ absdiff("age"), response = "w", reference = ~Unif(0,1), control = list(MCMLE.effectiveSize = NULL)) -## eL2 <- simulate(eL) -## -## set.seed(0) -## nw <- network.initialize(net_size, directed = directed, bipartite = bipartite) -## nw <- san(nw ~ edges, target.stats = network.dyadcount(nw)) -## nw %v% "age" <- runif(net_size) -## nw %e% "w" <- runif(network.edgecount(nw)) -## e <- ergm(nw ~ absdiff("age"), response = "w", reference = ~Unif(0,1), control = list(MCMLE.effectiveSize = NULL)) -## e2 <- simulate(e) -## -## expect_equal(coef(e), coef(eL)) -## expect_equal(as.edgelist(e2, attrname = "w"), as.edgelist(eL2, attrname = "w")) -## } -## } -## }) - test_that("network and networkLite `[<-` and add.edges produce consistent edgelists", { net_size <- 100 bip_size <- 40 @@ -621,7 +152,7 @@ test_that("network and networkLite `[<-` and add.edges produce consistent edgeli nw0 <- nw - rv <- san(nw0 ~ edges, target.stats = c(edges_target)) + rv <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") m <- as.matrix(rv, matrix.type = "adjacency") el <- as.matrix(rv, matrix.type = "edgelist") @@ -633,7 +164,7 @@ test_that("network and networkLite `[<-` and add.edges produce consistent edgeli expect_equal(as.edgelist(nw), as.edgelist(nwL)) expect_equal(as.edgelist(nwa), as.edgelist(nwLa)) - rv2 <- san(nw0 ~ edges, target.stats = c(edges_target)) + rv2 <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") m2 <- as.matrix(rv2, matrix.type = "adjacency") el2 <- as.matrix(rv2 - rv, matrix.type = "edgelist") @@ -690,7 +221,6 @@ test_that("network and networkLite `[<-` and add.edges produce consistent edgeli } }) - test_that("network and networkLite `+` and `-` produce consistent results", { net_size <- 100 bip_size <- 40 @@ -702,10 +232,8 @@ test_that("network and networkLite `+` and `-` produce consistent results", { next } - nw <- network.initialize(net_size, directed = directed, bipartite = bipartite) - - nw1 <- san(nw ~ edges, target.stats = c(edges_target)) - nw2 <- san(nw ~ edges, target.stats = c(edges_target)) + nw1 <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") + nw2 <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") nwL1 <- as.networkLite(nw1) nwL2 <- as.networkLite(nw2) @@ -806,6 +334,7 @@ test_that("network and networkLite behave equivalently for basic access and muta test_that("add.vertices and add.edges with irregular attribute arguments behave equivalently for network and networkLite", { net_size <- 100 bip_size <- 40 + edges_target <- net_size for(directed in list(FALSE, TRUE)) { for(bipartite in list(FALSE, bip_size)) { @@ -819,9 +348,8 @@ test_that("add.vertices and add.edges with irregular attribute arguments behave enames <- paste0("e", 1:4) set.seed(0) - nw <- network.initialize(net_size, directed = directed, bipartite = bipartite) - nwe <- san(nw ~ edges, target.stats = c(net_size)) - nw <- san(nw ~ edges, target.stats = c(net_size)) + nwe <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") + nw <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") nw %v% "v1" <- runif(net_size) nw %v% "v2" <- runif(net_size) nw %e% "e1" <- runif(network.edgecount(nw)) @@ -857,9 +385,8 @@ test_that("add.vertices and add.edges with irregular attribute arguments behave add.vertices(nw, vta, vattr = vattr, last.mode = last.mode) set.seed(0) - nwL <- networkLite(net_size, directed = directed, bipartite = bipartite) - nwLe <- san(nwL ~ edges, target.stats = c(net_size)) - nwL <- san(nwL ~ edges, target.stats = c(net_size)) + nwLe <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) + nwL <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) nwL %v% "v1" <- runif(net_size) nwL %v% "v2" <- runif(net_size) set.edge.attribute(nwL, "e1", runif(network.edgecount(nwL))) @@ -915,8 +442,9 @@ test_that("add.vertices and add.edges with irregular attribute arguments behave }) test_that("attribute setting and deleting behave equivalently for network and networkLite", { - net_size <- 10 - bip_size <- 4 + net_size <- 100 + bip_size <- 40 + edges_target <- net_size enames <- paste0("e", 1:10) vnames <- paste0("v", 1:10) @@ -930,8 +458,7 @@ test_that("attribute setting and deleting behave equivalently for network and ne } set.seed(0) - nw <- network.initialize(net_size, directed = directed, bipartite = bipartite) - nw <- san(nw ~ edges, target.stats = c(net_size)) + nw <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") for(i in seq_len(niter)) { en <- sample(enames, 1) vn <- sample(vnames, 1) @@ -955,8 +482,7 @@ test_that("attribute setting and deleting behave equivalently for network and ne } set.seed(0) - nwL <- networkLite(net_size, directed = directed, bipartite = bipartite) - nwL <- san(nwL ~ edges, target.stats = c(net_size)) + nwL <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) for(i in seq_len(niter)) { en <- sample(enames, 1) vn <- sample(vnames, 1) From 08fdfc0056f5073bb72f0a9d7a9ba8726e6db439 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Mon, 5 Sep 2022 16:49:45 -0700 Subject: [PATCH 04/49] update package description --- DESCRIPTION | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 39a5d5b..09c3281 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -5,10 +5,12 @@ Title: An Alternative Implementation of some of the `network` Package Functionality Description: An implementation of *some* of the `network` package functionality based on a simplified data structure that is faster in some applications. - Primarily intended for back-end use in `statnet` and `EpiModel` packages. - Supports binary and weighted, directed and undirected, bipartite and - unipartite networks; does not support multigraphs, hypergraphs, or loops. - Vertex and edge attributes should be atomic. + Primarily intended for back-end use in `statnet` and `EpiModel` packages; + the implementation is subject to change without notice. Supports binary and + weighted, directed and undirected, bipartite and unipartite networks; + does not support multigraphs, hypergraphs, or loops. Vertex and + edge attributes should be atomic, with a single (length one) value for each + vertex or edge. Maintainer: Samuel Jenness Authors@R: c(person("Samuel", "Jenness", role=c("cre","aut"), email="samuel.m.jenness@emory.edu"), From 703ffc7445e9481fc9537e1196e45a3f7654e1dd Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Tue, 6 Sep 2022 05:25:52 -0700 Subject: [PATCH 05/49] update error messages --- R/networkLite.R | 28 +++++++++++++++++----------- 1 file changed, 17 insertions(+), 11 deletions(-) diff --git a/R/networkLite.R b/R/networkLite.R index 94ac0bd..fb8ddc5 100644 --- a/R/networkLite.R +++ b/R/networkLite.R @@ -128,8 +128,8 @@ networkLite.edgelist <- function( if (!isFALSE(nw$gal[["loops"]]) || !isFALSE(nw$gal[["hyper"]]) || !isFALSE(nw$gal[["multiple"]])) { - stop("networkLite requires network attributes `loops`, - `hyper`, and `multiple` be `FALSE`.") + stop("networkLite requires network attributes `loops`, `hyper`, and", + " `multiple` be `FALSE`.") } ## for consistency with network, @@ -399,12 +399,13 @@ mixingmatrix.networkLite <- function(object, attr, ...) { "[<-.networkLite" <- function(x, i, j, names.eval = NULL, add.edges = FALSE, value) { if (!missing(i) || !missing(j)) { - stop("`[<-.networkLite` does not support `i` and `j` - arguments at this time") + stop("`[<-.networkLite` does not support `i` and `j` arguments at this", + " time") } if (any(is.na(value))) { - stop("`[<-.networkLite` does not support NA `value` arguments at this time") + stop("`[<-.networkLite` does not support NA `value` arguments at this", + " time") } if (is.null(names.eval) && isTRUE(all(value == FALSE))) { @@ -564,6 +565,11 @@ as.networkLite <- function(x, ...) { #' @rdname networkLitemethods #' @export as.networkLite.network <- function(x, ...) { + if (is.hyper(x) || is.multiplex(x) || has.loops(x)) { + stop("cannot coerce `network` to `networkLite` unless `hyper`,", + " `multiple`, and `loops` are all `FALSE`") + } + el <- as.edgelist(x, na.rm = FALSE) rv <- networkLite(el) @@ -827,8 +833,8 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL, if (!identical(e1 %n% "n", e2 %n% "n") || !identical(e1 %n% "directed", e2 %n% "directed") || !identical(e1 %n% "bipartite", e2 %n% "bipartite")) { - stop("cannot add networkLites of differing network size, directedness, or - bipartiteness") + stop("cannot add networkLites of differing network size, directedness, or", + " bipartiteness") } if (any(NVL(e1 %e% "na", FALSE)) || any(NVL(e2 %e% "na", FALSE))) { @@ -850,13 +856,13 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL, if (!identical(e1 %n% "n", e2 %n% "n") || !identical(e1 %n% "directed", e2 %n% "directed") || !identical(e1 %n% "bipartite", e2 %n% "bipartite")) { - stop("cannot subtract networkLites of differing network size, directedness, - or bipartiteness") + stop("cannot subtract networkLites of differing network size,", + " directedness, or bipartiteness") } if (any(NVL(e1 %e% "na", FALSE)) || any(NVL(e2 %e% "na", FALSE))) { - stop("subtracting networkLites with missing edges is - not currently supported") + stop("subtracting networkLites with missing edges is not currently", + " supported") } out <- e1 From 1ef013e0b8d32fc305a07f8bc67530ee9fc7b7dd Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Tue, 6 Sep 2022 05:36:35 -0700 Subject: [PATCH 06/49] add as.networkLite tests for hyper, multiple, and loops --- tests/testthat/test-networkLite.R | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index 1274b47..e5f9ecb 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -547,3 +547,32 @@ test_that("attribute setting and deleting behave equivalently for network and ne } } }) + +test_that("as.networkLite conversions work as expected with respect to network attributes", { + net_size <- 10L + bip_size <- 4L + + nw <- network.initialize(net_size) + nwL <- as.networkLite(nw) + expect_is(nwL, "networkLite") + expect_is(nwL, "network") + + nw <- network.initialize(net_size, directed = FALSE) + nwL <- as.networkLite(nw) + expect_is(nwL, "networkLite") + expect_is(nwL, "network") + + nw <- network.initialize(net_size, directed = FALSE, bipartite = bip_size) + nwL <- as.networkLite(nw) + expect_is(nwL, "networkLite") + expect_is(nwL, "network") + + nw <- network.initialize(net_size, directed = FALSE, bipartite = FALSE, hyper = TRUE) + expect_error(nwL <- as.networkLite(nw), "cannot coerce `network` to `networkLite`") + + nw <- network.initialize(net_size, directed = FALSE, bipartite = FALSE, multiple = TRUE) + expect_error(nwL <- as.networkLite(nw), "cannot coerce `network` to `networkLite`") + + nw <- network.initialize(net_size, directed = FALSE, bipartite = FALSE, loops = TRUE) + expect_error(nwL <- as.networkLite(nw), "cannot coerce `network` to `networkLite`") +}) From 0c4a996a4e6e03df168a0ce9086911bea71e1456 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Tue, 6 Sep 2022 05:45:27 -0700 Subject: [PATCH 07/49] tweak test name --- tests/testthat/test-networkLite.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index e5f9ecb..b6c293a 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -548,7 +548,7 @@ test_that("attribute setting and deleting behave equivalently for network and ne } }) -test_that("as.networkLite conversions work as expected with respect to network attributes", { +test_that("as.networkLite conversion errors work as expected with respect to network attributes", { net_size <- 10L bip_size <- 4L From 485cf3049587f24dac8dfc076507df4ed2c2092e Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Tue, 6 Sep 2022 09:46:57 -0700 Subject: [PATCH 08/49] lint --- R/networkLite.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/networkLite.R b/R/networkLite.R index fb8ddc5..d59edb1 100644 --- a/R/networkLite.R +++ b/R/networkLite.R @@ -569,7 +569,7 @@ as.networkLite.network <- function(x, ...) { stop("cannot coerce `network` to `networkLite` unless `hyper`,", " `multiple`, and `loops` are all `FALSE`") } - + el <- as.edgelist(x, na.rm = FALSE) rv <- networkLite(el) From f83c38fe7d7d9b96d48ccc42623b844ff5c446a0 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Fri, 9 Sep 2022 05:22:33 -0700 Subject: [PATCH 09/49] move network from Imports to Depends so that the "network API" is available to the user upon loading networkLite --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 09c3281..15afc1a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -28,10 +28,10 @@ License: GPL-3 URL: http://www.epimodel.org/ BugReports: https://github.com/EpiModel/networkLite/issues Depends: - R (>= 3.5) + R (>= 3.5), + network (>= 1.17.2) Imports: statnet.common (>= 4.6.0), - network (>= 1.17.2), tibble, dplyr Suggests: From a2881276d8bb569e139400f2b066e149140ebe14 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Sun, 11 Sep 2022 09:55:41 -0700 Subject: [PATCH 10/49] add support for non-atomic attributes and update documentation, tests, etc. references statnet/networkDynamic#16 --- DESCRIPTION | 4 +- R/networkLite.R | 105 +++++++++++++++++++++++------- man/as.networkLite.Rd | 34 ++++++++++ man/networkLitemethods.Rd | 25 +++---- man/to_network_networkLite.Rd | 7 +- tests/testthat/test-networkLite.R | 29 +++++++++ 6 files changed, 161 insertions(+), 43 deletions(-) create mode 100644 man/as.networkLite.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 15afc1a..9819798 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -8,9 +8,7 @@ Description: An implementation of *some* of the `network` package functionality Primarily intended for back-end use in `statnet` and `EpiModel` packages; the implementation is subject to change without notice. Supports binary and weighted, directed and undirected, bipartite and unipartite networks; - does not support multigraphs, hypergraphs, or loops. Vertex and - edge attributes should be atomic, with a single (length one) value for each - vertex or edge. + does not support multigraphs, hypergraphs, or loops. Maintainer: Samuel Jenness Authors@R: c(person("Samuel", "Jenness", role=c("cre","aut"), email="samuel.m.jenness@emory.edu"), diff --git a/R/networkLite.R b/R/networkLite.R index d59edb1..248fc5b 100644 --- a/R/networkLite.R +++ b/R/networkLite.R @@ -179,23 +179,34 @@ networkLite_initialize <- networkLite.numeric #' @param value The attribute value to set in vertex, edge, and network #' attribute setters; the value to set edges to (must be FALSE) #' for the \code{networkLite} replacement method. +#' @param unlist logical; if \code{TRUE}, call \code{unlist} on the attribute +#' value before returning it; if \code{FALSE}, call \code{as.list} on +#' the attribute value before returning it #' @param ... Any additional arguments. #' #' @details Allows use of networkLite objects in \code{ergm_model}. #' -#' @return An edgelist for \code{as.edgelist.networkLite}; an updated -#' \code{networkLite} object for the replacement method. The other -#' methods return no objects. +#' @return Behavior and return values are analogous to those of the +#' corresponding \code{network} methods, with network data structured +#' in the \code{networkLite} format. #' #' @rdname networkLitemethods #' @export #' -get.vertex.attribute.networkLite <- function(x, attrname, ...) { +get.vertex.attribute.networkLite <- function(x, attrname, ..., unlist = TRUE) { if (attrname %in% list.vertex.attributes(x)) { - x$attr[[attrname]] + out <- x$attr[[attrname]] } else { - rep(NA, length.out = network.size(x)) + out <- rep(NA, length.out = network.size(x)) } + + if (unlist == TRUE) { + out <- unlist(out) + } else { + out <- as.list(out) + } + + return(out) } #' @rdname networkLitemethods @@ -255,8 +266,16 @@ list.network.attributes.networkLite <- function(x, ...) { #' @rdname networkLitemethods #' @export #' -get.edge.attribute.networkLite <- function(x, attrname, ...) { - x$el[[attrname]] +get.edge.attribute.networkLite <- function(x, attrname, ..., unlist = TRUE) { + out <- x$el[[attrname]] + + if (unlist == TRUE) { + out <- unlist(out) + } else { + out <- as.list(out) + } + + return(out) } #' @rdname networkLitemethods @@ -338,7 +357,7 @@ as.edgelist.networkLite <- function(x, attrname = NULL, if (output == "matrix") { m <- matrix(c(x$el$.tail, x$el$.head), ncol = 2) if (!is.null(attrname)) { - m <- cbind(m, x$el[[attrname]]) + m <- cbind(m, get.edge.attribute(x, attrname)) } } else { m <- x$el[c(".tail", ".head", attrname)] @@ -503,7 +522,7 @@ print.networkLite <- function(x, ...) { #' @rdname networkLitemethods #' @export network.naedgecount.networkLite <- function(x, ...) { - sum(x$el[["na"]]) + sum(x %e% "na") } #' @rdname networkLitemethods @@ -556,13 +575,23 @@ as.network.networkLite <- function(x, ...) { return(x) } -#' @rdname networkLitemethods +#' @rdname as.networkLite +#' @title as.networkLite +#' @description Convert to \code{networkLite} representation. +#' @details Currently the network attributes \code{hyper}, \code{multiple}, and +#' \code{loops} must be \code{FALSE} for \code{networkLite}s; +#' attempting to convert to \code{networkLite} when this is not the +#' case will result in an error. +#' @param x a \code{network} or \code{networkLite} object +#' @param ... additional arguments +#' @return a corresponding \code{networkLite} object +#' @seealso \code{\link{to_network_networkLite}} #' @export as.networkLite <- function(x, ...) { UseMethod("as.networkLite") } -#' @rdname networkLitemethods +#' @rdname as.networkLite #' @export as.networkLite.network <- function(x, ...) { if (is.hyper(x) || is.multiplex(x) || has.loops(x)) { @@ -575,38 +604,68 @@ as.networkLite.network <- function(x, ...) { rv <- networkLite(el) for (name in list.vertex.attributes(x)) { - rv %v% name <- x %v% name + set.vertex.attribute(rv, name, get.vertex.attribute(x, + name, + null.na = TRUE, + unlist = FALSE)) } for (name in setdiff(list.network.attributes(x), c("mnext"))) { - rv %n% name <- x %n% name + set.network.attribute(rv, name, get.network.attribute(x, name)) } eids <- unlist(get.dyads.eids(x, el[, 1], el[, 2])) for (name in list.edge.attributes(x)) { - set.edge.attribute(rv, name, unlist(get.edge.attribute(x, name, null.na = TRUE, - deleted.edges.omit = FALSE, - unlist = FALSE)[eids])) + set.edge.attribute(rv, name, get.edge.attribute(x, name, null.na = TRUE, + deleted.edges.omit = FALSE, + unlist = FALSE)[eids]) } for (name in setdiff(names(attributes(x)), c("class", "names"))) { attr(rv, name) <- attr(x, name) } + rv <- atomize(rv) + rv } -#' @rdname networkLitemethods +## convert vertex and edge attributes to atomic vectors where possible; +## note that this may upcast atomic types, e.g. logical -> numeric -> character +atomize <- function(nwL) { + for (name in list.vertex.attributes(nwL)) { + value <- get.vertex.attribute(nwL, name, unlist = FALSE) + if (length(value) > 0 && + all(unlist(lapply(value, is.atomic))) && + all(unlist(lapply(value, length)) == 1)) { + nwL$attr[[name]] <- unlist(value) + } + } + + for (name in list.edge.attributes(nwL)) { + value <- get.edge.attribute(nwL, name, unlist = FALSE) + if (length(value) > 0 && + all(unlist(lapply(value, is.atomic))) && + all(unlist(lapply(value, length)) == 1)) { + nwL$el[[name]] <- unlist(value) + } + } + + nwL +} + +#' @rdname as.networkLite #' @export as.networkLite.networkLite <- function(x, ...) { x } #' @rdname to_network_networkLite -#' @title Convert networkLite to network +#' @title Convert a \code{networkLite} object to a \code{network} object #' @param x a \code{networkLite} object #' @param ... additional arguments #' @return a corresponding \code{network} object +#' @seealso \code{\link{as.networkLite}} #' @export to_network_networkLite <- function(x, ...) { nw <- network.initialize(network.size(x), @@ -618,16 +677,16 @@ to_network_networkLite <- function(x, ...) { nw <- add.edges(nw, el[, 1], el[, 2]) for (name in list.vertex.attributes(x)) { - nw %v% name <- x %v% name + set.vertex.attribute(nw, name, get.vertex.attribute(x, name, unlist = FALSE)) } for (name in list.network.attributes(x)) { - nw %n% name <- x %n% name + set.network.attribute(nw, name, get.network.attribute(x, name)) } eids <- unlist(get.dyads.eids(nw, el[, 1], el[, 2])) for (name in list.edge.attributes(x)) { - set.edge.attribute(nw, name, x %e% name, eids) + set.edge.attribute(nw, name, get.edge.attribute(x, name, unlist = FALSE), eids) } for (name in setdiff(names(attributes(x)), c("class", "names"))) { @@ -720,7 +779,7 @@ as.matrix.networkLite.edgelist <- function(x, attrname = NULL, m <- matrix(c(x$el$.tail, x$el$.head), ncol = 2) if (!is.null(attrname)) { - m <- cbind(m, x$el[[attrname]]) + m <- cbind(m, get.edge.attribute(x, attrname)) } if (na.rm == TRUE) { m <- m[!NVL(x %e% "na", FALSE), , drop = FALSE] diff --git a/man/as.networkLite.Rd b/man/as.networkLite.Rd new file mode 100644 index 0000000..ed0a805 --- /dev/null +++ b/man/as.networkLite.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/networkLite.R +\name{as.networkLite} +\alias{as.networkLite} +\alias{as.networkLite.network} +\alias{as.networkLite.networkLite} +\title{as.networkLite} +\usage{ +as.networkLite(x, ...) + +\method{as.networkLite}{network}(x, ...) + +\method{as.networkLite}{networkLite}(x, ...) +} +\arguments{ +\item{x}{a \code{network} or \code{networkLite} object} + +\item{...}{additional arguments} +} +\value{ +a corresponding \code{networkLite} object +} +\description{ +Convert to \code{networkLite} representation. +} +\details{ +Currently the network attributes \code{hyper}, \code{multiple}, and + \code{loops} must be \code{FALSE} for \code{networkLite}s; + attempting to convert to \code{networkLite} when this is not the + case will result in an error. +} +\seealso{ +\code{\link{to_network_networkLite}} +} diff --git a/man/networkLitemethods.Rd b/man/networkLitemethods.Rd index caee2e6..2b473d3 100644 --- a/man/networkLitemethods.Rd +++ b/man/networkLitemethods.Rd @@ -21,9 +21,6 @@ \alias{network.naedgecount.networkLite} \alias{add.edges.networkLite} \alias{as.network.networkLite} -\alias{as.networkLite} -\alias{as.networkLite.network} -\alias{as.networkLite.networkLite} \alias{as_tibble.networkLite} \alias{as.matrix.networkLite} \alias{is.na.networkLite} @@ -35,7 +32,7 @@ \alias{-.networkLite} \title{networkLite Methods} \usage{ -\method{get.vertex.attribute}{networkLite}(x, attrname, ...) +\method{get.vertex.attribute}{networkLite}(x, attrname, ..., unlist = TRUE) \method{set.vertex.attribute}{networkLite}(x, attrname, value, v = seq_len(network.size(x)), ...) @@ -47,9 +44,9 @@ \method{list.network.attributes}{networkLite}(x, ...) -\method{get.edge.attribute}{networkLite}(x, attrname, ...) +\method{get.edge.attribute}{networkLite}(x, attrname, ..., unlist = TRUE) -\method{get.edge.value}{networkLite}(x, attrname, ...) +\method{get.edge.value}{networkLite}(x, attrname, ..., unlist = TRUE) \method{set.edge.attribute}{networkLite}( x, @@ -91,12 +88,6 @@ \method{as.network}{networkLite}(x, ...) -as.networkLite(x, ...) - -\method{as.networkLite}{network}(x, ...) - -\method{as.networkLite}{networkLite}(x, ...) - \method{as_tibble}{networkLite}(x, attrnames = NULL, na.rm = TRUE, ...) \method{as.matrix}{networkLite}( @@ -127,6 +118,10 @@ as.networkLite(x, ...) \item{...}{Any additional arguments.} +\item{unlist}{logical; if \code{TRUE}, call \code{unlist} on the attribute +value before returning it; if \code{FALSE}, call \code{as.list} on +the attribute value before returning it} + \item{value}{The attribute value to set in vertex, edge, and network attribute setters; the value to set edges to (must be FALSE) for the \code{networkLite} replacement method.} @@ -178,9 +173,9 @@ be added to the second mode?} \item{e1, e2}{networkLite objects} } \value{ -An edgelist for \code{as.edgelist.networkLite}; an updated - \code{networkLite} object for the replacement method. The other - methods return no objects. +Behavior and return values are analogous to those of the + corresponding \code{network} methods, with network data structured + in the \code{networkLite} format. } \description{ S3 methods for networkLite class, for generics defined in diff --git a/man/to_network_networkLite.Rd b/man/to_network_networkLite.Rd index 4d6a958..e9d8870 100644 --- a/man/to_network_networkLite.Rd +++ b/man/to_network_networkLite.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/networkLite.R \name{to_network_networkLite} \alias{to_network_networkLite} -\title{Convert networkLite to network} +\title{Convert a \code{networkLite} object to a \code{network} object} \usage{ to_network_networkLite(x, ...) } @@ -15,5 +15,8 @@ to_network_networkLite(x, ...) a corresponding \code{network} object } \description{ -Convert networkLite to network +Convert a \code{networkLite} object to a \code{network} object +} +\seealso{ +\code{\link{as.networkLite}} } diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index b6c293a..79e1a66 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -576,3 +576,32 @@ test_that("as.networkLite conversion errors work as expected with respect to net nw <- network.initialize(net_size, directed = FALSE, bipartite = FALSE, loops = TRUE) expect_error(nwL <- as.networkLite(nw), "cannot coerce `network` to `networkLite`") }) + +test_that("more network conversions", { + nw <- network.initialize(5, directed = FALSE) + nwL <- networkLite(5) + + set.vertex.attribute(nw, "newattr", list(1,list(3),5), c(3,4,1)) + set.vertex.attribute(nwL, "newattr", list(1,list(3),5), c(3,4,1)) + + expect_identical(get.vertex.attribute(nw, "newattr", null.na = TRUE, unlist = FALSE), + get.vertex.attribute(nwL, "newattr", unlist = FALSE)) + + expect_identical(get.vertex.attribute(nw, "newattr", null.na = TRUE, unlist = TRUE), + get.vertex.attribute(nwL, "newattr", unlist = TRUE)) + + nw[1,2] <- 1 + nw[3,4] <- 1 + nw[2,5] <- 1 + + set.edge.attribute(nw, "eattr", list(list(NULL), NA, list(3))) + + nwL <- as.networkLite(nw) + el <- as.edgelist(nwL) + + eids <- unlist(get.dyads.eids(nw, el[,1], el[,2])) + expect_identical(get.edge.attribute(nw, "eattr", null.na = TRUE, unlist = FALSE)[eids], + get.edge.attribute(nwL, "eattr", unlist = FALSE)) + expect_identical(unlist(get.edge.attribute(nw, "eattr", null.na = TRUE, unlist = FALSE)[eids]), + unlist(get.edge.attribute(nwL, "eattr", unlist = FALSE))) +}) From f4e2ba932ee7b3fd5ad100a59842dd2a05fe9ca9 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Sun, 11 Sep 2022 10:03:44 -0700 Subject: [PATCH 11/49] lint --- R/networkLite.R | 4 ++-- man/networkLitemethods.Rd | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/networkLite.R b/R/networkLite.R index 248fc5b..9ce2388 100644 --- a/R/networkLite.R +++ b/R/networkLite.R @@ -186,8 +186,8 @@ networkLite_initialize <- networkLite.numeric #' #' @details Allows use of networkLite objects in \code{ergm_model}. #' -#' @return Behavior and return values are analogous to those of the -#' corresponding \code{network} methods, with network data structured +#' @return Behavior and return values are analogous to those of the +#' corresponding \code{network} methods, with network data structured #' in the \code{networkLite} format. #' #' @rdname networkLitemethods diff --git a/man/networkLitemethods.Rd b/man/networkLitemethods.Rd index 2b473d3..988c1f8 100644 --- a/man/networkLitemethods.Rd +++ b/man/networkLitemethods.Rd @@ -173,8 +173,8 @@ be added to the second mode?} \item{e1, e2}{networkLite objects} } \value{ -Behavior and return values are analogous to those of the - corresponding \code{network} methods, with network data structured +Behavior and return values are analogous to those of the + corresponding \code{network} methods, with network data structured in the \code{networkLite} format. } \description{ From 575dd4abf6c5b3cefd545ee80b6e79fb060c8e39 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Sun, 11 Sep 2022 13:43:32 -0700 Subject: [PATCH 12/49] update edgelist with attrname behavior --- R/networkLite.R | 5 ++++- tests/testthat/test-networkLite.R | 18 ++++++++++++++++++ 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/R/networkLite.R b/R/networkLite.R index 9ce2388..590c9cd 100644 --- a/R/networkLite.R +++ b/R/networkLite.R @@ -357,7 +357,10 @@ as.edgelist.networkLite <- function(x, attrname = NULL, if (output == "matrix") { m <- matrix(c(x$el$.tail, x$el$.head), ncol = 2) if (!is.null(attrname)) { - m <- cbind(m, get.edge.attribute(x, attrname)) + attrval <- get.edge.attribute(x, attrname, unlist = FALSE) + ## analogous to null.na = TRUE in network + attrval <- lapply(attrval, function(val) NVL(val, NA)) + m <- cbind(m, unlist(attrval)) } } else { m <- x$el[c(".tail", ".head", attrname)] diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index 79e1a66..b7884a6 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -605,3 +605,21 @@ test_that("more network conversions", { expect_identical(unlist(get.edge.attribute(nw, "eattr", null.na = TRUE, unlist = FALSE)[eids]), unlist(get.edge.attribute(nwL, "eattr", unlist = FALSE))) }) + +test_that("as.edgelist with attrname", { + nw <- network.initialize(10, directed = FALSE) + nw[1,2] <- 1 + nw[1,5] <- 1 + nw[2,7] <- 1 + nw[3,8] <- 1 + nw[5,10] <- 1 + + nwL <- networkLite(as.edgelist(nw)) + + set.edge.attribute(nwL, "eattr", list(1, 2, NULL, NA, 3)) + + el <- as.edgelist(nwL, attrname = "eattr") + + expect_equal(nwL$el[["eattr"]], list(1, 2, NULL, NA, 3)) + expect_equal(el[,3], c(1, 2, NA, NA, 3)) +}) From 96c60ef1f2ee47187aba76954e0e6632b9d18710 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Mon, 12 Sep 2022 07:12:49 -0700 Subject: [PATCH 13/49] add unlist for get.network.attribute and update documentation --- R/networkLite.R | 47 +++++++++++++++++---------------------- man/networkLite.Rd | 26 +++++----------------- man/networkLitemethods.Rd | 13 +++++++---- 3 files changed, 35 insertions(+), 51 deletions(-) diff --git a/R/networkLite.R b/R/networkLite.R index 590c9cd..f361ef2 100644 --- a/R/networkLite.R +++ b/R/networkLite.R @@ -57,27 +57,11 @@ #' @export #' #' @examples -#' \dontrun{ -#' library("EpiModel") -#' nw <- network_initialize(100) -#' formation <- ~edges -#' target.stats <- 50 -#' coef.diss <- dissolution_coefs(dissolution = ~offset(edges), duration = 20) -#' x <- netest(nw, formation, target.stats, coef.diss, verbose = FALSE) -#' -#' param <- param.net(inf.prob = 0.3) -#' init <- init.net(i.num = 10) -#' control <- control.net(type = "SI", nsteps = 100, nsims = 5, -#' tergmLite = TRUE) -#' -#' # networkLite representation after initialization -#' dat <- crosscheck.net(x, param, init, control) -#' dat <- initialize.net(x, param, init, control) -#' -#' # Conversion to networkLite class format -#' nwl <- networkLite(dat$el[[1]], dat$attr) -#' nwl -#' } +#' edgelist <- cbind(c(1,2,3), c(2,4,7)) +#' attr(edgelist, "n") <- 10 # network size +#' vertex_attributes <- list(a = 1:10, b = runif(10)) +#' nwL <- networkLite(edgelist, vertex_attributes) +#' nwL #' networkLite <- function(x, ...) { UseMethod("networkLite") @@ -179,9 +163,14 @@ networkLite_initialize <- networkLite.numeric #' @param value The attribute value to set in vertex, edge, and network #' attribute setters; the value to set edges to (must be FALSE) #' for the \code{networkLite} replacement method. -#' @param unlist logical; if \code{TRUE}, call \code{unlist} on the attribute -#' value before returning it; if \code{FALSE}, call \code{as.list} on -#' the attribute value before returning it +#' @param unlist logical; in \code{get.vertex.attribute} and +#' \code{get.edge.attribute}, if \code{unlist} is \code{TRUE}, call +#' \code{unlist} on the attribute value before returning it, and if +#' \code{unlist} is \code{FALSE}, call \code{as.list} on the attribute +#' value before returning it; in \code{get.network.attribute}, if +#' \code{unlist} is \code{TRUE}, call \code{unlist} on the attribute +#' value before returning it, and if \code{unlist} is \code{FALSE}, +#' return the attribute value without any modification #' @param ... Any additional arguments. #' #' @details Allows use of networkLite objects in \code{ergm_model}. @@ -240,8 +229,14 @@ list.vertex.attributes.networkLite <- function(x, ...) { #' @rdname networkLitemethods #' @export #' -get.network.attribute.networkLite <- function(x, attrname, ...) { - x$gal[[attrname]] +get.network.attribute.networkLite <- function(x, attrname, ..., unlist = FALSE) { + out <- x$gal[[attrname]] + + if (unlist == TRUE) { + out <- unlist(out) + } + + return(out) } #' @rdname networkLitemethods diff --git a/man/networkLite.Rd b/man/networkLite.Rd index 87239d6..8172867 100644 --- a/man/networkLite.Rd +++ b/man/networkLite.Rd @@ -81,26 +81,10 @@ Within \code{tergmLite}, the \code{networkLite} data structure is used in the calls to \code{ergm} and \code{tergm} \code{simulate} functions. } \examples{ -\dontrun{ -library("EpiModel") -nw <- network_initialize(100) -formation <- ~edges -target.stats <- 50 -coef.diss <- dissolution_coefs(dissolution = ~offset(edges), duration = 20) -x <- netest(nw, formation, target.stats, coef.diss, verbose = FALSE) - -param <- param.net(inf.prob = 0.3) -init <- init.net(i.num = 10) -control <- control.net(type = "SI", nsteps = 100, nsims = 5, - tergmLite = TRUE) - -# networkLite representation after initialization -dat <- crosscheck.net(x, param, init, control) -dat <- initialize.net(x, param, init, control) - -# Conversion to networkLite class format -nwl <- networkLite(dat$el[[1]], dat$attr) -nwl -} +edgelist <- cbind(c(1,2,3), c(2,4,7)) +attr(edgelist, "n") <- 10 # network size +vertex_attributes <- list(a = 1:10, b = runif(10)) +nwL <- networkLite(edgelist, vertex_attributes) +nwL } diff --git a/man/networkLitemethods.Rd b/man/networkLitemethods.Rd index 988c1f8..0152160 100644 --- a/man/networkLitemethods.Rd +++ b/man/networkLitemethods.Rd @@ -38,7 +38,7 @@ \method{list.vertex.attributes}{networkLite}(x, ...) -\method{get.network.attribute}{networkLite}(x, attrname, ...) +\method{get.network.attribute}{networkLite}(x, attrname, ..., unlist = FALSE) \method{set.network.attribute}{networkLite}(x, attrname, value, ...) @@ -118,9 +118,14 @@ \item{...}{Any additional arguments.} -\item{unlist}{logical; if \code{TRUE}, call \code{unlist} on the attribute -value before returning it; if \code{FALSE}, call \code{as.list} on -the attribute value before returning it} +\item{unlist}{logical; in \code{get.vertex.attribute} and +\code{get.edge.attribute}, if \code{unlist} is \code{TRUE}, call +\code{unlist} on the attribute value before returning it, and if +\code{unlist} is \code{FALSE}, call \code{as.list} on the attribute +value before returning it; in \code{get.network.attribute}, if +\code{unlist} is \code{TRUE}, call \code{unlist} on the attribute +value before returning it, and if \code{unlist} is \code{FALSE}, +return the attribute value without any modification} \item{value}{The attribute value to set in vertex, edge, and network attribute setters; the value to set edges to (must be FALSE) From 7df1c8e656f9dce7a9374fb46c19058237e4ab6e Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Mon, 12 Sep 2022 10:02:26 -0700 Subject: [PATCH 14/49] overhaul of package documentation and organization --- R/add_edges.R | 143 ++++ R/add_vertices.R | 52 ++ R/as.networkLite.R | 87 +++ R/attribute_methods.R | 206 ++++++ R/constructors.R | 153 ++++ R/matrix_conversions.R | 138 ++++ R/misc.R | 116 +++ R/mixingmatrix.R | 31 + R/networkLite.R | 933 ------------------------ R/to_network_networkLite.R | 46 ++ man/add_edges.Rd | 34 + man/add_vertices.Rd | 25 + man/as.networkLite.Rd | 20 +- man/attribute_methods.Rd | 95 +++ man/{networkLite.Rd => constructors.Rd} | 4 +- man/edgecount.Rd | 28 + man/is.na.Rd | 19 + man/matrix_conversions.Rd | 47 ++ man/mixingmatrix.Rd | 21 + man/networkLitemethods.Rd | 191 ----- man/operators.Rd | 23 + man/print.Rd | 20 + man/to_network_networkLite.Rd | 16 +- 23 files changed, 1311 insertions(+), 1137 deletions(-) create mode 100644 R/add_edges.R create mode 100644 R/add_vertices.R create mode 100644 R/as.networkLite.R create mode 100644 R/attribute_methods.R create mode 100644 R/constructors.R create mode 100644 R/matrix_conversions.R create mode 100644 R/misc.R create mode 100644 R/mixingmatrix.R delete mode 100644 R/networkLite.R create mode 100644 R/to_network_networkLite.R create mode 100644 man/add_edges.Rd create mode 100644 man/add_vertices.Rd create mode 100644 man/attribute_methods.Rd rename man/{networkLite.Rd => constructors.Rd} (96%) create mode 100644 man/edgecount.Rd create mode 100644 man/is.na.Rd create mode 100644 man/matrix_conversions.Rd create mode 100644 man/mixingmatrix.Rd delete mode 100644 man/networkLitemethods.Rd create mode 100644 man/operators.Rd create mode 100644 man/print.Rd diff --git a/R/add_edges.R b/R/add_edges.R new file mode 100644 index 0000000..0825802 --- /dev/null +++ b/R/add_edges.R @@ -0,0 +1,143 @@ + +#' @rdname add_edges +#' @title Methods to Add or Modify Edges in a \code{networkLite} +#' @param x A \code{networkLite}. +#' @param tail Vector of tails of edges to add to the networkLite. +#' @param head Vector of heads of edges to add to the networkLite. +#' @param names.eval name(s) of edge attributes +#' @param vals.eval value(s) of edge attributes +#' @param i,j Nodal indices (must be missing for networkLite method). +#' @param add.edges should edges being assigned to be added if not already +#' present? +#' @param value edge values to assign +#' @param ... additional arguments +#' @export +add.edges.networkLite <- function(x, tail, head, names.eval = NULL, + vals.eval = NULL, ...) { + tail <- NVL(unlist(tail), integer(0)) + head <- NVL(unlist(head), integer(0)) + if (length(names.eval) == 0 || length(vals.eval) == 0) { + update_tibble <- as_tibble(list(.tail = tail, .head = head, + na = logical(length(tail)))) + } else { + if (!is.list(names.eval)) names.eval <- + as.list(rep(names.eval, length.out = length(tail))) + if (!is.list(vals.eval)) vals.eval <- + as.list(rep(vals.eval, length.out = length(names.eval))) + + for (i in seq_along(vals.eval)) { + vals.eval[[i]] <- as.list(vals.eval[[i]]) + names(vals.eval[[i]]) <- unlist(names.eval[[i]]) + } + + f <- function(x) if (length(x) > 0) as_tibble(x) else tibble(NULL, .rows = 1) + update_tibble <- + dplyr::bind_cols(as_tibble(list(.tail = tail, .head = head)), + dplyr::bind_rows(lapply(vals.eval, f))) + } + + update_tibble[["na"]] <- NVL(update_tibble[["na"]], + logical(NROW(update_tibble))) + update_tibble[["na"]][is.na(update_tibble[["na"]])] <- FALSE + + xn <- substitute(x) + + x$el <- dplyr::bind_rows(x$el, update_tibble) + x$el <- x$el[order(x$el$.tail, x$el$.head), ] + x$el <- x$el[!duplicated(x$el[, c(".tail", ".head")]), ] + + on.exit(eval.parent(call("<-", xn, x))) + invisible(x) +} + +#' @rdname add_edges +#' @export +"[<-.networkLite" <- function(x, i, j, names.eval = NULL, + add.edges = FALSE, value) { + if (!missing(i) || !missing(j)) { + stop("`[<-.networkLite` does not support `i` and `j` arguments at this", + " time") + } + + if (any(is.na(value))) { + stop("`[<-.networkLite` does not support NA `value` arguments at this", + " time") + } + + if (is.null(names.eval) && isTRUE(all(value == FALSE))) { + x$el <- as_tibble(list(.tail = integer(0), + .head = integer(0), + na = logical(0))) + return(x) + } + + b1 <- if (is.bipartite(x)) x %n% "bipartite" else + network.size(x) + b2 <- if (is.bipartite(x)) network.size(x) - x %n% "bipartite" else + network.size(x) + + if (!is.matrix(value)) { + value <- matrix(value, nrow = b1, ncol = b2) + } else { + if (nrow(value) < b1 || ncol(value) < b2) { + stop("too small a matrix `value` passed to `[<-.networkLite`") + } + value <- value[seq_len(b1), seq_len(b2), drop = FALSE] + } + + if (is.null(names.eval)) { + # add edges whether or not add.edges is TRUE, + # for consistency with `network` behavior + w <- which(value != 0, arr.ind = TRUE) + if (is.bipartite(x)) { + w[, 2] <- w[, 2] + b1 + } + if (!is.directed(x)) { + w <- w[w[, 1] < w[, 2], , drop = FALSE] + } else { + w <- w[w[, 1] != w[, 2], , drop = FALSE] + } + w <- w[order(w[, 1], w[, 2]), , drop = FALSE] + x$el <- as_tibble(list(.tail = w[, 1], + .head = w[, 2], + na = logical(NROW(w)))) + } else { + if (!add.edges) { + el <- as.edgelist(x, na.rm = FALSE) + if (is.bipartite(x)) { + el[, 2] <- el[, 2] - b1 + } + if (names.eval == "na") { + value[is.na(value)] <- FALSE + } + set.edge.attribute(x, names.eval, value[el]) + } else { + w <- which(value != 0, arr.ind = TRUE) + vals <- value[w] + if (is.bipartite(x)) { + w[, 2] <- w[, 2] + b1 + } + if (!is.directed(x)) { + vals <- vals[w[, 1] < w[, 2]] + w <- w[w[, 1] < w[, 2], , drop = FALSE] + } else { + vals <- vals[w[, 1] != w[, 2]] + w <- w[w[, 1] != w[, 2], , drop = FALSE] + } + vals <- vals[order(w[, 1], w[, 2])] + w <- w[order(w[, 1], w[, 2]), , drop = FALSE] + if (names.eval == "na") { + vals[is.na(vals)] <- FALSE + tbl_list <- list(w[, 1], w[, 2], vals) + names(tbl_list) <- c(".tail", + ".head", + names.eval) + } else { + tbl_list <- list(w[, 1], w[, 2], vals, logical(NROW(w))) + names(tbl_list) <- c(".tail", ".head", names.eval, "na") + } + x$el <- as_tibble(tbl_list) + } + } + return(x) +} diff --git a/R/add_vertices.R b/R/add_vertices.R new file mode 100644 index 0000000..bd6bb10 --- /dev/null +++ b/R/add_vertices.R @@ -0,0 +1,52 @@ +#' @rdname add_vertices +#' @title Add Vertices to a \code{networkLite} +#' @param x A \code{networkLite} object. +#' @param nv Number of vertices to add to the \code{networkLite}. +#' @param vattr A list (of length \code{nv}) of named lists of vertex +#' attribute values for added vertices, or \code{NULL} to indicate vertex +#' attribute values are not being passed. +#' @param last.mode logical; if \code{x} is bipartite, should the new vertices +#' be added to the second mode? +#' @param ... additional arguments +#' @export +add.vertices.networkLite <- function(x, nv, vattr = NULL, + last.mode = TRUE, ...) { + xn <- substitute(x) + + nv <- as.integer(nv) + if (nv > 0) { + oldsize <- network.size(x) + x %n% "n" <- oldsize + nv + + if (is.bipartite(x) && !last.mode) { + offset <- x %n% "bipartite" + x %n% "bipartite" <- x %n% "bipartite" + nv + x$el$.head <- x$el$.head + nv + } else { + offset <- oldsize + } + + if (!is.null(vattr)) { + if (is.list(vattr)) { + vattr <- rep(vattr, length.out = nv) + } else { + vattr <- as.list(rep(vattr, length.out = nv)) + } + + f <- function(x) if (length(x) > 0) as_tibble(x) else tibble(NULL, .rows = 1) + update_tibble <- dplyr::bind_rows(lapply(vattr, f)) + } else { + update_tibble <- as_tibble(list(na = logical(nv))) + } + update_tibble[["na"]] <- NVL(update_tibble[["na"]], + logical(NROW(update_tibble))) + update_tibble[["na"]][is.na(update_tibble[["na"]])] <- FALSE + + x$attr <- dplyr::bind_rows(x$attr[seq_len(offset), ], + update_tibble, + x$attr[offset + seq_len(oldsize - offset), ]) + } + + on.exit(eval.parent(call("<-", xn, x))) + invisible(x) +} diff --git a/R/as.networkLite.R b/R/as.networkLite.R new file mode 100644 index 0000000..20ce4e5 --- /dev/null +++ b/R/as.networkLite.R @@ -0,0 +1,87 @@ +#' @rdname as.networkLite +#' @title Convert to \code{networkLite} Representation +#' @details \code{as.networkLite.network} converts a \code{network} object +#' to a \code{networkLite} object. \code{as.networkLite.networkLite} +#' returns the \code{networkLite} object unchanged. +#' +#' Currently the network attributes \code{hyper}, \code{multiple}, and +#' \code{loops} must be \code{FALSE} for \code{networkLite}s; +#' attempting to convert a \code{network} to a \code{networkLite} when +#' this is not the case will result in an error. +#' @param x A \code{network} or \code{networkLite} object. +#' @param ... additional arguments +#' @return A corresponding \code{networkLite} object. +#' @seealso \code{\link{to_network_networkLite}} +#' @export +as.networkLite <- function(x, ...) { + UseMethod("as.networkLite") +} + +#' @rdname as.networkLite +#' @export +as.networkLite.network <- function(x, ...) { + if (is.hyper(x) || is.multiplex(x) || has.loops(x)) { + stop("cannot coerce `network` to `networkLite` unless `hyper`,", + " `multiple`, and `loops` are all `FALSE`") + } + + el <- as.edgelist(x, na.rm = FALSE) + + rv <- networkLite(el) + + for (name in list.vertex.attributes(x)) { + set.vertex.attribute(rv, name, get.vertex.attribute(x, + name, + null.na = TRUE, + unlist = FALSE)) + } + + for (name in setdiff(list.network.attributes(x), c("mnext"))) { + set.network.attribute(rv, name, get.network.attribute(x, name)) + } + + eids <- unlist(get.dyads.eids(x, el[, 1], el[, 2])) + for (name in list.edge.attributes(x)) { + set.edge.attribute(rv, name, get.edge.attribute(x, name, null.na = TRUE, + deleted.edges.omit = FALSE, + unlist = FALSE)[eids]) + } + + for (name in setdiff(names(attributes(x)), c("class", "names"))) { + attr(rv, name) <- attr(x, name) + } + + rv <- atomize(rv) + + rv +} + +## convert vertex and edge attributes to atomic vectors where possible; +## note that this may upcast atomic types, e.g. logical -> numeric -> character +atomize <- function(nwL) { + for (name in list.vertex.attributes(nwL)) { + value <- get.vertex.attribute(nwL, name, unlist = FALSE) + if (length(value) > 0 && + all(unlist(lapply(value, is.atomic))) && + all(unlist(lapply(value, length)) == 1)) { + nwL$attr[[name]] <- unlist(value) + } + } + + for (name in list.edge.attributes(nwL)) { + value <- get.edge.attribute(nwL, name, unlist = FALSE) + if (length(value) > 0 && + all(unlist(lapply(value, is.atomic))) && + all(unlist(lapply(value, length)) == 1)) { + nwL$el[[name]] <- unlist(value) + } + } + + nwL +} + +#' @rdname as.networkLite +#' @export +as.networkLite.networkLite <- function(x, ...) { + x +} diff --git a/R/attribute_methods.R b/R/attribute_methods.R new file mode 100644 index 0000000..915b3ff --- /dev/null +++ b/R/attribute_methods.R @@ -0,0 +1,206 @@ + +#' @rdname attribute_methods +#' @title \code{networkLite} Attribute Methods +#' +#' @description S3 attribute methods for the \code{networkLite} class, for +#' generics defined in the \code{network} package. +#' +#' @param x A \code{networkLite} object. +#' @param attrname The name of an attribute in \code{x}; must be a length one +#' character vector. +#' @param value The attribute value to set in vertex, edge, and network +#' attribute setters. +#' @param v Indices at which to set vertex attribute values. +#' @param e Indices at which to set edge attribute values. +#' @param unlist Logical. In \code{get.vertex.attribute} and +#' \code{get.edge.attribute}, if \code{unlist} is \code{TRUE}, we call +#' \code{unlist} on the attribute value before returning it, and if +#' \code{unlist} is \code{FALSE}, we call \code{as.list} on the +#' attribute value before returning it. In \code{get.network.attribute}, +#' if \code{unlist} is \code{TRUE}, we call \code{unlist} on the +#' attribute value before returning it, and if \code{unlist} is +#' \code{FALSE}, we return the attribute value without any modification. +#' @param ... additional arguments +#' +#' @details Allows basic attribute manipulation for \code{networkLite}s. +#' +#' @return Behavior and return values are analogous to those of the +#' corresponding \code{network} methods, with network data structured +#' in the \code{networkLite} format. +#' +#' @export +#' +get.vertex.attribute.networkLite <- function(x, attrname, ..., unlist = TRUE) { + if (attrname %in% list.vertex.attributes(x)) { + out <- x$attr[[attrname]] + } else { + out <- rep(NA, length.out = network.size(x)) + } + + if (unlist == TRUE) { + out <- unlist(out) + } else { + out <- as.list(out) + } + + return(out) +} + +#' @rdname attribute_methods +#' @export +#' +set.vertex.attribute.networkLite <- function(x, + attrname, + value, + v = seq_len(network.size(x)), + ...) { + xn <- substitute(x) + + if (!(attrname %in% list.vertex.attributes(x))) { + x$attr[[attrname]] <- rep(NA, length.out = network.size(x)) + } + + x$attr[[attrname]][v] <- value + + on.exit(eval.parent(call("<-", xn, x))) + invisible(x) +} + +#' @rdname attribute_methods +#' @export +#' +list.vertex.attributes.networkLite <- function(x, ...) { + sort(unique(names(x$attr))) +} + +#' @rdname attribute_methods +#' @export +#' +get.network.attribute.networkLite <- function(x, attrname, ..., unlist = FALSE) { + out <- x$gal[[attrname]] + + if (unlist == TRUE) { + out <- unlist(out) + } + + return(out) +} + +#' @rdname attribute_methods +#' @export +#' +set.network.attribute.networkLite <- function(x, attrname, value, ...) { + xn <- substitute(x) + + x$gal[[attrname]] <- value + + on.exit(eval.parent(call("<-", xn, x))) + invisible(x) +} + +#' @rdname attribute_methods +#' @export +#' +list.network.attributes.networkLite <- function(x, ...) { + sort(unique(names(x$gal))) +} + +#' @rdname attribute_methods +#' @export +#' +get.edge.attribute.networkLite <- function(x, attrname, ..., unlist = TRUE) { + out <- x$el[[attrname]] + + if (unlist == TRUE) { + out <- unlist(out) + } else { + out <- as.list(out) + } + + return(out) +} + +#' @rdname attribute_methods +#' @export +#' +get.edge.value.networkLite <- get.edge.attribute.networkLite + +#' @rdname attribute_methods +#' @export +#' +set.edge.attribute.networkLite <- function( + x, attrname, value, + e = seq_len(network.edgecount(x, na.omit = FALSE)), ...) { + + xn <- substitute(x) + + if (!(attrname %in% list.edge.attributes(x))) { + x$el[[attrname]] <- rep(NA, + length.out = network.edgecount(x, na.omit = FALSE)) + } + + x$el[[attrname]][e] <- value + + on.exit(eval.parent(call("<-", xn, x))) + invisible(x) +} + +#' @rdname attribute_methods +#' @export +#' +set.edge.value.networkLite <- function( + x, attrname, value, + e = seq_len(network.edgecount(x, na.omit = FALSE)), ...) { + + xn <- substitute(x) + + if (!(attrname %in% list.edge.attributes(x))) { + x$el[[attrname]] <- rep(NA, + length.out = network.edgecount(x, na.omit = FALSE)) + } + + x$el[[attrname]][e] <- value[as.matrix(x$el[e, c(".tail", ".head")])] + + on.exit(eval.parent(call("<-", xn, x))) + invisible(x) +} + +#' @rdname attribute_methods +#' @export +#' +list.edge.attributes.networkLite <- function(x, ...) { + sort(unique(colnames(x$el)[-c(1, 2)])) +} + +#' @rdname attribute_methods +#' @export +delete.vertex.attribute.networkLite <- function(x, attrname, ...) { + xn <- substitute(x) + + x$attr[[attrname]] <- NULL + + on.exit(eval.parent(call("<-", xn, x))) + invisible(x) +} + +#' @rdname attribute_methods +#' @export +delete.edge.attribute.networkLite <- function(x, attrname, ...) { + xn <- substitute(x) + + x$el[[attrname]] <- NULL + + on.exit(eval.parent(call("<-", xn, x))) + invisible(x) +} + +#' @rdname attribute_methods +#' @export +delete.network.attribute.networkLite <- function(x, attrname, ...) { + xn <- substitute(x) + + x$gal[[attrname]] <- NULL + + on.exit(eval.parent(call("<-", xn, x))) + invisible(x) +} diff --git a/R/constructors.R b/R/constructors.R new file mode 100644 index 0000000..7f83646 --- /dev/null +++ b/R/constructors.R @@ -0,0 +1,153 @@ + +#' @import network +#' @importFrom statnet.common NVL NVL2 +#' @importFrom tibble tibble as_tibble is_tibble +#' @importFrom dplyr bind_rows bind_cols +#' @importFrom stats na.omit + +#' @rdname constructors +#' @title networkLite Constructor Utilities +#' +#' @description Constructor methods for \code{networkLite} objects. +#' +#' @param x Either an \code{edgelist} class network representation (including +#' network attributes in its \code{attributes} list), or a number +#' specifying the network size. +#' @param attr A named list of vertex attributes for the network represented by +#' \code{x}. +#' @param directed,bipartite Common network attributes that may be set via +#' arguments to the \code{networkLite.numeric} method. +#' @param ... additional arguments +#' +#' @details Currently there are several distinct \code{networkLite} constructor +#' methods available. +#' +#' The \code{edgelist} method takes an \code{edgelist} class object \code{x} +#' with network attributes attached in its \code{attributes} list, and a named +#' list of vertex attributes \code{attr}, and returns a \code{networkLite} +#' object, which is a named list with fields \code{el}, \code{attr}, and +#' \code{gal}; the fields \code{el} and \code{attr} match the arguments \code{x} +#' and \code{attr} (the latter coerced to \code{tibble}) respectively, and the +#' field \code{gal} is the list of network attributes (copied from +#' \code{attributes(x)}). Missing network attributes \code{directed} and +#' \code{bipartite} are defaulted to \code{FALSE}; the network size attribute +#' \code{n} must not be missing. Attributes \code{class}, \code{dim}, +#' \code{dimnames}, \code{vnames}, and \code{mnext} (if present) are not copied +#' from \code{x} to the \code{networkLite}. (For convenience, a \code{matrix} +#' method, identical to the \code{edgelist} method, is also defined, to handle +#' cases where the edgelist is, for whatever reason, not classed as an +#' \code{edgelist}.) +#' +#' The \code{numeric} method takes a number \code{x} as well as the network +#' attributes \code{directed} and \code{bipartite} (defaulting to \code{FALSE}), +#' and returns an empty \code{networkLite} with these network attributes and +#' number of nodes \code{x}. +#' +#' The constructor \code{networkLite_initialize} is also available for creating +#' an empty \code{networkLite}, and its \code{x} argument should be a number +#' indicating the size of the \code{networkLite} to create. +#' +#' Within \code{tergmLite}, the \code{networkLite} data structure is used in the +#' calls to \code{ergm} and \code{tergm} \code{simulate} functions. +#' +#' @return +#' A networkLite object with edge list \code{el}, vertex attributes \code{attr}, +#' and network attributes \code{gal}. +#' +#' @export +#' +#' @examples +#' edgelist <- cbind(c(1,2,3), c(2,4,7)) +#' attr(edgelist, "n") <- 10 # network size +#' vertex_attributes <- list(a = 1:10, b = runif(10)) +#' nwL <- networkLite(edgelist, vertex_attributes) +#' nwL +#' +networkLite <- function(x, ...) { + UseMethod("networkLite") +} + +#' @rdname constructors +#' @export +networkLite.edgelist <- function( + x, + attr = list(vertex.names = seq_len(attributes(x)[["n"]]), + na = logical(attributes(x)[["n"]])), + ...) { + + nw <- list(el = x, + attr = as_tibble(attr), + gal = attributes(x)[setdiff(names(attributes(x)), + c("class", "dim", "dimnames", + "vnames", "mnext"))]) + + if (!is_tibble(x)) { + nw$el <- as_tibble(list(.tail = as.integer(x[, 1]), + .head = as.integer(x[, 2]))) + } + + nw$el[["na"]] <- NVL(nw$el[["na"]], logical(NROW(nw$el))) + nw$el[["na"]][is.na(nw$el[["na"]])] <- FALSE + + # network size attribute is required + if (is.null(nw$gal[["n"]])) { + stop("edgelist passed to networkLite must have the `n` attribute.") + } + # other common attributes default to FALSE + if (is.null(nw$gal[["directed"]])) { + nw$gal[["directed"]] <- FALSE + } + if (is.null(nw$gal[["bipartite"]])) { + nw$gal[["bipartite"]] <- FALSE + } + if (is.null(nw$gal[["loops"]])) { + nw$gal[["loops"]] <- FALSE + } + if (is.null(nw$gal[["hyper"]])) { + nw$gal[["hyper"]] <- FALSE + } + if (is.null(nw$gal[["multiple"]])) { + nw$gal[["multiple"]] <- FALSE + } + + if (!isFALSE(nw$gal[["loops"]]) || !isFALSE(nw$gal[["hyper"]]) || + !isFALSE(nw$gal[["multiple"]])) { + stop("networkLite requires network attributes `loops`, `hyper`, and", + " `multiple` be `FALSE`.") + } + + ## for consistency with network, + ## we want nw$gal[["n"]] to be of + ## type numeric, not integer + nw$gal[["n"]] <- as.numeric(nw$gal[["n"]]) + + class(nw) <- c("networkLite", "network") + return(nw) +} + +#' @rdname constructors +#' @export +networkLite.matrix <- networkLite.edgelist + +#' @rdname constructors +#' @export +networkLite.numeric <- function(x, + directed = FALSE, + bipartite = FALSE, + ...) { + x <- as.numeric(x) # so it's not of class integer + + el <- as_tibble(list(.tail = integer(0), .head = integer(0), na = logical(0))) + attr <- list(vertex.names = seq_len(x), na = logical(x)) + gal <- list(n = x, directed = directed, bipartite = bipartite, + loops = FALSE, hyper = FALSE, multiple = FALSE) + + nw <- list(el = el, attr = as_tibble(attr), gal = gal) + + class(nw) <- c("networkLite", "network") + return(nw) +} + +#' @rdname constructors +#' @export +networkLite_initialize <- networkLite.numeric diff --git a/R/matrix_conversions.R b/R/matrix_conversions.R new file mode 100644 index 0000000..1e1d937 --- /dev/null +++ b/R/matrix_conversions.R @@ -0,0 +1,138 @@ +#' @rdname matrix_conversions +#' @title Convert a \code{networkLite} to a Matrix or \code{tibble}. +#' @param x A \code{networkLite}. +#' @param attrname Name of an edge attribute in \code{x}. +#' @param attrnames Vector specifying edge attributes to include in the tibble; +#' may be logical, integer, or character vector, the former two being +#' used to select attribute names from \code{list.edge.attributes(x)}, +#' and the latter being used as the attribute names themselves +#' @param output Type of edgelist to output. +#' @param na.rm should missing edges be dropped from edgelist? +#' @param matrix.type type of matrix to return from +#' \code{as.matrix.networkLite} +#' @param ... additional arguments +#' @export +#' +as.edgelist.networkLite <- function(x, attrname = NULL, + output = c("matrix", "tibble"), + na.rm = TRUE, ...) { + output <- match.arg(output) + + if (output == "matrix") { + m <- matrix(c(x$el$.tail, x$el$.head), ncol = 2) + if (!is.null(attrname)) { + attrval <- get.edge.attribute(x, attrname, unlist = FALSE) + ## analogous to null.na = TRUE in network + attrval <- lapply(attrval, function(val) NVL(val, NA)) + m <- cbind(m, unlist(attrval)) + } + } else { + m <- x$el[c(".tail", ".head", attrname)] + } + + if (na.rm && NROW(m) > 0) { + na <- NVL(x %e% "na", FALSE) + m <- m[!na, , drop = FALSE] + } + + attr(m, "dimnames") <- NULL + + attr(m, "n") <- as.integer(network.size(x)) + attr(m, "vnames") <- network.vertex.names(x) + bip <- if (is.bipartite(x)) x %n% "bipartite" else FALSE + attr(m, "bipartite") <- if (is.numeric(bip)) as.integer(bip) else bip + attr(m, "directed") <- as.logical(is.directed(x)) + attr(m, "loops") <- as.logical(has.loops(x)) + class(m) <- c(if (output == "matrix") "matrix_edgelist" else "tibble_edgelist", + "edgelist", class(m)) + return(m) +} + + +#' @rdname matrix_conversions +#' @export +as_tibble.networkLite <- function(x, attrnames = NULL, na.rm = TRUE, ...) { + if (is.logical(attrnames) || is.numeric(attrnames)) + attrnames <- na.omit(list.edge.attributes(x)[attrnames]) + out <- x$el[, c(".tail", ".head", attrnames)] + if (na.rm && NROW(out) > 0) { + na <- NVL(x %e% "na", FALSE) + out <- out[!na, ] + } + attr(out, "n") <- network.size(x) + attr(out, "vnames") <- network.vertex.names(x) + if (is.bipartite(x)) attr(out, "bipartite") <- x %n% "bipartite" + out +} + +#' @rdname matrix_conversions +#' @export +as.matrix.networkLite <- function(x, + matrix.type = c("adjacency", + "incidence", "edgelist"), + attrname = NULL, ...) { + matrix.type <- match.arg(matrix.type) + switch(matrix.type, + adjacency = as.matrix.networkLite.adjacency(x, attrname, ...), + incidence = as.matrix.networkLite.incidence(x, attrname, ...), + edgelist = as.matrix.networkLite.edgelist(x, attrname, ...)) +} + +as.matrix.networkLite.adjacency <- function(x, attrname = NULL, ...) { + el <- as.edgelist(x, na.rm = FALSE) + + if (!is.null(attrname)) { + vals <- x %e% attrname + } else { + vals <- rep(1, network.edgecount(x, na.omit = FALSE)) + } + vals[NVL(x %e% "na", FALSE)] <- NA + + n <- network.size(x) + + m <- matrix(0, nrow = n, ncol = n) + m[el] <- vals + if (!is.directed(x)) { + m[el[, c(2, 1)]] <- vals + } + dimnames(m) <- rep(list(network.vertex.names(x)), 2) + + if (is.bipartite(x)) { + bip <- x %n% "bipartite" + m[seq_len(bip), -seq_len(bip)] + } else { + m + } +} + +as.matrix.networkLite.incidence <- function(x, attrname = NULL, ...) { + el <- as.edgelist(x, na.rm = FALSE) + + vals <- NVL2(attrname, x %e% attrname, + rep(1, network.edgecount(x, na.omit = FALSE))) + vals[NVL(x %e% "na", FALSE)] <- NA + + m <- matrix(0, nrow = network.size(x), + ncol = network.edgecount(x, na.omit = FALSE)) + + m[cbind(el[, 1], seq_len(NROW(el)))] <- if (is.directed(x)) -vals else vals + m[cbind(el[, 2], seq_len(NROW(el)))] <- vals + + m +} + +as.matrix.networkLite.edgelist <- function(x, attrname = NULL, + na.rm = TRUE, ...) { + + m <- matrix(c(x$el$.tail, x$el$.head), ncol = 2) + if (!is.null(attrname)) { + m <- cbind(m, get.edge.attribute(x, attrname)) + } + if (na.rm == TRUE) { + m <- m[!NVL(x %e% "na", FALSE), , drop = FALSE] + } + attr(m, "n") <- network.size(x) + attr(m, "vnames") <- network.vertex.names(x) + if (is.bipartite(x)) attr(m, "bipartite") <- x %n% "bipartite" + m +} diff --git a/R/misc.R b/R/misc.R new file mode 100644 index 0000000..4f57f46 --- /dev/null +++ b/R/misc.R @@ -0,0 +1,116 @@ + +#' @rdname edgecount +#' @title Count Edges in a \code{networkLite} +#' @param x A \code{networkLite} object. +#' @param na.omit logical; omit missing edges from edge count? +#' @param ... additional arguments +#' @details The \code{network.edgecount} method provides a count of the number +#' of edges in the \code{networkLite}, including missing edges if +#' \code{na.omit = FALSE} and omitting them if \code{na.omit = TRUE}. +#' The \code{network.naedgecount} method provides a count of the +#' number of missing edges in the \code{networkLite}. +#' @export +#' +network.edgecount.networkLite <- function(x, na.omit = TRUE, ...) { + if (na.omit == TRUE) { + NROW(x$el) - network.naedgecount(x) + } else { + NROW(x$el) + } +} + +#' @rdname edgecount +#' @export +network.naedgecount.networkLite <- function(x, ...) { + sum(x %e% "na") +} + +#' @rdname print +#' @title Print Basic Summary of a \code{networkLite} +#' @param x A \code{networkLite} object. +#' @param ... additional arguments +#' @details This method prints a basic summary of a \code{networkLite} object, +#' including network size, edge count, and attribute names. +#' @export +print.networkLite <- function(x, ...) { + cat("networkLite with properties:\n") + cat(" Network size:", network.size(x), "\n") + cat(" Edge count:", network.edgecount(x, na.omit = FALSE), "\n") + cat(" Non-missing edge count:", network.edgecount(x, na.omit = TRUE), "\n") + cat(" Missing edge count:", network.naedgecount(x), "\n") + cat(" Network attributes:", list.network.attributes(x), "\n") + cat(" Vertex attributes:", list.vertex.attributes(x), "\n") + cat(" Edge attributes:", list.edge.attributes(x), "\n") + invisible(x) +} + +#' @rdname is.na +#' @title Extract \code{networkLite} with Missing Edges Only +#' @param x A \code{networkLite}. +#' @details The \code{is.na} method creates a \code{networkLite} whose edges +#' are precisely those edges in \code{x} that are missing. The edges +#' in the return value are marked as not missing. +#' @export +is.na.networkLite <- function(x) { + y <- networkLite(network.size(x), + directed = x %n% "directed", + bipartite = x %n% "bipartite") + el <- as.edgelist(x, na.rm = FALSE) + elna <- el[NVL(x %e% "na", FALSE), , drop = FALSE] + add.edges(y, elna[, 1], elna[, 2]) + y +} + +#' @rdname operators +#' @title Add and Subtract \code{networkLite}s +#' @param e1,e2 \code{networkLite} objects +#' @details \code{e1 + e2} produces a \code{networkLite} whose edges are those +#' in either \code{e1} or \code{e2}, and \code{e1 - e2} produces a +#' \code{networkLite} whose edges are those in \code{e1} and not in +#' \code{e2}. +#' @export +`+.networkLite` <- function(e1, e2) { + if (!identical(e1 %n% "n", e2 %n% "n") || + !identical(e1 %n% "directed", e2 %n% "directed") || + !identical(e1 %n% "bipartite", e2 %n% "bipartite")) { + stop("cannot add networkLites of differing network size, directedness, or", + " bipartiteness") + } + + if (any(NVL(e1 %e% "na", FALSE)) || any(NVL(e2 %e% "na", FALSE))) { + stop("adding networkLites with missing edges is not currently supported") + } + + out <- e1 + if (network.edgecount(e2, na.omit = FALSE) > 0) { + edgelist <- dplyr::bind_rows(e1$el, e2$el) + edgelist <- edgelist[!duplicated(edgelist[, c(".tail", ".head")]), ] + out$el <- edgelist[order(edgelist$.tail, edgelist$.head), ] + } + out +} + +#' @rdname operators +#' @export +`-.networkLite` <- function(e1, e2) { + if (!identical(e1 %n% "n", e2 %n% "n") || + !identical(e1 %n% "directed", e2 %n% "directed") || + !identical(e1 %n% "bipartite", e2 %n% "bipartite")) { + stop("cannot subtract networkLites of differing network size,", + " directedness, or bipartiteness") + } + + if (any(NVL(e1 %e% "na", FALSE)) || any(NVL(e2 %e% "na", FALSE))) { + stop("subtracting networkLites with missing edges is not currently", + " supported") + } + + out <- e1 + if (network.edgecount(e2, na.omit = FALSE) > 0) { + edgelist <- dplyr::bind_rows(e2$el, e1$el) + nd <- !duplicated(edgelist[, c(".tail", ".head")]) + out$el <- out$el[nd[-seq_len(network.edgecount(e2, na.omit = FALSE))], ] + out$el <- out$el[order(out$el$.tail, out$el$.head), ] + } + out +} diff --git a/R/mixingmatrix.R b/R/mixingmatrix.R new file mode 100644 index 0000000..36c9c53 --- /dev/null +++ b/R/mixingmatrix.R @@ -0,0 +1,31 @@ +#' @rdname mixingmatrix +#' @title Extract Mixing Matrix from \code{networkLite} +#' @param object A \code{networkLite} object. +#' @param attr The name of a vertex attribute in \code{object}. +#' @param ... additional arguments +#' @return The mixing matrix for \code{object} and \code{attr}. +#' @export +mixingmatrix.networkLite <- function(object, attr, ...) { + nw <- object + + all_attr <- get.vertex.attribute(nw, attr) + + if (is.bipartite(nw)) { + row_levels <- sort(unique(all_attr[seq_len(nw %n% "bipartite")])) + col_levels <- sort(unique(all_attr[-seq_len(nw %n% "bipartite")])) + } else { + row_levels <- sort(unique(all_attr)) + col_levels <- row_levels + } + + el <- as.edgelist(nw) + + m <- table(from = factor(all_attr[el[, 1]], levels = row_levels), + to = factor(all_attr[el[, 2]], levels = col_levels)) + + if (!is.bipartite(nw) && !is.directed(nw)) { + m <- m + t(m) - diag(diag(m)) + } + + m +} diff --git a/R/networkLite.R b/R/networkLite.R deleted file mode 100644 index f361ef2..0000000 --- a/R/networkLite.R +++ /dev/null @@ -1,933 +0,0 @@ - -#' @import network -#' @importFrom statnet.common NVL NVL2 -#' @importFrom tibble tibble as_tibble is_tibble -#' @importFrom dplyr bind_rows bind_cols -#' @importFrom stats na.omit - -#' @title networkLite Constructor Utilities -#' -#' @description Constructor methods for \code{networkLite} objects. -#' -#' @param x Either an \code{edgelist} class network representation (including -#' network attributes in its \code{attributes} list), or a number -#' specifying the network size. -#' @param attr A named list of vertex attributes for the network represented by -#' \code{x}. -#' @param directed,bipartite Common network attributes that may be set via -#' arguments to the \code{networkLite.numeric} method. -#' @param ... Additional arguments used by other methods. -#' -#' @details Currently there are several distinct \code{networkLite} constructor -#' methods available. -#' -#' The \code{edgelist} method takes an \code{edgelist} class object \code{x} -#' with network attributes attached in its \code{attributes} list, and a named -#' list of vertex attributes \code{attr}, and returns a \code{networkLite} -#' object, which is a named list with fields \code{el}, \code{attr}, and -#' \code{gal}; the fields \code{el} and \code{attr} match the arguments \code{x} -#' and \code{attr} (the latter coerced to \code{tibble}) respectively, and the -#' field \code{gal} is the list of network attributes (copied from -#' \code{attributes(x)}). Missing network attributes \code{directed} and -#' \code{bipartite} are defaulted to \code{FALSE}; the network size attribute -#' \code{n} must not be missing. Attributes \code{class}, \code{dim}, -#' \code{dimnames}, \code{vnames}, and \code{mnext} (if present) are not copied -#' from \code{x} to the \code{networkLite}. (For convenience, a \code{matrix} -#' method, identical to the \code{edgelist} method, is also defined, to handle -#' cases where the edgelist is, for whatever reason, not classed as an -#' \code{edgelist}.) -#' -#' The \code{numeric} method takes a number \code{x} as well as the network -#' attributes \code{directed} and \code{bipartite} (defaulting to \code{FALSE}), -#' and returns an empty \code{networkLite} with these network attributes and -#' number of nodes \code{x}. -#' -#' The constructor \code{networkLite_initialize} is also available for creating -#' an empty \code{networkLite}, and its \code{x} argument should be a number -#' indicating the size of the \code{networkLite} to create. -#' -#' Within \code{tergmLite}, the \code{networkLite} data structure is used in the -#' calls to \code{ergm} and \code{tergm} \code{simulate} functions. -#' -#' @return -#' A networkLite object with edge list \code{el}, vertex attributes \code{attr}, -#' and network attributes \code{gal}. -#' -#' @rdname networkLite -#' @export -#' -#' @examples -#' edgelist <- cbind(c(1,2,3), c(2,4,7)) -#' attr(edgelist, "n") <- 10 # network size -#' vertex_attributes <- list(a = 1:10, b = runif(10)) -#' nwL <- networkLite(edgelist, vertex_attributes) -#' nwL -#' -networkLite <- function(x, ...) { - UseMethod("networkLite") -} - -#' @rdname networkLite -#' @export -networkLite.edgelist <- function( - x, - attr = list(vertex.names = seq_len(attributes(x)[["n"]]), - na = logical(attributes(x)[["n"]])), - ...) { - - nw <- list(el = x, - attr = as_tibble(attr), - gal = attributes(x)[setdiff(names(attributes(x)), - c("class", "dim", "dimnames", - "vnames", "mnext"))]) - - if (!is_tibble(x)) { - nw$el <- as_tibble(list(.tail = as.integer(x[, 1]), - .head = as.integer(x[, 2]))) - } - - nw$el[["na"]] <- NVL(nw$el[["na"]], logical(NROW(nw$el))) - nw$el[["na"]][is.na(nw$el[["na"]])] <- FALSE - - # network size attribute is required - if (is.null(nw$gal[["n"]])) { - stop("edgelist passed to networkLite must have the `n` attribute.") - } - # other common attributes default to FALSE - if (is.null(nw$gal[["directed"]])) { - nw$gal[["directed"]] <- FALSE - } - if (is.null(nw$gal[["bipartite"]])) { - nw$gal[["bipartite"]] <- FALSE - } - if (is.null(nw$gal[["loops"]])) { - nw$gal[["loops"]] <- FALSE - } - if (is.null(nw$gal[["hyper"]])) { - nw$gal[["hyper"]] <- FALSE - } - if (is.null(nw$gal[["multiple"]])) { - nw$gal[["multiple"]] <- FALSE - } - - if (!isFALSE(nw$gal[["loops"]]) || !isFALSE(nw$gal[["hyper"]]) || - !isFALSE(nw$gal[["multiple"]])) { - stop("networkLite requires network attributes `loops`, `hyper`, and", - " `multiple` be `FALSE`.") - } - - ## for consistency with network, - ## we want nw$gal[["n"]] to be of - ## type numeric, not integer - nw$gal[["n"]] <- as.numeric(nw$gal[["n"]]) - - class(nw) <- c("networkLite", "network") - return(nw) -} - -#' @rdname networkLite -#' @export -networkLite.matrix <- networkLite.edgelist - -#' @rdname networkLite -#' @export -networkLite.numeric <- function(x, - directed = FALSE, - bipartite = FALSE, - ...) { - x <- as.numeric(x) # so it's not of class integer - - el <- as_tibble(list(.tail = integer(0), .head = integer(0), na = logical(0))) - attr <- list(vertex.names = seq_len(x), na = logical(x)) - gal <- list(n = x, directed = directed, bipartite = bipartite, - loops = FALSE, hyper = FALSE, multiple = FALSE) - - nw <- list(el = el, attr = as_tibble(attr), gal = gal) - - class(nw) <- c("networkLite", "network") - return(nw) -} - -#' @rdname networkLite -#' @export -networkLite_initialize <- networkLite.numeric - -#' @name networkLitemethods -#' @title networkLite Methods -#' -#' @description S3 methods for networkLite class, for generics defined in -#' network package. -#' -#' @param x A \code{networkLite} object. -#' @param attrname The name of an attribute in \code{x}. -#' @param value The attribute value to set in vertex, edge, and network -#' attribute setters; the value to set edges to (must be FALSE) -#' for the \code{networkLite} replacement method. -#' @param unlist logical; in \code{get.vertex.attribute} and -#' \code{get.edge.attribute}, if \code{unlist} is \code{TRUE}, call -#' \code{unlist} on the attribute value before returning it, and if -#' \code{unlist} is \code{FALSE}, call \code{as.list} on the attribute -#' value before returning it; in \code{get.network.attribute}, if -#' \code{unlist} is \code{TRUE}, call \code{unlist} on the attribute -#' value before returning it, and if \code{unlist} is \code{FALSE}, -#' return the attribute value without any modification -#' @param ... Any additional arguments. -#' -#' @details Allows use of networkLite objects in \code{ergm_model}. -#' -#' @return Behavior and return values are analogous to those of the -#' corresponding \code{network} methods, with network data structured -#' in the \code{networkLite} format. -#' -#' @rdname networkLitemethods -#' @export -#' -get.vertex.attribute.networkLite <- function(x, attrname, ..., unlist = TRUE) { - if (attrname %in% list.vertex.attributes(x)) { - out <- x$attr[[attrname]] - } else { - out <- rep(NA, length.out = network.size(x)) - } - - if (unlist == TRUE) { - out <- unlist(out) - } else { - out <- as.list(out) - } - - return(out) -} - -#' @rdname networkLitemethods -#' @param v Indices at which to set vertex attribute values. -#' @export -#' -set.vertex.attribute.networkLite <- function(x, - attrname, - value, - v = seq_len(network.size(x)), - ...) { - xn <- substitute(x) - - if (!(attrname %in% list.vertex.attributes(x))) { - x$attr[[attrname]] <- rep(NA, length.out = network.size(x)) - } - - x$attr[[attrname]][v] <- value - - on.exit(eval.parent(call("<-", xn, x))) - invisible(x) -} - -#' @rdname networkLitemethods -#' @export -#' -list.vertex.attributes.networkLite <- function(x, ...) { - sort(unique(names(x$attr))) -} - -#' @rdname networkLitemethods -#' @export -#' -get.network.attribute.networkLite <- function(x, attrname, ..., unlist = FALSE) { - out <- x$gal[[attrname]] - - if (unlist == TRUE) { - out <- unlist(out) - } - - return(out) -} - -#' @rdname networkLitemethods -#' @export -#' -set.network.attribute.networkLite <- function(x, attrname, value, ...) { - xn <- substitute(x) - - x$gal[[attrname]] <- value - - on.exit(eval.parent(call("<-", xn, x))) - invisible(x) -} - -#' @rdname networkLitemethods -#' @export -#' -list.network.attributes.networkLite <- function(x, ...) { - sort(unique(names(x$gal))) -} - -#' @rdname networkLitemethods -#' @export -#' -get.edge.attribute.networkLite <- function(x, attrname, ..., unlist = TRUE) { - out <- x$el[[attrname]] - - if (unlist == TRUE) { - out <- unlist(out) - } else { - out <- as.list(out) - } - - return(out) -} - -#' @rdname networkLitemethods -#' @export -#' -get.edge.value.networkLite <- get.edge.attribute.networkLite - -#' @rdname networkLitemethods -#' @param e edge indices to assign value -#' @export -#' -set.edge.attribute.networkLite <- function( - x, attrname, value, - e = seq_len(network.edgecount(x, na.omit = FALSE)), ...) { - - xn <- substitute(x) - - if (!(attrname %in% list.edge.attributes(x))) { - x$el[[attrname]] <- rep(NA, - length.out = network.edgecount(x, na.omit = FALSE)) - } - - x$el[[attrname]][e] <- value - - on.exit(eval.parent(call("<-", xn, x))) - invisible(x) -} - -#' @rdname networkLitemethods -#' @export -#' -set.edge.value.networkLite <- function( - x, attrname, value, - e = seq_len(network.edgecount(x, na.omit = FALSE)), ...) { - - xn <- substitute(x) - - if (!(attrname %in% list.edge.attributes(x))) { - x$el[[attrname]] <- rep(NA, - length.out = network.edgecount(x, na.omit = FALSE)) - } - - x$el[[attrname]][e] <- value[as.matrix(x$el[e, c(".tail", ".head")])] - - on.exit(eval.parent(call("<-", xn, x))) - invisible(x) -} - -#' @rdname networkLitemethods -#' @export -#' -list.edge.attributes.networkLite <- function(x, ...) { - sort(unique(colnames(x$el)[-c(1, 2)])) -} - - -#' @rdname networkLitemethods -#' @param na.omit logical; omit missing edges from edge count? -#' @export -#' -network.edgecount.networkLite <- function(x, na.omit = TRUE, ...) { - if (na.omit == TRUE) { - NROW(x$el) - network.naedgecount(x) - } else { - NROW(x$el) - } -} - -#' @rdname networkLitemethods -#' @param output Type of edgelist to output. -#' @param na.rm should missing edges be dropped from edgelist? -#' @export -#' -as.edgelist.networkLite <- function(x, attrname = NULL, - output = c("matrix", "tibble"), - na.rm = TRUE, ...) { - output <- match.arg(output) - - if (output == "matrix") { - m <- matrix(c(x$el$.tail, x$el$.head), ncol = 2) - if (!is.null(attrname)) { - attrval <- get.edge.attribute(x, attrname, unlist = FALSE) - ## analogous to null.na = TRUE in network - attrval <- lapply(attrval, function(val) NVL(val, NA)) - m <- cbind(m, unlist(attrval)) - } - } else { - m <- x$el[c(".tail", ".head", attrname)] - } - - if (na.rm && NROW(m) > 0) { - na <- NVL(x %e% "na", FALSE) - m <- m[!na, , drop = FALSE] - } - - attr(m, "dimnames") <- NULL - - attr(m, "n") <- as.integer(network.size(x)) - attr(m, "vnames") <- network.vertex.names(x) - bip <- if (is.bipartite(x)) x %n% "bipartite" else FALSE - attr(m, "bipartite") <- if (is.numeric(bip)) as.integer(bip) else bip - attr(m, "directed") <- as.logical(is.directed(x)) - attr(m, "loops") <- as.logical(has.loops(x)) - class(m) <- c(if (output == "matrix") "matrix_edgelist" else "tibble_edgelist", - "edgelist", class(m)) - return(m) -} - -#' @rdname networkLitemethods -#' @param object A \code{networkLite} object. -#' @param attr The name of a vertex attribute in \code{object}. -#' @export -mixingmatrix.networkLite <- function(object, attr, ...) { - nw <- object - - all_attr <- get.vertex.attribute(nw, attr) - - if (is.bipartite(nw)) { - row_levels <- sort(unique(all_attr[seq_len(nw %n% "bipartite")])) - col_levels <- sort(unique(all_attr[-seq_len(nw %n% "bipartite")])) - } else { - row_levels <- sort(unique(all_attr)) - col_levels <- row_levels - } - - el <- as.edgelist(nw) - - m <- table(from = factor(all_attr[el[, 1]], levels = row_levels), - to = factor(all_attr[el[, 2]], levels = col_levels)) - - if (!is.bipartite(nw) && !is.directed(nw)) { - m <- m + t(m) - diag(diag(m)) - } - - m -} - -#' @rdname networkLitemethods -#' @param i,j Nodal indices (must be missing for networkLite method). -#' @param add.edges should edges being assigned to be added if not already -#' present? -#' @export -"[<-.networkLite" <- function(x, i, j, names.eval = NULL, - add.edges = FALSE, value) { - if (!missing(i) || !missing(j)) { - stop("`[<-.networkLite` does not support `i` and `j` arguments at this", - " time") - } - - if (any(is.na(value))) { - stop("`[<-.networkLite` does not support NA `value` arguments at this", - " time") - } - - if (is.null(names.eval) && isTRUE(all(value == FALSE))) { - x$el <- as_tibble(list(.tail = integer(0), - .head = integer(0), - na = logical(0))) - return(x) - } - - b1 <- if (is.bipartite(x)) x %n% "bipartite" else - network.size(x) - b2 <- if (is.bipartite(x)) network.size(x) - x %n% "bipartite" else - network.size(x) - - if (!is.matrix(value)) { - value <- matrix(value, nrow = b1, ncol = b2) - } else { - if (nrow(value) < b1 || ncol(value) < b2) { - stop("too small a matrix `value` passed to `[<-.networkLite`") - } - value <- value[seq_len(b1), seq_len(b2), drop = FALSE] - } - - if (is.null(names.eval)) { - # add edges whether or not add.edges is TRUE, - # for consistency with `network` behavior - w <- which(value != 0, arr.ind = TRUE) - if (is.bipartite(x)) { - w[, 2] <- w[, 2] + b1 - } - if (!is.directed(x)) { - w <- w[w[, 1] < w[, 2], , drop = FALSE] - } else { - w <- w[w[, 1] != w[, 2], , drop = FALSE] - } - w <- w[order(w[, 1], w[, 2]), , drop = FALSE] - x$el <- as_tibble(list(.tail = w[, 1], - .head = w[, 2], - na = logical(NROW(w)))) - } else { - if (!add.edges) { - el <- as.edgelist(x, na.rm = FALSE) - if (is.bipartite(x)) { - el[, 2] <- el[, 2] - b1 - } - if (names.eval == "na") { - value[is.na(value)] <- FALSE - } - set.edge.attribute(x, names.eval, value[el]) - } else { - w <- which(value != 0, arr.ind = TRUE) - vals <- value[w] - if (is.bipartite(x)) { - w[, 2] <- w[, 2] + b1 - } - if (!is.directed(x)) { - vals <- vals[w[, 1] < w[, 2]] - w <- w[w[, 1] < w[, 2], , drop = FALSE] - } else { - vals <- vals[w[, 1] != w[, 2]] - w <- w[w[, 1] != w[, 2], , drop = FALSE] - } - vals <- vals[order(w[, 1], w[, 2])] - w <- w[order(w[, 1], w[, 2]), , drop = FALSE] - if (names.eval == "na") { - vals[is.na(vals)] <- FALSE - tbl_list <- list(w[, 1], w[, 2], vals) - names(tbl_list) <- c(".tail", - ".head", - names.eval) - } else { - tbl_list <- list(w[, 1], w[, 2], vals, logical(NROW(w))) - names(tbl_list) <- c(".tail", ".head", names.eval, "na") - } - x$el <- as_tibble(tbl_list) - } - } - return(x) -} - -#' @rdname networkLitemethods -#' @export -print.networkLite <- function(x, ...) { - cat("networkLite with properties:\n") - cat(" Network size:", network.size(x), "\n") - cat(" Edge count:", network.edgecount(x, na.omit = FALSE), "\n") - cat(" Non-missing edge count:", network.edgecount(x, na.omit = TRUE), "\n") - cat(" Missing edge count:", network.naedgecount(x), "\n") - cat(" Network attributes:", list.network.attributes(x), "\n") - cat(" Vertex attributes:", list.vertex.attributes(x), "\n") - cat(" Edge attributes:", list.edge.attributes(x), "\n") - invisible(x) -} - -#' @rdname networkLitemethods -#' @export -network.naedgecount.networkLite <- function(x, ...) { - sum(x %e% "na") -} - -#' @rdname networkLitemethods -#' @param tail Vector of tails of edges to add to the networkLite. -#' @param head Vector of heads of edges to add to the networkLite. -#' @param names.eval name(s) of edge attributes -#' @param vals.eval value(s) of edge attributes -#' @export -add.edges.networkLite <- function(x, tail, head, names.eval = NULL, - vals.eval = NULL, ...) { - tail <- NVL(unlist(tail), integer(0)) - head <- NVL(unlist(head), integer(0)) - if (length(names.eval) == 0 || length(vals.eval) == 0) { - update_tibble <- as_tibble(list(.tail = tail, .head = head, - na = logical(length(tail)))) - } else { - if (!is.list(names.eval)) names.eval <- - as.list(rep(names.eval, length.out = length(tail))) - if (!is.list(vals.eval)) vals.eval <- - as.list(rep(vals.eval, length.out = length(names.eval))) - - for (i in seq_along(vals.eval)) { - vals.eval[[i]] <- as.list(vals.eval[[i]]) - names(vals.eval[[i]]) <- unlist(names.eval[[i]]) - } - - f <- function(x) if (length(x) > 0) as_tibble(x) else tibble(NULL, .rows = 1) - update_tibble <- - dplyr::bind_cols(as_tibble(list(.tail = tail, .head = head)), - dplyr::bind_rows(lapply(vals.eval, f))) - } - - update_tibble[["na"]] <- NVL(update_tibble[["na"]], - logical(NROW(update_tibble))) - update_tibble[["na"]][is.na(update_tibble[["na"]])] <- FALSE - - xn <- substitute(x) - - x$el <- dplyr::bind_rows(x$el, update_tibble) - x$el <- x$el[order(x$el$.tail, x$el$.head), ] - x$el <- x$el[!duplicated(x$el[, c(".tail", ".head")]), ] - - on.exit(eval.parent(call("<-", xn, x))) - invisible(x) -} - -#' @rdname networkLitemethods -#' @export -as.network.networkLite <- function(x, ...) { - return(x) -} - -#' @rdname as.networkLite -#' @title as.networkLite -#' @description Convert to \code{networkLite} representation. -#' @details Currently the network attributes \code{hyper}, \code{multiple}, and -#' \code{loops} must be \code{FALSE} for \code{networkLite}s; -#' attempting to convert to \code{networkLite} when this is not the -#' case will result in an error. -#' @param x a \code{network} or \code{networkLite} object -#' @param ... additional arguments -#' @return a corresponding \code{networkLite} object -#' @seealso \code{\link{to_network_networkLite}} -#' @export -as.networkLite <- function(x, ...) { - UseMethod("as.networkLite") -} - -#' @rdname as.networkLite -#' @export -as.networkLite.network <- function(x, ...) { - if (is.hyper(x) || is.multiplex(x) || has.loops(x)) { - stop("cannot coerce `network` to `networkLite` unless `hyper`,", - " `multiple`, and `loops` are all `FALSE`") - } - - el <- as.edgelist(x, na.rm = FALSE) - - rv <- networkLite(el) - - for (name in list.vertex.attributes(x)) { - set.vertex.attribute(rv, name, get.vertex.attribute(x, - name, - null.na = TRUE, - unlist = FALSE)) - } - - for (name in setdiff(list.network.attributes(x), c("mnext"))) { - set.network.attribute(rv, name, get.network.attribute(x, name)) - } - - eids <- unlist(get.dyads.eids(x, el[, 1], el[, 2])) - for (name in list.edge.attributes(x)) { - set.edge.attribute(rv, name, get.edge.attribute(x, name, null.na = TRUE, - deleted.edges.omit = FALSE, - unlist = FALSE)[eids]) - } - - for (name in setdiff(names(attributes(x)), c("class", "names"))) { - attr(rv, name) <- attr(x, name) - } - - rv <- atomize(rv) - - rv -} - -## convert vertex and edge attributes to atomic vectors where possible; -## note that this may upcast atomic types, e.g. logical -> numeric -> character -atomize <- function(nwL) { - for (name in list.vertex.attributes(nwL)) { - value <- get.vertex.attribute(nwL, name, unlist = FALSE) - if (length(value) > 0 && - all(unlist(lapply(value, is.atomic))) && - all(unlist(lapply(value, length)) == 1)) { - nwL$attr[[name]] <- unlist(value) - } - } - - for (name in list.edge.attributes(nwL)) { - value <- get.edge.attribute(nwL, name, unlist = FALSE) - if (length(value) > 0 && - all(unlist(lapply(value, is.atomic))) && - all(unlist(lapply(value, length)) == 1)) { - nwL$el[[name]] <- unlist(value) - } - } - - nwL -} - -#' @rdname as.networkLite -#' @export -as.networkLite.networkLite <- function(x, ...) { - x -} - -#' @rdname to_network_networkLite -#' @title Convert a \code{networkLite} object to a \code{network} object -#' @param x a \code{networkLite} object -#' @param ... additional arguments -#' @return a corresponding \code{network} object -#' @seealso \code{\link{as.networkLite}} -#' @export -to_network_networkLite <- function(x, ...) { - nw <- network.initialize(network.size(x), - directed = x %n% "directed", - bipartite = x %n% "bipartite") - - el <- as.edgelist(x, na.rm = FALSE) - - nw <- add.edges(nw, el[, 1], el[, 2]) - - for (name in list.vertex.attributes(x)) { - set.vertex.attribute(nw, name, get.vertex.attribute(x, name, unlist = FALSE)) - } - - for (name in list.network.attributes(x)) { - set.network.attribute(nw, name, get.network.attribute(x, name)) - } - - eids <- unlist(get.dyads.eids(nw, el[, 1], el[, 2])) - for (name in list.edge.attributes(x)) { - set.edge.attribute(nw, name, get.edge.attribute(x, name, unlist = FALSE), eids) - } - - for (name in setdiff(names(attributes(x)), c("class", "names"))) { - attr(nw, name) <- attr(x, name) - } - - nw -} - -#' @rdname networkLitemethods -#' @param attrnames vector specifying edge attributes to include in the tibble; -#' may be logical, integer, or character vector, the former two being -#' used to select attribute names from \code{list.edge.attributes(x)}, -#' and the latter being used as the attribute names themselves -#' @export -as_tibble.networkLite <- function(x, attrnames = NULL, na.rm = TRUE, ...) { - if (is.logical(attrnames) || is.numeric(attrnames)) - attrnames <- na.omit(list.edge.attributes(x)[attrnames]) - out <- x$el[, c(".tail", ".head", attrnames)] - if (na.rm && NROW(out) > 0) { - na <- NVL(x %e% "na", FALSE) - out <- out[!na, ] - } - attr(out, "n") <- network.size(x) - attr(out, "vnames") <- network.vertex.names(x) - if (is.bipartite(x)) attr(out, "bipartite") <- x %n% "bipartite" - out -} - -#' @rdname networkLitemethods -#' @param matrix.type type of matrix to return from -#' \code{as.matrix.networkLite} -#' @export -as.matrix.networkLite <- function(x, - matrix.type = c("adjacency", - "incidence", "edgelist"), - attrname = NULL, ...) { - matrix.type <- match.arg(matrix.type) - switch(matrix.type, - adjacency = as.matrix.networkLite.adjacency(x, attrname, ...), - incidence = as.matrix.networkLite.incidence(x, attrname, ...), - edgelist = as.matrix.networkLite.edgelist(x, attrname, ...)) -} - -as.matrix.networkLite.adjacency <- function(x, attrname = NULL, ...) { - el <- as.edgelist(x, na.rm = FALSE) - - if (!is.null(attrname)) { - vals <- x %e% attrname - } else { - vals <- rep(1, network.edgecount(x, na.omit = FALSE)) - } - vals[NVL(x %e% "na", FALSE)] <- NA - - n <- network.size(x) - - m <- matrix(0, nrow = n, ncol = n) - m[el] <- vals - if (!is.directed(x)) { - m[el[, c(2, 1)]] <- vals - } - dimnames(m) <- rep(list(network.vertex.names(x)), 2) - - if (is.bipartite(x)) { - bip <- x %n% "bipartite" - m[seq_len(bip), -seq_len(bip)] - } else { - m - } -} - -as.matrix.networkLite.incidence <- function(x, attrname = NULL, ...) { - el <- as.edgelist(x, na.rm = FALSE) - - vals <- NVL2(attrname, x %e% attrname, - rep(1, network.edgecount(x, na.omit = FALSE))) - vals[NVL(x %e% "na", FALSE)] <- NA - - m <- matrix(0, nrow = network.size(x), - ncol = network.edgecount(x, na.omit = FALSE)) - - m[cbind(el[, 1], seq_len(NROW(el)))] <- if (is.directed(x)) -vals else vals - m[cbind(el[, 2], seq_len(NROW(el)))] <- vals - - m -} - -as.matrix.networkLite.edgelist <- function(x, attrname = NULL, - na.rm = TRUE, ...) { - - m <- matrix(c(x$el$.tail, x$el$.head), ncol = 2) - if (!is.null(attrname)) { - m <- cbind(m, get.edge.attribute(x, attrname)) - } - if (na.rm == TRUE) { - m <- m[!NVL(x %e% "na", FALSE), , drop = FALSE] - } - attr(m, "n") <- network.size(x) - attr(m, "vnames") <- network.vertex.names(x) - if (is.bipartite(x)) attr(m, "bipartite") <- x %n% "bipartite" - m -} - -#' @rdname networkLitemethods -#' @export -is.na.networkLite <- function(x) { - y <- networkLite(network.size(x), - directed = x %n% "directed", - bipartite = x %n% "bipartite") - el <- as.edgelist(x, na.rm = FALSE) - elna <- el[NVL(x %e% "na", FALSE), , drop = FALSE] - add.edges(y, elna[, 1], elna[, 2]) - y -} - -#' @rdname networkLitemethods -#' @export -delete.vertex.attribute.networkLite <- function(x, attrname, ...) { - xn <- substitute(x) - - x$attr[[attrname]] <- NULL - - on.exit(eval.parent(call("<-", xn, x))) - invisible(x) -} - -#' @rdname networkLitemethods -#' @export -delete.edge.attribute.networkLite <- function(x, attrname, ...) { - xn <- substitute(x) - - x$el[[attrname]] <- NULL - - on.exit(eval.parent(call("<-", xn, x))) - invisible(x) -} - -#' @rdname networkLitemethods -#' @export -delete.network.attribute.networkLite <- function(x, attrname, ...) { - xn <- substitute(x) - - x$gal[[attrname]] <- NULL - - on.exit(eval.parent(call("<-", xn, x))) - invisible(x) -} - -#' @rdname networkLitemethods -#' @param nv number of vertices to add to the \code{networkLite} -#' @param vattr list (of length \code{nv}) of named lists of vertex attributes -#' for added vertices, or \code{NULL} to indicate vertex attributes are -#' not being passed -#' @param last.mode logical; if \code{x} is bipartite, should the new vertices -#' be added to the second mode? -#' @export -add.vertices.networkLite <- function(x, nv, vattr = NULL, - last.mode = TRUE, ...) { - xn <- substitute(x) - - nv <- as.integer(nv) - if (nv > 0) { - oldsize <- network.size(x) - x %n% "n" <- oldsize + nv - - if (is.bipartite(x) && !last.mode) { - offset <- x %n% "bipartite" - x %n% "bipartite" <- x %n% "bipartite" + nv - x$el$.head <- x$el$.head + nv - } else { - offset <- oldsize - } - - if (!is.null(vattr)) { - if (is.list(vattr)) { - vattr <- rep(vattr, length.out = nv) - } else { - vattr <- as.list(rep(vattr, length.out = nv)) - } - - f <- function(x) if (length(x) > 0) as_tibble(x) else tibble(NULL, .rows = 1) - update_tibble <- dplyr::bind_rows(lapply(vattr, f)) - } else { - update_tibble <- as_tibble(list(na = logical(nv))) - } - update_tibble[["na"]] <- NVL(update_tibble[["na"]], - logical(NROW(update_tibble))) - update_tibble[["na"]][is.na(update_tibble[["na"]])] <- FALSE - - x$attr <- dplyr::bind_rows(x$attr[seq_len(offset), ], - update_tibble, - x$attr[offset + seq_len(oldsize - offset), ]) - } - - on.exit(eval.parent(call("<-", xn, x))) - invisible(x) -} - -#' @rdname networkLitemethods -#' @param e1,e2 networkLite objects -#' @export -`+.networkLite` <- function(e1, e2) { - if (!identical(e1 %n% "n", e2 %n% "n") || - !identical(e1 %n% "directed", e2 %n% "directed") || - !identical(e1 %n% "bipartite", e2 %n% "bipartite")) { - stop("cannot add networkLites of differing network size, directedness, or", - " bipartiteness") - } - - if (any(NVL(e1 %e% "na", FALSE)) || any(NVL(e2 %e% "na", FALSE))) { - stop("adding networkLites with missing edges is not currently supported") - } - - out <- e1 - if (network.edgecount(e2, na.omit = FALSE) > 0) { - edgelist <- dplyr::bind_rows(e1$el, e2$el) - edgelist <- edgelist[!duplicated(edgelist[, c(".tail", ".head")]), ] - out$el <- edgelist[order(edgelist$.tail, edgelist$.head), ] - } - out -} - -#' @rdname networkLitemethods -#' @export -`-.networkLite` <- function(e1, e2) { - if (!identical(e1 %n% "n", e2 %n% "n") || - !identical(e1 %n% "directed", e2 %n% "directed") || - !identical(e1 %n% "bipartite", e2 %n% "bipartite")) { - stop("cannot subtract networkLites of differing network size,", - " directedness, or bipartiteness") - } - - if (any(NVL(e1 %e% "na", FALSE)) || any(NVL(e2 %e% "na", FALSE))) { - stop("subtracting networkLites with missing edges is not currently", - " supported") - } - - out <- e1 - if (network.edgecount(e2, na.omit = FALSE) > 0) { - edgelist <- dplyr::bind_rows(e2$el, e1$el) - nd <- !duplicated(edgelist[, c(".tail", ".head")]) - out$el <- out$el[nd[-seq_len(network.edgecount(e2, na.omit = FALSE))], ] - out$el <- out$el[order(out$el$.tail, out$el$.head), ] - } - out -} diff --git a/R/to_network_networkLite.R b/R/to_network_networkLite.R new file mode 100644 index 0000000..92ff922 --- /dev/null +++ b/R/to_network_networkLite.R @@ -0,0 +1,46 @@ +#' @rdname to_network_networkLite +#' @title Convert a \code{networkLite} object to a \code{network} object +#' @param x A \code{networkLite} object. +#' @param ... additional arguments +#' @return A corresponding \code{network} object. +#' @seealso \code{\link{as.networkLite}} +#' @details The \code{to_network_networkLite} function takes a +#' \code{networkLite} and returns a corresponding \code{network}. +#' +#' The \code{as.network.networkLite} method returns the +#' \code{networkLite} unchanged, for compatibility with \code{ergm}. +#' @export +to_network_networkLite <- function(x, ...) { + nw <- network.initialize(network.size(x), + directed = x %n% "directed", + bipartite = x %n% "bipartite") + + el <- as.edgelist(x, na.rm = FALSE) + + nw <- add.edges(nw, el[, 1], el[, 2]) + + for (name in list.vertex.attributes(x)) { + set.vertex.attribute(nw, name, get.vertex.attribute(x, name, unlist = FALSE)) + } + + for (name in list.network.attributes(x)) { + set.network.attribute(nw, name, get.network.attribute(x, name)) + } + + eids <- unlist(get.dyads.eids(nw, el[, 1], el[, 2])) + for (name in list.edge.attributes(x)) { + set.edge.attribute(nw, name, get.edge.attribute(x, name, unlist = FALSE), eids) + } + + for (name in setdiff(names(attributes(x)), c("class", "names"))) { + attr(nw, name) <- attr(x, name) + } + + nw +} + +#' @rdname to_network_networkLite +#' @export +as.network.networkLite <- function(x, ...) { + return(x) +} diff --git a/man/add_edges.Rd b/man/add_edges.Rd new file mode 100644 index 0000000..cf18207 --- /dev/null +++ b/man/add_edges.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_edges.R +\name{add.edges.networkLite} +\alias{add.edges.networkLite} +\alias{[<-.networkLite} +\title{Methods to Add or Modify Edges in a \code{networkLite}} +\usage{ +\method{add.edges}{networkLite}(x, tail, head, names.eval = NULL, vals.eval = NULL, ...) + +\method{[}{networkLite}(x, i, j, names.eval = NULL, add.edges = FALSE) <- value +} +\arguments{ +\item{x}{A \code{networkLite}.} + +\item{tail}{Vector of tails of edges to add to the networkLite.} + +\item{head}{Vector of heads of edges to add to the networkLite.} + +\item{names.eval}{name(s) of edge attributes} + +\item{vals.eval}{value(s) of edge attributes} + +\item{...}{additional arguments} + +\item{i, j}{Nodal indices (must be missing for networkLite method).} + +\item{add.edges}{should edges being assigned to be added if not already +present?} + +\item{value}{edge values to assign} +} +\description{ +Methods to Add or Modify Edges in a \code{networkLite} +} diff --git a/man/add_vertices.Rd b/man/add_vertices.Rd new file mode 100644 index 0000000..85b1664 --- /dev/null +++ b/man/add_vertices.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/add_vertices.R +\name{add.vertices.networkLite} +\alias{add.vertices.networkLite} +\title{Add Vertices to a \code{networkLite}} +\usage{ +\method{add.vertices}{networkLite}(x, nv, vattr = NULL, last.mode = TRUE, ...) +} +\arguments{ +\item{x}{A \code{networkLite} object.} + +\item{nv}{Number of vertices to add to the \code{networkLite}.} + +\item{vattr}{A list (of length \code{nv}) of named lists of vertex +attribute values for added vertices, or \code{NULL} to indicate vertex +attribute values are not being passed.} + +\item{last.mode}{logical; if \code{x} is bipartite, should the new vertices +be added to the second mode?} + +\item{...}{additional arguments} +} +\description{ +Add Vertices to a \code{networkLite} +} diff --git a/man/as.networkLite.Rd b/man/as.networkLite.Rd index ed0a805..356171c 100644 --- a/man/as.networkLite.Rd +++ b/man/as.networkLite.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/networkLite.R +% Please edit documentation in R/as.networkLite.R \name{as.networkLite} \alias{as.networkLite} \alias{as.networkLite.network} \alias{as.networkLite.networkLite} -\title{as.networkLite} +\title{Convert to \code{networkLite} Representation} \usage{ as.networkLite(x, ...) @@ -13,21 +13,25 @@ as.networkLite(x, ...) \method{as.networkLite}{networkLite}(x, ...) } \arguments{ -\item{x}{a \code{network} or \code{networkLite} object} +\item{x}{A \code{network} or \code{networkLite} object.} \item{...}{additional arguments} } \value{ -a corresponding \code{networkLite} object +A corresponding \code{networkLite} object. } \description{ -Convert to \code{networkLite} representation. +Convert to \code{networkLite} Representation } \details{ -Currently the network attributes \code{hyper}, \code{multiple}, and +\code{as.networkLite.network} converts a \code{network} object + to a \code{networkLite} object. \code{as.networkLite.networkLite} + returns the \code{networkLite} object unchanged. + + Currently the network attributes \code{hyper}, \code{multiple}, and \code{loops} must be \code{FALSE} for \code{networkLite}s; - attempting to convert to \code{networkLite} when this is not the - case will result in an error. + attempting to convert a \code{network} to a \code{networkLite} when + this is not the case will result in an error. } \seealso{ \code{\link{to_network_networkLite}} diff --git a/man/attribute_methods.Rd b/man/attribute_methods.Rd new file mode 100644 index 0000000..dba7923 --- /dev/null +++ b/man/attribute_methods.Rd @@ -0,0 +1,95 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/attribute_methods.R +\name{get.vertex.attribute.networkLite} +\alias{get.vertex.attribute.networkLite} +\alias{set.vertex.attribute.networkLite} +\alias{list.vertex.attributes.networkLite} +\alias{get.network.attribute.networkLite} +\alias{set.network.attribute.networkLite} +\alias{list.network.attributes.networkLite} +\alias{get.edge.attribute.networkLite} +\alias{get.edge.value.networkLite} +\alias{set.edge.attribute.networkLite} +\alias{set.edge.value.networkLite} +\alias{list.edge.attributes.networkLite} +\alias{delete.vertex.attribute.networkLite} +\alias{delete.edge.attribute.networkLite} +\alias{delete.network.attribute.networkLite} +\title{\code{networkLite} Attribute Methods} +\usage{ +\method{get.vertex.attribute}{networkLite}(x, attrname, ..., unlist = TRUE) + +\method{set.vertex.attribute}{networkLite}(x, attrname, value, v = seq_len(network.size(x)), ...) + +\method{list.vertex.attributes}{networkLite}(x, ...) + +\method{get.network.attribute}{networkLite}(x, attrname, ..., unlist = FALSE) + +\method{set.network.attribute}{networkLite}(x, attrname, value, ...) + +\method{list.network.attributes}{networkLite}(x, ...) + +\method{get.edge.attribute}{networkLite}(x, attrname, ..., unlist = TRUE) + +\method{get.edge.value}{networkLite}(x, attrname, ..., unlist = TRUE) + +\method{set.edge.attribute}{networkLite}( + x, + attrname, + value, + e = seq_len(network.edgecount(x, na.omit = FALSE)), + ... +) + +\method{set.edge.value}{networkLite}( + x, + attrname, + value, + e = seq_len(network.edgecount(x, na.omit = FALSE)), + ... +) + +\method{list.edge.attributes}{networkLite}(x, ...) + +\method{delete.vertex.attribute}{networkLite}(x, attrname, ...) + +\method{delete.edge.attribute}{networkLite}(x, attrname, ...) + +\method{delete.network.attribute}{networkLite}(x, attrname, ...) +} +\arguments{ +\item{x}{A \code{networkLite} object.} + +\item{attrname}{The name of an attribute in \code{x}; must be a length one +character vector.} + +\item{...}{additional arguments} + +\item{unlist}{Logical. In \code{get.vertex.attribute} and +\code{get.edge.attribute}, if \code{unlist} is \code{TRUE}, we call +\code{unlist} on the attribute value before returning it, and if +\code{unlist} is \code{FALSE}, we call \code{as.list} on the +attribute value before returning it. In \code{get.network.attribute}, +if \code{unlist} is \code{TRUE}, we call \code{unlist} on the +attribute value before returning it, and if \code{unlist} is +\code{FALSE}, we return the attribute value without any modification.} + +\item{value}{The attribute value to set in vertex, edge, and network +attribute setters.} + +\item{v}{Indices at which to set vertex attribute values.} + +\item{e}{Indices at which to set edge attribute values.} +} +\value{ +Behavior and return values are analogous to those of the + corresponding \code{network} methods, with network data structured + in the \code{networkLite} format. +} +\description{ +S3 attribute methods for the \code{networkLite} class, for + generics defined in the \code{network} package. +} +\details{ +Allows basic attribute manipulation for \code{networkLite}s. +} diff --git a/man/networkLite.Rd b/man/constructors.Rd similarity index 96% rename from man/networkLite.Rd rename to man/constructors.Rd index 8172867..f53e5d9 100644 --- a/man/networkLite.Rd +++ b/man/constructors.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/networkLite.R +% Please edit documentation in R/constructors.R \name{networkLite} \alias{networkLite} \alias{networkLite.edgelist} @@ -33,7 +33,7 @@ networkLite_initialize(x, directed = FALSE, bipartite = FALSE, ...) network attributes in its \code{attributes} list), or a number specifying the network size.} -\item{...}{Additional arguments used by other methods.} +\item{...}{additional arguments} \item{attr}{A named list of vertex attributes for the network represented by \code{x}.} diff --git a/man/edgecount.Rd b/man/edgecount.Rd new file mode 100644 index 0000000..bacdde0 --- /dev/null +++ b/man/edgecount.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/misc.R +\name{network.edgecount.networkLite} +\alias{network.edgecount.networkLite} +\alias{network.naedgecount.networkLite} +\title{Count Edges in a \code{networkLite}} +\usage{ +\method{network.edgecount}{networkLite}(x, na.omit = TRUE, ...) + +\method{network.naedgecount}{networkLite}(x, ...) +} +\arguments{ +\item{x}{A \code{networkLite} object.} + +\item{na.omit}{logical; omit missing edges from edge count?} + +\item{...}{additional arguments} +} +\description{ +Count Edges in a \code{networkLite} +} +\details{ +The \code{network.edgecount} method provides a count of the number + of edges in the \code{networkLite}, including missing edges if + \code{na.omit = FALSE} and omitting them if \code{na.omit = TRUE}. + The \code{network.naedgecount} method provides a count of the + number of missing edges in the \code{networkLite}. +} diff --git a/man/is.na.Rd b/man/is.na.Rd new file mode 100644 index 0000000..a875c2e --- /dev/null +++ b/man/is.na.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/misc.R +\name{is.na.networkLite} +\alias{is.na.networkLite} +\title{Extract \code{networkLite} with Missing Edges Only} +\usage{ +\method{is.na}{networkLite}(x) +} +\arguments{ +\item{x}{A \code{networkLite}.} +} +\description{ +Extract \code{networkLite} with Missing Edges Only +} +\details{ +The \code{is.na} method creates a \code{networkLite} whose edges + are precisely those edges in \code{x} that are missing. The edges + in the return value are marked as not missing. +} diff --git a/man/matrix_conversions.Rd b/man/matrix_conversions.Rd new file mode 100644 index 0000000..73d03ef --- /dev/null +++ b/man/matrix_conversions.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/matrix_conversions.R +\name{as.edgelist.networkLite} +\alias{as.edgelist.networkLite} +\alias{as_tibble.networkLite} +\alias{as.matrix.networkLite} +\title{Convert a \code{networkLite} to a Matrix or \code{tibble}.} +\usage{ +\method{as.edgelist}{networkLite}( + x, + attrname = NULL, + output = c("matrix", "tibble"), + na.rm = TRUE, + ... +) + +\method{as_tibble}{networkLite}(x, attrnames = NULL, na.rm = TRUE, ...) + +\method{as.matrix}{networkLite}( + x, + matrix.type = c("adjacency", "incidence", "edgelist"), + attrname = NULL, + ... +) +} +\arguments{ +\item{x}{A \code{networkLite}.} + +\item{attrname}{Name of an edge attribute in \code{x}.} + +\item{output}{Type of edgelist to output.} + +\item{na.rm}{should missing edges be dropped from edgelist?} + +\item{...}{additional arguments} + +\item{attrnames}{Vector specifying edge attributes to include in the tibble; +may be logical, integer, or character vector, the former two being +used to select attribute names from \code{list.edge.attributes(x)}, +and the latter being used as the attribute names themselves} + +\item{matrix.type}{type of matrix to return from +\code{as.matrix.networkLite}} +} +\description{ +Convert a \code{networkLite} to a Matrix or \code{tibble}. +} diff --git a/man/mixingmatrix.Rd b/man/mixingmatrix.Rd new file mode 100644 index 0000000..319624a --- /dev/null +++ b/man/mixingmatrix.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mixingmatrix.R +\name{mixingmatrix.networkLite} +\alias{mixingmatrix.networkLite} +\title{Extract Mixing Matrix from \code{networkLite}} +\usage{ +\method{mixingmatrix}{networkLite}(object, attr, ...) +} +\arguments{ +\item{object}{A \code{networkLite} object.} + +\item{attr}{The name of a vertex attribute in \code{object}.} + +\item{...}{additional arguments} +} +\value{ +The mixing matrix for \code{object} and \code{attr}. +} +\description{ +Extract Mixing Matrix from \code{networkLite} +} diff --git a/man/networkLitemethods.Rd b/man/networkLitemethods.Rd deleted file mode 100644 index 0152160..0000000 --- a/man/networkLitemethods.Rd +++ /dev/null @@ -1,191 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/networkLite.R -\name{networkLitemethods} -\alias{networkLitemethods} -\alias{get.vertex.attribute.networkLite} -\alias{set.vertex.attribute.networkLite} -\alias{list.vertex.attributes.networkLite} -\alias{get.network.attribute.networkLite} -\alias{set.network.attribute.networkLite} -\alias{list.network.attributes.networkLite} -\alias{get.edge.attribute.networkLite} -\alias{get.edge.value.networkLite} -\alias{set.edge.attribute.networkLite} -\alias{set.edge.value.networkLite} -\alias{list.edge.attributes.networkLite} -\alias{network.edgecount.networkLite} -\alias{as.edgelist.networkLite} -\alias{mixingmatrix.networkLite} -\alias{[<-.networkLite} -\alias{print.networkLite} -\alias{network.naedgecount.networkLite} -\alias{add.edges.networkLite} -\alias{as.network.networkLite} -\alias{as_tibble.networkLite} -\alias{as.matrix.networkLite} -\alias{is.na.networkLite} -\alias{delete.vertex.attribute.networkLite} -\alias{delete.edge.attribute.networkLite} -\alias{delete.network.attribute.networkLite} -\alias{add.vertices.networkLite} -\alias{+.networkLite} -\alias{-.networkLite} -\title{networkLite Methods} -\usage{ -\method{get.vertex.attribute}{networkLite}(x, attrname, ..., unlist = TRUE) - -\method{set.vertex.attribute}{networkLite}(x, attrname, value, v = seq_len(network.size(x)), ...) - -\method{list.vertex.attributes}{networkLite}(x, ...) - -\method{get.network.attribute}{networkLite}(x, attrname, ..., unlist = FALSE) - -\method{set.network.attribute}{networkLite}(x, attrname, value, ...) - -\method{list.network.attributes}{networkLite}(x, ...) - -\method{get.edge.attribute}{networkLite}(x, attrname, ..., unlist = TRUE) - -\method{get.edge.value}{networkLite}(x, attrname, ..., unlist = TRUE) - -\method{set.edge.attribute}{networkLite}( - x, - attrname, - value, - e = seq_len(network.edgecount(x, na.omit = FALSE)), - ... -) - -\method{set.edge.value}{networkLite}( - x, - attrname, - value, - e = seq_len(network.edgecount(x, na.omit = FALSE)), - ... -) - -\method{list.edge.attributes}{networkLite}(x, ...) - -\method{network.edgecount}{networkLite}(x, na.omit = TRUE, ...) - -\method{as.edgelist}{networkLite}( - x, - attrname = NULL, - output = c("matrix", "tibble"), - na.rm = TRUE, - ... -) - -\method{mixingmatrix}{networkLite}(object, attr, ...) - -\method{[}{networkLite}(x, i, j, names.eval = NULL, add.edges = FALSE) <- value - -\method{print}{networkLite}(x, ...) - -\method{network.naedgecount}{networkLite}(x, ...) - -\method{add.edges}{networkLite}(x, tail, head, names.eval = NULL, vals.eval = NULL, ...) - -\method{as.network}{networkLite}(x, ...) - -\method{as_tibble}{networkLite}(x, attrnames = NULL, na.rm = TRUE, ...) - -\method{as.matrix}{networkLite}( - x, - matrix.type = c("adjacency", "incidence", "edgelist"), - attrname = NULL, - ... -) - -\method{is.na}{networkLite}(x) - -\method{delete.vertex.attribute}{networkLite}(x, attrname, ...) - -\method{delete.edge.attribute}{networkLite}(x, attrname, ...) - -\method{delete.network.attribute}{networkLite}(x, attrname, ...) - -\method{add.vertices}{networkLite}(x, nv, vattr = NULL, last.mode = TRUE, ...) - -\method{+}{networkLite}(e1, e2) - -\method{-}{networkLite}(e1, e2) -} -\arguments{ -\item{x}{A \code{networkLite} object.} - -\item{attrname}{The name of an attribute in \code{x}.} - -\item{...}{Any additional arguments.} - -\item{unlist}{logical; in \code{get.vertex.attribute} and -\code{get.edge.attribute}, if \code{unlist} is \code{TRUE}, call -\code{unlist} on the attribute value before returning it, and if -\code{unlist} is \code{FALSE}, call \code{as.list} on the attribute -value before returning it; in \code{get.network.attribute}, if -\code{unlist} is \code{TRUE}, call \code{unlist} on the attribute -value before returning it, and if \code{unlist} is \code{FALSE}, -return the attribute value without any modification} - -\item{value}{The attribute value to set in vertex, edge, and network -attribute setters; the value to set edges to (must be FALSE) -for the \code{networkLite} replacement method.} - -\item{v}{Indices at which to set vertex attribute values.} - -\item{e}{edge indices to assign value} - -\item{na.omit}{logical; omit missing edges from edge count?} - -\item{output}{Type of edgelist to output.} - -\item{na.rm}{should missing edges be dropped from edgelist?} - -\item{object}{A \code{networkLite} object.} - -\item{attr}{The name of a vertex attribute in \code{object}.} - -\item{i, j}{Nodal indices (must be missing for networkLite method).} - -\item{names.eval}{name(s) of edge attributes} - -\item{add.edges}{should edges being assigned to be added if not already -present?} - -\item{tail}{Vector of tails of edges to add to the networkLite.} - -\item{head}{Vector of heads of edges to add to the networkLite.} - -\item{vals.eval}{value(s) of edge attributes} - -\item{attrnames}{vector specifying edge attributes to include in the tibble; -may be logical, integer, or character vector, the former two being -used to select attribute names from \code{list.edge.attributes(x)}, -and the latter being used as the attribute names themselves} - -\item{matrix.type}{type of matrix to return from -\code{as.matrix.networkLite}} - -\item{nv}{number of vertices to add to the \code{networkLite}} - -\item{vattr}{list (of length \code{nv}) of named lists of vertex attributes -for added vertices, or \code{NULL} to indicate vertex attributes are -not being passed} - -\item{last.mode}{logical; if \code{x} is bipartite, should the new vertices -be added to the second mode?} - -\item{e1, e2}{networkLite objects} -} -\value{ -Behavior and return values are analogous to those of the - corresponding \code{network} methods, with network data structured - in the \code{networkLite} format. -} -\description{ -S3 methods for networkLite class, for generics defined in - network package. -} -\details{ -Allows use of networkLite objects in \code{ergm_model}. -} diff --git a/man/operators.Rd b/man/operators.Rd new file mode 100644 index 0000000..f722374 --- /dev/null +++ b/man/operators.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/misc.R +\name{+.networkLite} +\alias{+.networkLite} +\alias{-.networkLite} +\title{Add and Subtract \code{networkLite}s} +\usage{ +\method{+}{networkLite}(e1, e2) + +\method{-}{networkLite}(e1, e2) +} +\arguments{ +\item{e1, e2}{\code{networkLite} objects} +} +\description{ +Add and Subtract \code{networkLite}s +} +\details{ +\code{e1 + e2} produces a \code{networkLite} whose edges are those + in either \code{e1} or \code{e2}, and \code{e1 - e2} produces a + \code{networkLite} whose edges are those in \code{e1} and not in + \code{e2}. +} diff --git a/man/print.Rd b/man/print.Rd new file mode 100644 index 0000000..82f0403 --- /dev/null +++ b/man/print.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/misc.R +\name{print.networkLite} +\alias{print.networkLite} +\title{Print Basic Summary of a \code{networkLite}} +\usage{ +\method{print}{networkLite}(x, ...) +} +\arguments{ +\item{x}{A \code{networkLite} object.} + +\item{...}{additional arguments} +} +\description{ +Print Basic Summary of a \code{networkLite} +} +\details{ +This method prints a basic summary of a \code{networkLite} object, + including network size, edge count, and attribute names. +} diff --git a/man/to_network_networkLite.Rd b/man/to_network_networkLite.Rd index e9d8870..e81fbda 100644 --- a/man/to_network_networkLite.Rd +++ b/man/to_network_networkLite.Rd @@ -1,22 +1,32 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/networkLite.R +% Please edit documentation in R/to_network_networkLite.R \name{to_network_networkLite} \alias{to_network_networkLite} +\alias{as.network.networkLite} \title{Convert a \code{networkLite} object to a \code{network} object} \usage{ to_network_networkLite(x, ...) + +\method{as.network}{networkLite}(x, ...) } \arguments{ -\item{x}{a \code{networkLite} object} +\item{x}{A \code{networkLite} object.} \item{...}{additional arguments} } \value{ -a corresponding \code{network} object +A corresponding \code{network} object. } \description{ Convert a \code{networkLite} object to a \code{network} object } +\details{ +The \code{to_network_networkLite} function takes a + \code{networkLite} and returns a corresponding \code{network}. + + The \code{as.network.networkLite} method returns the + \code{networkLite} unchanged, for compatibility with \code{ergm}. +} \seealso{ \code{\link{as.networkLite}} } From 9d132ebaa10f47f2120475b0ebfc3fe2f60bc3db Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Mon, 12 Sep 2022 10:05:06 -0700 Subject: [PATCH 15/49] Rename as.networkLite.R to as_networkLite.R --- R/{as.networkLite.R => as_networkLite.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename R/{as.networkLite.R => as_networkLite.R} (100%) diff --git a/R/as.networkLite.R b/R/as_networkLite.R similarity index 100% rename from R/as.networkLite.R rename to R/as_networkLite.R From df4fcf745249003cf576ef4716d85b1e7b96716a Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Mon, 12 Sep 2022 10:07:09 -0700 Subject: [PATCH 16/49] use underscore for consistency --- R/as_networkLite.R | 6 +++--- man/{as.networkLite.Rd => as_networkLite.Rd} | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) rename man/{as.networkLite.Rd => as_networkLite.Rd} (95%) diff --git a/R/as_networkLite.R b/R/as_networkLite.R index 20ce4e5..6834ef9 100644 --- a/R/as_networkLite.R +++ b/R/as_networkLite.R @@ -1,4 +1,4 @@ -#' @rdname as.networkLite +#' @rdname as_networkLite #' @title Convert to \code{networkLite} Representation #' @details \code{as.networkLite.network} converts a \code{network} object #' to a \code{networkLite} object. \code{as.networkLite.networkLite} @@ -17,7 +17,7 @@ as.networkLite <- function(x, ...) { UseMethod("as.networkLite") } -#' @rdname as.networkLite +#' @rdname as_networkLite #' @export as.networkLite.network <- function(x, ...) { if (is.hyper(x) || is.multiplex(x) || has.loops(x)) { @@ -80,7 +80,7 @@ atomize <- function(nwL) { nwL } -#' @rdname as.networkLite +#' @rdname as_networkLite #' @export as.networkLite.networkLite <- function(x, ...) { x diff --git a/man/as.networkLite.Rd b/man/as_networkLite.Rd similarity index 95% rename from man/as.networkLite.Rd rename to man/as_networkLite.Rd index 356171c..7daf0b7 100644 --- a/man/as.networkLite.Rd +++ b/man/as_networkLite.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/as.networkLite.R +% Please edit documentation in R/as_networkLite.R \name{as.networkLite} \alias{as.networkLite} \alias{as.networkLite.network} From 3d444409fc8026f4be940f115d59f8373c22357b Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Tue, 13 Sep 2022 09:01:51 -0700 Subject: [PATCH 17/49] re-implementation of networkLites to handle attributes more like networks --- R/add_edges.R | 41 +++++-- R/add_vertices.R | 39 +++++-- R/as_networkLite.R | 40 +++---- R/attribute_methods.R | 33 ++++-- R/matrix_conversions.R | 9 +- R/misc.R | 16 ++- R/to_network_networkLite.R | 11 +- man/attribute_methods.Rd | 12 +- tests/testthat/test-networkLite.R | 186 ++++++++++++------------------ 9 files changed, 212 insertions(+), 175 deletions(-) diff --git a/R/add_edges.R b/R/add_edges.R index 0825802..31cd042 100644 --- a/R/add_edges.R +++ b/R/add_edges.R @@ -16,33 +16,52 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, vals.eval = NULL, ...) { tail <- NVL(unlist(tail), integer(0)) head <- NVL(unlist(head), integer(0)) - if (length(names.eval) == 0 || length(vals.eval) == 0) { + if (length(names.eval) == 0 || length(vals.eval) == 0 || + length(unlist(names.eval)) == 0 || length(unlist(vals.eval)) == 0) { update_tibble <- as_tibble(list(.tail = tail, .head = head, na = logical(length(tail)))) + new_names <- c("na") } else { + new_names <- unique(unlist(names.eval)) + if (!is.list(names.eval)) names.eval <- as.list(rep(names.eval, length.out = length(tail))) if (!is.list(vals.eval)) vals.eval <- as.list(rep(vals.eval, length.out = length(names.eval))) for (i in seq_along(vals.eval)) { - vals.eval[[i]] <- as.list(vals.eval[[i]]) - names(vals.eval[[i]]) <- unlist(names.eval[[i]]) + given_names <- unlist(names.eval[[i]]) + null_names <- setdiff(new_names, given_names) + vals.eval[[i]] <- c(as.list(vals.eval[[i]]), vector(mode = "list", length = length(null_names))) + names(vals.eval[[i]]) <- c(given_names, null_names) } - f <- function(x) if (length(x) > 0) as_tibble(x) else tibble(NULL, .rows = 1) - update_tibble <- - dplyr::bind_cols(as_tibble(list(.tail = tail, .head = head)), - dplyr::bind_rows(lapply(vals.eval, f))) + update_list <- lapply(new_names, function(name) lapply(vals.eval, `[[`, name)) + names(update_list) <- new_names + update_tibble <- dplyr::bind_cols(as_tibble(list(.tail = tail, .head = head)), + as_tibble(update_list)) + + if ("na" %in% new_names) { + update_tibble[["na"]] <- lapply(update_tibble[["na"]], + function(val) if (is.null(val) || is.na(val)) FALSE else val) + } else { + new_names <- c(new_names, "na") + update_tibble[["na"]] <- logical(NROW(update_tibble)) + } } - update_tibble[["na"]] <- NVL(update_tibble[["na"]], - logical(NROW(update_tibble))) - update_tibble[["na"]][is.na(update_tibble[["na"]])] <- FALSE + old_names <- list.edge.attributes(x) + for (name in setdiff(old_names, new_names)) { + update_tibble[[name]] <- vector(mode = "list", length = NROW(update_tibble)) + } xn <- substitute(x) - x$el <- dplyr::bind_rows(x$el, update_tibble) + for (name in setdiff(new_names, old_names)) { + x$el[[name]] <- vector(mode = "list", length = NROW(x$el)) + } + + x$el <- dplyr::bind_rows(ensure_list(list(x$el, update_tibble))) x$el <- x$el[order(x$el$.tail, x$el$.head), ] x$el <- x$el[!duplicated(x$el[, c(".tail", ".head")]), ] diff --git a/R/add_vertices.R b/R/add_vertices.R index bd6bb10..aa6e361 100644 --- a/R/add_vertices.R +++ b/R/add_vertices.R @@ -33,18 +33,41 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL, vattr <- as.list(rep(vattr, length.out = nv)) } - f <- function(x) if (length(x) > 0) as_tibble(x) else tibble(NULL, .rows = 1) - update_tibble <- dplyr::bind_rows(lapply(vattr, f)) + new_names <- unique(unlist(lapply(vattr, names))) + for (i in seq_along(vattr)) { + given_names <- names(vattr[[i]]) + null_names <- setdiff(new_names, given_names) + vattr[[i]] <- c(vattr[[i]], vector(mode = "list", length = length(null_names))) + names(vattr[[i]]) <- c(given_names, null_names) + } + + update_list <- lapply(new_names, function(name) lapply(vattr, `[[`, name)) + names(update_list) <- new_names + update_tibble <- as_tibble(update_list) + + if ("na" %in% new_names) { + update_tibble[["na"]] <- lapply(update_tibble[["na"]], + function(val) if (is.null(val) || is.na(val)) FALSE else val) + } else { + new_names <- c(new_names, "na") + update_tibble[["na"]] <- logical(NROW(update_tibble)) + } } else { + new_names <- c("na") update_tibble <- as_tibble(list(na = logical(nv))) } - update_tibble[["na"]] <- NVL(update_tibble[["na"]], - logical(NROW(update_tibble))) - update_tibble[["na"]][is.na(update_tibble[["na"]])] <- FALSE - x$attr <- dplyr::bind_rows(x$attr[seq_len(offset), ], - update_tibble, - x$attr[offset + seq_len(oldsize - offset), ]) + old_names <- list.vertex.attributes(x) + for (name in setdiff(old_names, new_names)) { + update_tibble[[name]] <- vector(mode = "list", length = NROW(update_tibble)) + } + for (name in setdiff(new_names, old_names)) { + x$attr[[name]] <- vector(mode = "list", length = NROW(x$attr)) + } + + x$attr <- dplyr::bind_rows(ensure_list(list(x$attr[seq_len(offset), ], + update_tibble, + x$attr[offset + seq_len(oldsize - offset), ]))) } on.exit(eval.parent(call("<-", xn, x))) diff --git a/R/as_networkLite.R b/R/as_networkLite.R index 6834ef9..e1581a5 100644 --- a/R/as_networkLite.R +++ b/R/as_networkLite.R @@ -30,21 +30,21 @@ as.networkLite.network <- function(x, ...) { rv <- networkLite(el) for (name in list.vertex.attributes(x)) { - set.vertex.attribute(rv, name, get.vertex.attribute(x, - name, - null.na = TRUE, - unlist = FALSE)) + value <- get.vertex.attribute(x, name, null.na = FALSE, na.omit = FALSE, + unlist = FALSE) + set.vertex.attribute(rv, name, value) } for (name in setdiff(list.network.attributes(x), c("mnext"))) { - set.network.attribute(rv, name, get.network.attribute(x, name)) + value <- get.network.attribute(x, name) + set.network.attribute(rv, name, value) } - eids <- unlist(get.dyads.eids(x, el[, 1], el[, 2])) + eids <- unlist(get.dyads.eids(x, el[, 1], el[, 2], na.omit = FALSE)) for (name in list.edge.attributes(x)) { - set.edge.attribute(rv, name, get.edge.attribute(x, name, null.na = TRUE, - deleted.edges.omit = FALSE, - unlist = FALSE)[eids]) + value <- get.edge.attribute(x, name, unlist = FALSE, null.na = FALSE, + na.omit = FALSE, deleted.edges.omit = FALSE)[eids] + set.edge.attribute(rv, name, value) } for (name in setdiff(names(attributes(x)), c("class", "names"))) { @@ -59,25 +59,21 @@ as.networkLite.network <- function(x, ...) { ## convert vertex and edge attributes to atomic vectors where possible; ## note that this may upcast atomic types, e.g. logical -> numeric -> character atomize <- function(nwL) { - for (name in list.vertex.attributes(nwL)) { - value <- get.vertex.attribute(nwL, name, unlist = FALSE) - if (length(value) > 0 && - all(unlist(lapply(value, is.atomic))) && - all(unlist(lapply(value, length)) == 1)) { - nwL$attr[[name]] <- unlist(value) - } - } + nwL$el <- atomize_tibble(nwL$el) # also applies to .tail, .head + nwL$attr <- atomize_tibble(nwL$attr) + nwL +} - for (name in list.edge.attributes(nwL)) { - value <- get.edge.attribute(nwL, name, unlist = FALSE) +atomize_tibble <- function(x) { + for (name in names(x)) { + value <- x[[name]] if (length(value) > 0 && all(unlist(lapply(value, is.atomic))) && all(unlist(lapply(value, length)) == 1)) { - nwL$el[[name]] <- unlist(value) + x[[name]] <- unlist(value) } } - - nwL + x } #' @rdname as_networkLite diff --git a/R/attribute_methods.R b/R/attribute_methods.R index 915b3ff..4478d67 100644 --- a/R/attribute_methods.R +++ b/R/attribute_methods.R @@ -12,7 +12,10 @@ #' attribute setters. #' @param v Indices at which to set vertex attribute values. #' @param e Indices at which to set edge attribute values. -#' @param unlist Logical. In \code{get.vertex.attribute} and +#' @param null.na Logical. If \code{TRUE}, replace \code{NULL} attribute values +#' with \code{NA} in \code{get.vertex.attribute} and +#' \code{get.edge.attribute}. Applied before the \code{unlist} argument. +#' @param unlist Logical. In \code{get.vertex.attribute} and #' \code{get.edge.attribute}, if \code{unlist} is \code{TRUE}, we call #' \code{unlist} on the attribute value before returning it, and if #' \code{unlist} is \code{FALSE}, we call \code{as.list} on the @@ -30,11 +33,15 @@ #' #' @export #' -get.vertex.attribute.networkLite <- function(x, attrname, ..., unlist = TRUE) { +get.vertex.attribute.networkLite <- function(x, attrname, ..., null.na = TRUE, unlist = TRUE) { if (attrname %in% list.vertex.attributes(x)) { out <- x$attr[[attrname]] } else { - out <- rep(NA, length.out = network.size(x)) + out <- vector(mode = "list", length = network.size(x)) + } + + if (null.na == TRUE && is.list(out)) { + out <- lapply(out, NVL, NA) } if (unlist == TRUE) { @@ -57,7 +64,7 @@ set.vertex.attribute.networkLite <- function(x, xn <- substitute(x) if (!(attrname %in% list.vertex.attributes(x))) { - x$attr[[attrname]] <- rep(NA, length.out = network.size(x)) + x$attr[[attrname]] <- vector(mode = "list", length = network.size(x)) } x$attr[[attrname]][v] <- value @@ -108,8 +115,16 @@ list.network.attributes.networkLite <- function(x, ...) { #' @rdname attribute_methods #' @export #' -get.edge.attribute.networkLite <- function(x, attrname, ..., unlist = TRUE) { - out <- x$el[[attrname]] +get.edge.attribute.networkLite <- function(x, attrname, ..., null.na = TRUE, unlist = TRUE) { + if (attrname %in% list.edge.attributes(x)) { + out <- x$el[[attrname]] + } else { + out <- vector(mode = "list", length = network.edgecount(x, na.omit = FALSE)) + } + + if (null.na == TRUE && is.list(out)) { + out <- lapply(out, NVL, NA) + } if (unlist == TRUE) { out <- unlist(out) @@ -135,8 +150,7 @@ set.edge.attribute.networkLite <- function( xn <- substitute(x) if (!(attrname %in% list.edge.attributes(x))) { - x$el[[attrname]] <- rep(NA, - length.out = network.edgecount(x, na.omit = FALSE)) + x$el[[attrname]] <- vector(mode = "list", length = network.edgecount(x, na.omit = FALSE)) } x$el[[attrname]][e] <- value @@ -155,8 +169,7 @@ set.edge.value.networkLite <- function( xn <- substitute(x) if (!(attrname %in% list.edge.attributes(x))) { - x$el[[attrname]] <- rep(NA, - length.out = network.edgecount(x, na.omit = FALSE)) + x$el[[attrname]] <- vector(mode = "list", length = network.edgecount(x, na.omit = FALSE)) } x$el[[attrname]][e] <- value[as.matrix(x$el[e, c(".tail", ".head")])] diff --git a/R/matrix_conversions.R b/R/matrix_conversions.R index 1e1d937..286ea99 100644 --- a/R/matrix_conversions.R +++ b/R/matrix_conversions.R @@ -21,10 +21,7 @@ as.edgelist.networkLite <- function(x, attrname = NULL, if (output == "matrix") { m <- matrix(c(x$el$.tail, x$el$.head), ncol = 2) if (!is.null(attrname)) { - attrval <- get.edge.attribute(x, attrname, unlist = FALSE) - ## analogous to null.na = TRUE in network - attrval <- lapply(attrval, function(val) NVL(val, NA)) - m <- cbind(m, unlist(attrval)) + m <- cbind(m, get.edge.attribute(x, attrname, null.na = TRUE, unlist = TRUE)) } } else { m <- x$el[c(".tail", ".head", attrname)] @@ -35,6 +32,9 @@ as.edgelist.networkLite <- function(x, attrname = NULL, m <- m[!na, , drop = FALSE] } + if (output == "tibble") { + m <- atomize_tibble(m) + } attr(m, "dimnames") <- NULL attr(m, "n") <- as.integer(network.size(x)) @@ -59,6 +59,7 @@ as_tibble.networkLite <- function(x, attrnames = NULL, na.rm = TRUE, ...) { na <- NVL(x %e% "na", FALSE) out <- out[!na, ] } + out <- atomize_tibble(out) attr(out, "n") <- network.size(x) attr(out, "vnames") <- network.vertex.names(x) if (is.bipartite(x)) attr(out, "bipartite") <- x %n% "bipartite" diff --git a/R/misc.R b/R/misc.R index 4f57f46..416a642 100644 --- a/R/misc.R +++ b/R/misc.R @@ -83,7 +83,7 @@ is.na.networkLite <- function(x) { out <- e1 if (network.edgecount(e2, na.omit = FALSE) > 0) { - edgelist <- dplyr::bind_rows(e1$el, e2$el) + edgelist <- dplyr::bind_rows(ensure_list(list(e1$el, e2$el))) edgelist <- edgelist[!duplicated(edgelist[, c(".tail", ".head")]), ] out$el <- edgelist[order(edgelist$.tail, edgelist$.head), ] } @@ -107,10 +107,22 @@ is.na.networkLite <- function(x) { out <- e1 if (network.edgecount(e2, na.omit = FALSE) > 0) { - edgelist <- dplyr::bind_rows(e2$el, e1$el) + edgelist <- dplyr::bind_rows(ensure_list(list(e2$el, e1$el))) nd <- !duplicated(edgelist[, c(".tail", ".head")]) out$el <- out$el[nd[-seq_len(network.edgecount(e2, na.omit = FALSE))], ] out$el <- out$el[order(out$el$.tail, out$el$.head), ] } out } + +# x = a list of tibbles +ensure_list <- function(x) { + names <- sort(unique(unlist(lapply(x, names)))) + for(name in names) { + any_list <- any(unlist(lapply(lapply(x, `[[`, name), is.list))) + if (any_list == TRUE) { + x <- lapply(x, function(y) { if (name %in% names(y)) { y[[name]] <- as.list(y[[name]]) }; y }) + } + } + return(x) +} diff --git a/R/to_network_networkLite.R b/R/to_network_networkLite.R index 92ff922..9dcd05f 100644 --- a/R/to_network_networkLite.R +++ b/R/to_network_networkLite.R @@ -20,16 +20,19 @@ to_network_networkLite <- function(x, ...) { nw <- add.edges(nw, el[, 1], el[, 2]) for (name in list.vertex.attributes(x)) { - set.vertex.attribute(nw, name, get.vertex.attribute(x, name, unlist = FALSE)) + value <- get.vertex.attribute(x, name, null.na = FALSE, unlist = FALSE) + set.vertex.attribute(nw, name, value) } for (name in list.network.attributes(x)) { - set.network.attribute(nw, name, get.network.attribute(x, name)) + value <- get.network.attribute(x, name) + set.network.attribute(nw, name, value) } - eids <- unlist(get.dyads.eids(nw, el[, 1], el[, 2])) + eids <- unlist(get.dyads.eids(nw, el[, 1], el[, 2], na.omit = FALSE)) for (name in list.edge.attributes(x)) { - set.edge.attribute(nw, name, get.edge.attribute(x, name, unlist = FALSE), eids) + value <- get.edge.attribute(x, name, null.na = FALSE, unlist = FALSE) + set.edge.attribute(nw, name, value, eids) } for (name in setdiff(names(attributes(x)), c("class", "names"))) { diff --git a/man/attribute_methods.Rd b/man/attribute_methods.Rd index dba7923..5509826 100644 --- a/man/attribute_methods.Rd +++ b/man/attribute_methods.Rd @@ -17,7 +17,7 @@ \alias{delete.network.attribute.networkLite} \title{\code{networkLite} Attribute Methods} \usage{ -\method{get.vertex.attribute}{networkLite}(x, attrname, ..., unlist = TRUE) +\method{get.vertex.attribute}{networkLite}(x, attrname, ..., null.na = TRUE, unlist = TRUE) \method{set.vertex.attribute}{networkLite}(x, attrname, value, v = seq_len(network.size(x)), ...) @@ -29,9 +29,9 @@ \method{list.network.attributes}{networkLite}(x, ...) -\method{get.edge.attribute}{networkLite}(x, attrname, ..., unlist = TRUE) +\method{get.edge.attribute}{networkLite}(x, attrname, ..., null.na = TRUE, unlist = TRUE) -\method{get.edge.value}{networkLite}(x, attrname, ..., unlist = TRUE) +\method{get.edge.value}{networkLite}(x, attrname, ..., null.na = TRUE, unlist = TRUE) \method{set.edge.attribute}{networkLite}( x, @@ -65,7 +65,11 @@ character vector.} \item{...}{additional arguments} -\item{unlist}{Logical. In \code{get.vertex.attribute} and +\item{null.na}{Logical. If \code{TRUE}, replace \code{NULL} attribute values +with \code{NA} in \code{get.vertex.attribute} and +\code{get.edge.attribute}. Applied before the \code{unlist} argument.} + +\item{unlist}{Logical. In \code{get.vertex.attribute} and \code{get.edge.attribute}, if \code{unlist} is \code{TRUE}, we call \code{unlist} on the attribute value before returning it, and if \code{unlist} is \code{FALSE}, we call \code{as.list} on the diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index b7884a6..2373733 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -1,3 +1,52 @@ +expect_equiv_nets <- function(nw1, nw2) { + expect_identical(list.network.attributes(nw1), + list.network.attributes(nw2)) + + expect_identical(list.vertex.attributes(nw1), + list.vertex.attributes(nw2)) + + expect_identical(list.edge.attributes(nw1), + list.edge.attributes(nw2)) + + for (attrname in list.network.attributes(nw1)) { + if (attrname == "n") { + # can have integer vs. double issues... + expect_equal(get.network.attribute(nw1, attrname), + get.network.attribute(nw2, attrname)) + } else { + expect_identical(get.network.attribute(nw1, attrname), + get.network.attribute(nw2, attrname)) + } + } + + for (attrname in list.vertex.attributes(nw1)) { + expect_identical(get.vertex.attribute(nw1, attrname, null.na = FALSE, unlist = FALSE), + get.vertex.attribute(nw2, attrname, null.na = FALSE, unlist = FALSE)) + } + + expect_identical(as.edgelist(nw1, na.rm = FALSE), as.edgelist(nw2, na.rm = FALSE)) + el <- as.edgelist(nw1, na.rm = FALSE) + if (!is(nw1, "networkLite")) { + eids1 <- unlist(get.dyads.eids(nw1, el[,1], el[,2], na.omit = FALSE)) + } else { + eids1 <- seq_len(network.edgecount(nw1, na.omit = FALSE)) + } + if (!is(nw2, "networkLite")) { + eids2 <- unlist(get.dyads.eids(nw2, el[,1], el[,2], na.omit = FALSE)) + } else { + eids2 <- seq_len(network.edgecount(nw2, na.omit = FALSE)) + } + for (attrname in list.edge.attributes(nw1)) { + expect_identical(get.edge.attribute(nw1, attrname, null.na = FALSE, unlist = FALSE, na.omit = FALSE, deleted.edges.omit = FALSE)[eids1], + get.edge.attribute(nw2, attrname, null.na = FALSE, unlist = FALSE, na.omit = FALSE, deleted.edges.omit = FALSE)[eids2]) + } + + sn1 <- sort(names(attributes(nw1))) + sn2 <- sort(names(attributes(nw2))) + expect_identical(sn1, sn2) + expect_identical(length(sn1), length(attributes(nw1))) + expect_identical(attributes(nw1)[sn1], attributes(nw2)[sn2]) +} create_random_edgelist <- function(n_nodes, directed, bipartite, target_n_edges) { if (directed == TRUE) { @@ -32,56 +81,26 @@ test_that("direct conversion between network and networkLite functions as expect } for(last.mode in list(FALSE, TRUE)) { - for(delete in list(FALSE)) { - set.seed(0) - nw <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") - nw %v% "b" <- runif(net_size) - nw %e% "eattr" <- runif(network.edgecount(nw)) - nw %n% "nattr" <- "attr" -# nainds <- sample(valid.eids(nw), as.integer(network.size(nw)/2), FALSE) -# set.edge.attribute(nw, "na", TRUE, nainds) - add.vertices(nw, 9, vattr = rep(list(list(na = FALSE, vertex.names = NA_integer_, b = NA_real_)), 9), last.mode = last.mode) - if(delete) { - el <- as.edgelist(nw, attrname = "na", na.rm = FALSE) - w1 <- sample(which(as.logical(el[,3])))[1:5] - w2 <- sample(which(!as.logical(el[,3])))[1:7] - delete.edges(nw, unlist(get.dyads.eids(nw, el[w1,1], el[w1,2], na.omit = FALSE))) - delete.edges(nw, unlist(get.dyads.eids(nw, el[w2,1], el[w2,2], na.omit = FALSE))) - vd <- sample(seq_len(net_size), 10, FALSE) - delete.vertices(nw, vd) - } - # add.vertices and delete.vertices convert network size to integer.... - nw %n% "n" <- as.numeric(nw %n% "n") - - set.seed(0) - nwL <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) - nwL %v% "b" <- runif(net_size) - set.edge.attribute(nwL, "eattr", runif(network.edgecount(nwL))) - nwL %n% "nattr" <- "attr" -# nainds <- sample(seq_len(network.edgecount(nwL)), as.integer(network.size(nwL)/2), FALSE) -# set.edge.attribute(nwL, "na", TRUE, nainds) - add.vertices(nwL, 9, vattr = rep(list(list(na = FALSE, vertex.names = NA_integer_, b = NA_real_)), 9), last.mode = last.mode) - if(delete) { - el <- as.edgelist(nwL, attrname = "na", na.rm = FALSE) - w1 <- sample(which(as.logical(el[,3])))[1:5] - w2 <- sample(which(!as.logical(el[,3])))[1:7] - delete.edges(nwL, c(w1,w2)) - vd <- sample(seq_len(net_size), 10, FALSE) - delete.vertices(nwL, vd) - } + set.seed(0) + nw <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") + nw %v% "b" <- runif(net_size) + nw %e% "eattr" <- runif(network.edgecount(nw)) + nw %n% "nattr" <- "attr" + add.vertices(nw, 9, vattr = rep(list(list(na = FALSE, vertex.names = NA_integer_, b = NA_real_)), 9), last.mode = last.mode) - expect_identical(as.networkLite(nw), nwL) - expect_identical(as.networkLite(is.na(nw)), is.na(nwL)) - expect_identical(as.networkLite(is.na(is.na(nw))), is.na(is.na(nwL))) + set.seed(0) + nwL <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) + nwL %v% "b" <- runif(net_size) + set.edge.attribute(nwL, "eattr", runif(network.edgecount(nwL))) + nwL %n% "nattr" <- "attr" + add.vertices(nwL, 9, vattr = rep(list(list(na = FALSE, vertex.names = NA_integer_, b = NA_real_)), 9), last.mode = last.mode) - if(delete) { - expect_identical(as.networkLite(nw), as.networkLite(to_network_networkLite(nwL))) - expect_identical(as.networkLite(is.na(nw)), as.networkLite(to_network_networkLite(is.na(nwL)))) - } else { - expect_identical(nw, to_network_networkLite(nwL)) - expect_identical(is.na(nw), to_network_networkLite(is.na(nwL))) - } - } + expect_equiv_nets(as.networkLite(nw), nwL) + expect_equiv_nets(as.networkLite(is.na(nw)), is.na(nwL)) + expect_equiv_nets(as.networkLite(is.na(is.na(nw))), is.na(is.na(nwL))) + + expect_equiv_nets(nw, to_network_networkLite(nwL)) + expect_equiv_nets(is.na(nw), to_network_networkLite(is.na(nwL))) } } } @@ -101,14 +120,10 @@ test_that("network and networkLite produce identical matrices, edgelists, and ti set.seed(0) nw <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") nw %e% "eattr" <- runif(network.edgecount(nw)) -# nainds <- sample(valid.eids(nw), as.integer(length(valid.eids(nw))/2), FALSE) -# set.edge.attribute(nw, "na", TRUE, nainds) set.seed(0) nwL <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) set.edge.attribute(nwL, "eattr", runif(network.edgecount(nwL))) -# nainds <- sample(valid.eids(nwL), as.integer(length(valid.eids(nwL))/2), FALSE) -# set.edge.attribute(nwL, "na", TRUE, nainds) for(attrname in list(NULL, "eattr", "na")) { for(na.rm in list(FALSE, TRUE)) { @@ -321,7 +336,7 @@ test_that("network and networkLite behave equivalently for basic access and muta nwL %v% "vattr3" <- vattr3 expect_identical(as.edgelist(nw, attrname = "eattr1"), as.edgelist(nwL, attrname = "eattr1")) -# expect_identical(as.edgelist(nw, attrname = "eattr2"), as.edgelist(nwL, attrname = "eattr2")) + expect_identical(as.edgelist(nw, attrname = "eattr2"), as.edgelist(nwL, attrname = "eattr2")) expect_identical(as.edgelist(nw, attrname = "eattr3"), as.edgelist(nwL, attrname = "eattr3")) expect_identical(nw %v% "vattr1", nwL %v% "vattr1") @@ -422,20 +437,8 @@ test_that("add.vertices and add.edges with irregular attribute arguments behave } add.vertices(nwL, vta, vattr = vattr, last.mode = last.mode) - for(en in setdiff(list.edge.attributes(nw), "na")) { - ev <- get.edge.attribute(nwL, en) - delete.edge.attribute(nwL, en) - set.edge.attribute(nwL, en, ev) - } - - for(vn in setdiff(list.vertex.attributes(nw), c("na", "vertex.names"))) { - vv <- get.vertex.attribute(nwL, vn) - delete.vertex.attribute(nwL, vn) - set.vertex.attribute(nwL, vn, vv) - } - - expect_equal(as.networkLite(nw), nwL) - expect_equal(as.networkLite(nw), as.networkLite(to_network_networkLite(nwL))) + expect_equiv_nets(as.networkLite(nw), nwL) + expect_equiv_nets(as.networkLite(nw), as.networkLite(to_network_networkLite(nwL))) } } } @@ -505,45 +508,8 @@ test_that("attribute setting and deleting behave equivalently for network and ne } } - ## re-order everything for these comparisons... - for(en in setdiff(list.edge.attributes(nw), "na")) { - ev <- get.edge.attribute(nwL, en) - delete.edge.attribute(nwL, en) - set.edge.attribute(nwL, en, ev) - } - - for(vn in setdiff(list.vertex.attributes(nw), c("na", "vertex.names"))) { - vv <- get.vertex.attribute(nwL, vn) - delete.vertex.attribute(nwL, vn) - set.vertex.attribute(nwL, vn, vv) - } - - for(nn in setdiff(list.network.attributes(nw), c("n", "directed", "bipartite", "loops", "hyper", "multiple", "mnext"))) { - nv <- get.network.attribute(nwL, nn) - delete.network.attribute(nwL, nn) - set.network.attribute(nwL, nn, nv) - } - - for(en in setdiff(list.edge.attributes(nwL), "na")) { - ev <- get.edge.attribute(nw, en) - delete.edge.attribute(nw, en) - set.edge.attribute(nw, en, ev) - } - - for(vn in setdiff(list.vertex.attributes(nwL), c("na", "vertex.names"))) { - vv <- get.vertex.attribute(nw, vn) - delete.vertex.attribute(nw, vn) - set.vertex.attribute(nw, vn, vv) - } - - for(nn in setdiff(list.network.attributes(nwL), c("n", "directed", "bipartite", "loops", "hyper", "multiple", "mnext"))) { - nv <- get.network.attribute(nw, nn) - delete.network.attribute(nw, nn) - set.network.attribute(nw, nn, nv) - } - - expect_identical(nw, to_network_networkLite(nwL)) - expect_identical(as.networkLite(nw), nwL) + expect_equiv_nets(nw, to_network_networkLite(nwL)) + expect_equiv_nets(as.networkLite(nw), nwL) } } }) @@ -585,10 +551,10 @@ test_that("more network conversions", { set.vertex.attribute(nwL, "newattr", list(1,list(3),5), c(3,4,1)) expect_identical(get.vertex.attribute(nw, "newattr", null.na = TRUE, unlist = FALSE), - get.vertex.attribute(nwL, "newattr", unlist = FALSE)) + get.vertex.attribute(nwL, "newattr", null.na = TRUE, unlist = FALSE)) expect_identical(get.vertex.attribute(nw, "newattr", null.na = TRUE, unlist = TRUE), - get.vertex.attribute(nwL, "newattr", unlist = TRUE)) + get.vertex.attribute(nwL, "newattr", null.na = TRUE, unlist = TRUE)) nw[1,2] <- 1 nw[3,4] <- 1 @@ -601,9 +567,9 @@ test_that("more network conversions", { eids <- unlist(get.dyads.eids(nw, el[,1], el[,2])) expect_identical(get.edge.attribute(nw, "eattr", null.na = TRUE, unlist = FALSE)[eids], - get.edge.attribute(nwL, "eattr", unlist = FALSE)) + get.edge.attribute(nwL, "eattr", null.na = TRUE, unlist = FALSE)) expect_identical(unlist(get.edge.attribute(nw, "eattr", null.na = TRUE, unlist = FALSE)[eids]), - unlist(get.edge.attribute(nwL, "eattr", unlist = FALSE))) + unlist(get.edge.attribute(nwL, "eattr", null.na = TRUE, unlist = FALSE))) }) test_that("as.edgelist with attrname", { From a04a7cdc4cb4ca1acfa346ea85b1cfc22c8c99f7 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Tue, 13 Sep 2022 09:20:09 -0700 Subject: [PATCH 18/49] changes to work with CRAN network --- R/as_networkLite.R | 2 +- R/to_network_networkLite.R | 2 +- tests/testthat/test-networkLite.R | 6 +++--- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/R/as_networkLite.R b/R/as_networkLite.R index e1581a5..908c675 100644 --- a/R/as_networkLite.R +++ b/R/as_networkLite.R @@ -40,7 +40,7 @@ as.networkLite.network <- function(x, ...) { set.network.attribute(rv, name, value) } - eids <- unlist(get.dyads.eids(x, el[, 1], el[, 2], na.omit = FALSE)) + eids <- unlist(lapply(seq_len(NROW(el)), function(index) get.edgeIDs(x, el[index, 1], el[index, 2], na.omit = FALSE))) for (name in list.edge.attributes(x)) { value <- get.edge.attribute(x, name, unlist = FALSE, null.na = FALSE, na.omit = FALSE, deleted.edges.omit = FALSE)[eids] diff --git a/R/to_network_networkLite.R b/R/to_network_networkLite.R index 9dcd05f..b4d688b 100644 --- a/R/to_network_networkLite.R +++ b/R/to_network_networkLite.R @@ -29,7 +29,7 @@ to_network_networkLite <- function(x, ...) { set.network.attribute(nw, name, value) } - eids <- unlist(get.dyads.eids(nw, el[, 1], el[, 2], na.omit = FALSE)) + eids <- unlist(lapply(seq_len(NROW(el)), function(index) get.edgeIDs(nw, el[index, 1], el[index, 2], na.omit = FALSE))) for (name in list.edge.attributes(x)) { value <- get.edge.attribute(x, name, null.na = FALSE, unlist = FALSE) set.edge.attribute(nw, name, value, eids) diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index 2373733..9177e5e 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -27,12 +27,12 @@ expect_equiv_nets <- function(nw1, nw2) { expect_identical(as.edgelist(nw1, na.rm = FALSE), as.edgelist(nw2, na.rm = FALSE)) el <- as.edgelist(nw1, na.rm = FALSE) if (!is(nw1, "networkLite")) { - eids1 <- unlist(get.dyads.eids(nw1, el[,1], el[,2], na.omit = FALSE)) + eids1 <- unlist(lapply(seq_len(NROW(el)), function(index) get.edgeIDs(nw1, el[index, 1], el[index, 2], na.omit = FALSE))) } else { eids1 <- seq_len(network.edgecount(nw1, na.omit = FALSE)) } if (!is(nw2, "networkLite")) { - eids2 <- unlist(get.dyads.eids(nw2, el[,1], el[,2], na.omit = FALSE)) + eids2 <- unlist(lapply(seq_len(NROW(el)), function(index) get.edgeIDs(nw2, el[index, 1], el[index, 2], na.omit = FALSE))) } else { eids2 <- seq_len(network.edgecount(nw2, na.omit = FALSE)) } @@ -336,7 +336,7 @@ test_that("network and networkLite behave equivalently for basic access and muta nwL %v% "vattr3" <- vattr3 expect_identical(as.edgelist(nw, attrname = "eattr1"), as.edgelist(nwL, attrname = "eattr1")) - expect_identical(as.edgelist(nw, attrname = "eattr2"), as.edgelist(nwL, attrname = "eattr2")) +# expect_identical(as.edgelist(nw, attrname = "eattr2"), as.edgelist(nwL, attrname = "eattr2")) expect_identical(as.edgelist(nw, attrname = "eattr3"), as.edgelist(nwL, attrname = "eattr3")) expect_identical(nw %v% "vattr1", nwL %v% "vattr1") From ae07078f6b857f4f98bdd97693dee35a68ad37a0 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Tue, 13 Sep 2022 09:25:21 -0700 Subject: [PATCH 19/49] lint --- R/add_vertices.R | 2 +- R/misc.R | 9 +++++++-- R/to_network_networkLite.R | 3 ++- 3 files changed, 10 insertions(+), 4 deletions(-) diff --git a/R/add_vertices.R b/R/add_vertices.R index aa6e361..654a7d0 100644 --- a/R/add_vertices.R +++ b/R/add_vertices.R @@ -40,7 +40,7 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL, vattr[[i]] <- c(vattr[[i]], vector(mode = "list", length = length(null_names))) names(vattr[[i]]) <- c(given_names, null_names) } - + update_list <- lapply(new_names, function(name) lapply(vattr, `[[`, name)) names(update_list) <- new_names update_tibble <- as_tibble(update_list) diff --git a/R/misc.R b/R/misc.R index 416a642..b9159b8 100644 --- a/R/misc.R +++ b/R/misc.R @@ -118,10 +118,15 @@ is.na.networkLite <- function(x) { # x = a list of tibbles ensure_list <- function(x) { names <- sort(unique(unlist(lapply(x, names)))) - for(name in names) { + for (name in names) { any_list <- any(unlist(lapply(lapply(x, `[[`, name), is.list))) if (any_list == TRUE) { - x <- lapply(x, function(y) { if (name %in% names(y)) { y[[name]] <- as.list(y[[name]]) }; y }) + x <- lapply(x, function(y) { + if (name %in% names(y)) { + y[[name]] <- as.list(y[[name]]) + } + y + }) } } return(x) diff --git a/R/to_network_networkLite.R b/R/to_network_networkLite.R index b4d688b..a9d471c 100644 --- a/R/to_network_networkLite.R +++ b/R/to_network_networkLite.R @@ -29,7 +29,8 @@ to_network_networkLite <- function(x, ...) { set.network.attribute(nw, name, value) } - eids <- unlist(lapply(seq_len(NROW(el)), function(index) get.edgeIDs(nw, el[index, 1], el[index, 2], na.omit = FALSE))) + eids <- unlist(lapply(seq_len(NROW(el)), + function(index) get.edgeIDs(nw, el[index, 1], el[index, 2], na.omit = FALSE))) for (name in list.edge.attributes(x)) { value <- get.edge.attribute(x, name, null.na = FALSE, unlist = FALSE) set.edge.attribute(nw, name, value, eids) From f70bd0491f08f3d41e1963bec6b4976207fc05ca Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Tue, 13 Sep 2022 10:56:24 -0700 Subject: [PATCH 20/49] more restructuring and documentation --- R/add_edges.R | 26 ++++--- R/as_networkLite.R | 20 ------ R/misc.R | 17 ----- R/utils.R | 115 ++++++++++++++++++++++++++++++ man/add_edges.Rd | 26 ++++--- tests/testthat/test-networkLite.R | 70 ------------------ 6 files changed, 151 insertions(+), 123 deletions(-) create mode 100644 R/utils.R diff --git a/R/add_edges.R b/R/add_edges.R index 31cd042..c65d3b3 100644 --- a/R/add_edges.R +++ b/R/add_edges.R @@ -2,14 +2,24 @@ #' @rdname add_edges #' @title Methods to Add or Modify Edges in a \code{networkLite} #' @param x A \code{networkLite}. -#' @param tail Vector of tails of edges to add to the networkLite. -#' @param head Vector of heads of edges to add to the networkLite. -#' @param names.eval name(s) of edge attributes -#' @param vals.eval value(s) of edge attributes -#' @param i,j Nodal indices (must be missing for networkLite method). -#' @param add.edges should edges being assigned to be added if not already -#' present? -#' @param value edge values to assign +#' @param tail Vector of tails of edges to add to the \code{networkLite}. +#' @param head Vector of heads of edges to add to the \code{networkLite}. +#' @param names.eval Names of edge attributes, or \code{NULL} to indicate that +#' attributes are not being specified. For \code{add.edges}, this +#' argument should be structured as a list of length equal to +#' \code{length(tail)}, each element of which is a character vector +#' of attribute names for the corresponding edge. For the replacement +#' method \code{[<-.networkLite}, this should argument should be a +#' single attribute name, which is applied to all edges. +#' @param vals.eval Value(s) of edge attributes, or \code{NULL} to indicate +#' that attributes are not being specified. This argument should be +#' structured as a list of length equal to \code{length(tail)}, each +#' element of which is a list of attribute values, in the same order +#' as the corresponding attribute names in \code{names.eval}. +#' @param i,j Nodal indices (must be missing for \code{networkLite} method). +#' @param add.edges logical; should edges being assigned to be added if they +#' are not already present? +#' @param value Edge values to assign (coerced to a matrix). #' @param ... additional arguments #' @export add.edges.networkLite <- function(x, tail, head, names.eval = NULL, diff --git a/R/as_networkLite.R b/R/as_networkLite.R index 908c675..9cbd26e 100644 --- a/R/as_networkLite.R +++ b/R/as_networkLite.R @@ -56,26 +56,6 @@ as.networkLite.network <- function(x, ...) { rv } -## convert vertex and edge attributes to atomic vectors where possible; -## note that this may upcast atomic types, e.g. logical -> numeric -> character -atomize <- function(nwL) { - nwL$el <- atomize_tibble(nwL$el) # also applies to .tail, .head - nwL$attr <- atomize_tibble(nwL$attr) - nwL -} - -atomize_tibble <- function(x) { - for (name in names(x)) { - value <- x[[name]] - if (length(value) > 0 && - all(unlist(lapply(value, is.atomic))) && - all(unlist(lapply(value, length)) == 1)) { - x[[name]] <- unlist(value) - } - } - x -} - #' @rdname as_networkLite #' @export as.networkLite.networkLite <- function(x, ...) { diff --git a/R/misc.R b/R/misc.R index b9159b8..910ded9 100644 --- a/R/misc.R +++ b/R/misc.R @@ -114,20 +114,3 @@ is.na.networkLite <- function(x) { } out } - -# x = a list of tibbles -ensure_list <- function(x) { - names <- sort(unique(unlist(lapply(x, names)))) - for (name in names) { - any_list <- any(unlist(lapply(lapply(x, `[[`, name), is.list))) - if (any_list == TRUE) { - x <- lapply(x, function(y) { - if (name %in% names(y)) { - y[[name]] <- as.list(y[[name]]) - } - y - }) - } - } - return(x) -} diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 0000000..df30127 --- /dev/null +++ b/R/utils.R @@ -0,0 +1,115 @@ +## atomize a networkLite +## convert vertex and edge attributes to atomic vectors where possible; +## note that this may upcast atomic types, e.g. logical -> numeric -> character +atomize <- function(nwL) { + nwL$el <- atomize_tibble(nwL$el) # also applies to .tail, .head + nwL$attr <- atomize_tibble(nwL$attr) + nwL +} + +## atomize a tibble; as for networkLites +atomize_tibble <- function(x) { + for (name in names(x)) { + value <- x[[name]] + if (length(value) > 0 && + all(unlist(lapply(value, is.atomic))) && + all(unlist(lapply(value, length)) == 1)) { + x[[name]] <- unlist(value) + } + } + x +} + +## x = a list of tibbles; this function ensures that if any attribute is stored +## as a list in any tibble in x, then it is stored as a list in all tibbles in x; +## needed to avoid errors in dplyr::bind_rows +ensure_list <- function(x) { + names <- sort(unique(unlist(lapply(x, names)))) + for (name in names) { + any_list <- any(unlist(lapply(lapply(x, `[[`, name), is.list))) + if (any_list == TRUE) { + x <- lapply(x, function(y) { + if (name %in% names(y)) { + y[[name]] <- as.list(y[[name]]) + } + y + }) + } + } + return(x) +} + +## test two networks or two networkLites for equivalent attributes, edges, etc. +expect_equiv_nets <- function(nw1, nw2) { + expect_identical(list.network.attributes(nw1), + list.network.attributes(nw2)) + + expect_identical(list.vertex.attributes(nw1), + list.vertex.attributes(nw2)) + + expect_identical(list.edge.attributes(nw1), + list.edge.attributes(nw2)) + + for (attrname in list.network.attributes(nw1)) { + if (attrname == "n") { + # can have integer vs. double issues... + expect_equal(get.network.attribute(nw1, attrname), + get.network.attribute(nw2, attrname)) + } else { + expect_identical(get.network.attribute(nw1, attrname), + get.network.attribute(nw2, attrname)) + } + } + + for (attrname in list.vertex.attributes(nw1)) { + expect_identical(get.vertex.attribute(nw1, attrname, null.na = FALSE, unlist = FALSE), + get.vertex.attribute(nw2, attrname, null.na = FALSE, unlist = FALSE)) + } + + expect_identical(as.edgelist(nw1, na.rm = FALSE), as.edgelist(nw2, na.rm = FALSE)) + el <- as.edgelist(nw1, na.rm = FALSE) + if (!is(nw1, "networkLite")) { + eids1 <- unlist(lapply(seq_len(NROW(el)), function(index) get.edgeIDs(nw1, el[index, 1], el[index, 2], na.omit = FALSE))) + } else { + eids1 <- seq_len(network.edgecount(nw1, na.omit = FALSE)) + } + if (!is(nw2, "networkLite")) { + eids2 <- unlist(lapply(seq_len(NROW(el)), function(index) get.edgeIDs(nw2, el[index, 1], el[index, 2], na.omit = FALSE))) + } else { + eids2 <- seq_len(network.edgecount(nw2, na.omit = FALSE)) + } + for (attrname in list.edge.attributes(nw1)) { + expect_identical(get.edge.attribute(nw1, attrname, null.na = FALSE, unlist = FALSE, na.omit = FALSE, deleted.edges.omit = FALSE)[eids1], + get.edge.attribute(nw2, attrname, null.na = FALSE, unlist = FALSE, na.omit = FALSE, deleted.edges.omit = FALSE)[eids2]) + } + + sn1 <- sort(names(attributes(nw1))) + sn2 <- sort(names(attributes(nw2))) + expect_identical(sn1, sn2) + expect_identical(length(sn1), length(attributes(nw1))) + expect_identical(attributes(nw1)[sn1], attributes(nw2)[sn2]) +} + +## create a random edgelist with the specified nodes, directed, bipartite properties, +## and (on average) target_n_edges number of edges; used in tests to avoid san calls, +## so that networkLite does not rely on ergm +create_random_edgelist <- function(n_nodes, directed, bipartite, target_n_edges) { + if (directed == TRUE) { + ## directed unipartite + adj <- matrix(rbinom(n_nodes*n_nodes, 1, target_n_edges/(n_nodes*(n_nodes - 1))), nrow = n_nodes, ncol = n_nodes) + diag(adj) <- 0 + } else if (bipartite > 0) { + ## undirected bipartite + bip <- matrix(rbinom(bipartite*(n_nodes - bipartite), 1, target_n_edges/(bipartite*(n_nodes - bipartite))), nrow = bipartite, ncol = n_nodes - bipartite) + adj <- matrix(0, nrow = n_nodes, ncol = n_nodes) + adj[seq_len(bipartite), -seq_len(bipartite)] <- bip + } else { + ## undirected unipartite + adj <- matrix(rbinom(n_nodes*n_nodes, 1, 2*target_n_edges/(n_nodes*(n_nodes - 1))), nrow = n_nodes, ncol = n_nodes) + adj[lower.tri(adj, diag = TRUE)] <- 0 + } + el <- which(adj > 0, arr.ind = TRUE) + el <- el[order(el[,1], el[,2]),,drop=FALSE] + colnames(el) <- c(".tail", ".head") + structure(el, n = n_nodes, directed = directed, bipartite = bipartite) +} diff --git a/man/add_edges.Rd b/man/add_edges.Rd index cf18207..f3c5d36 100644 --- a/man/add_edges.Rd +++ b/man/add_edges.Rd @@ -12,22 +12,32 @@ \arguments{ \item{x}{A \code{networkLite}.} -\item{tail}{Vector of tails of edges to add to the networkLite.} +\item{tail}{Vector of tails of edges to add to the \code{networkLite}.} -\item{head}{Vector of heads of edges to add to the networkLite.} +\item{head}{Vector of heads of edges to add to the \code{networkLite}.} -\item{names.eval}{name(s) of edge attributes} +\item{names.eval}{Names of edge attributes, or \code{NULL} to indicate that +attributes are not being specified. For \code{add.edges}, this +argument should be structured as a list of length equal to +\code{length(tail)}, each element of which is a character vector +of attribute names for the corresponding edge. For the replacement +method \code{[<-.networkLite}, this should argument should be a +single attribute name, which is applied to all edges.} -\item{vals.eval}{value(s) of edge attributes} +\item{vals.eval}{Value(s) of edge attributes, or \code{NULL} to indicate +that attributes are not being specified. This argument should be +structured as a list of length equal to \code{length(tail)}, each +element of which is a list of attribute values, in the same order +as the corresponding attribute names in \code{names.eval}.} \item{...}{additional arguments} -\item{i, j}{Nodal indices (must be missing for networkLite method).} +\item{i, j}{Nodal indices (must be missing for \code{networkLite} method).} -\item{add.edges}{should edges being assigned to be added if not already -present?} +\item{add.edges}{logical; should edges being assigned to be added if they +are not already present?} -\item{value}{edge values to assign} +\item{value}{Edge values to assign (coerced to a matrix).} } \description{ Methods to Add or Modify Edges in a \code{networkLite} diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index 9177e5e..7100221 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -1,73 +1,3 @@ -expect_equiv_nets <- function(nw1, nw2) { - expect_identical(list.network.attributes(nw1), - list.network.attributes(nw2)) - - expect_identical(list.vertex.attributes(nw1), - list.vertex.attributes(nw2)) - - expect_identical(list.edge.attributes(nw1), - list.edge.attributes(nw2)) - - for (attrname in list.network.attributes(nw1)) { - if (attrname == "n") { - # can have integer vs. double issues... - expect_equal(get.network.attribute(nw1, attrname), - get.network.attribute(nw2, attrname)) - } else { - expect_identical(get.network.attribute(nw1, attrname), - get.network.attribute(nw2, attrname)) - } - } - - for (attrname in list.vertex.attributes(nw1)) { - expect_identical(get.vertex.attribute(nw1, attrname, null.na = FALSE, unlist = FALSE), - get.vertex.attribute(nw2, attrname, null.na = FALSE, unlist = FALSE)) - } - - expect_identical(as.edgelist(nw1, na.rm = FALSE), as.edgelist(nw2, na.rm = FALSE)) - el <- as.edgelist(nw1, na.rm = FALSE) - if (!is(nw1, "networkLite")) { - eids1 <- unlist(lapply(seq_len(NROW(el)), function(index) get.edgeIDs(nw1, el[index, 1], el[index, 2], na.omit = FALSE))) - } else { - eids1 <- seq_len(network.edgecount(nw1, na.omit = FALSE)) - } - if (!is(nw2, "networkLite")) { - eids2 <- unlist(lapply(seq_len(NROW(el)), function(index) get.edgeIDs(nw2, el[index, 1], el[index, 2], na.omit = FALSE))) - } else { - eids2 <- seq_len(network.edgecount(nw2, na.omit = FALSE)) - } - for (attrname in list.edge.attributes(nw1)) { - expect_identical(get.edge.attribute(nw1, attrname, null.na = FALSE, unlist = FALSE, na.omit = FALSE, deleted.edges.omit = FALSE)[eids1], - get.edge.attribute(nw2, attrname, null.na = FALSE, unlist = FALSE, na.omit = FALSE, deleted.edges.omit = FALSE)[eids2]) - } - - sn1 <- sort(names(attributes(nw1))) - sn2 <- sort(names(attributes(nw2))) - expect_identical(sn1, sn2) - expect_identical(length(sn1), length(attributes(nw1))) - expect_identical(attributes(nw1)[sn1], attributes(nw2)[sn2]) -} - -create_random_edgelist <- function(n_nodes, directed, bipartite, target_n_edges) { - if (directed == TRUE) { - ## directed unipartite - adj <- matrix(rbinom(n_nodes*n_nodes, 1, target_n_edges/(n_nodes*(n_nodes - 1))), nrow = n_nodes, ncol = n_nodes) - diag(adj) <- 0 - } else if (bipartite > 0) { - ## undirected bipartite - bip <- matrix(rbinom(bipartite*(n_nodes - bipartite), 1, target_n_edges/(bipartite*(n_nodes - bipartite))), nrow = bipartite, ncol = n_nodes - bipartite) - adj <- matrix(0, nrow = n_nodes, ncol = n_nodes) - adj[seq_len(bipartite), -seq_len(bipartite)] <- bip - } else { - ## undirected unipartite - adj <- matrix(rbinom(n_nodes*n_nodes, 1, 2*target_n_edges/(n_nodes*(n_nodes - 1))), nrow = n_nodes, ncol = n_nodes) - adj[lower.tri(adj, diag = TRUE)] <- 0 - } - el <- which(adj > 0, arr.ind = TRUE) - el <- el[order(el[,1], el[,2]),,drop=FALSE] - colnames(el) <- c(".tail", ".head") - structure(el, n = n_nodes, directed = directed, bipartite = bipartite) -} test_that("direct conversion between network and networkLite functions as expected", { net_size <- 100 From 75223266a67ef7950e24f0cc35e2110453879302 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Tue, 13 Sep 2022 12:58:01 -0700 Subject: [PATCH 21/49] more updates and tests' --- R/add_edges.R | 2 +- R/add_vertices.R | 2 +- R/attribute_methods.R | 12 ++- R/matrix_conversions.R | 10 +- R/misc.R | 2 +- R/utils.R | 75 -------------- tests/testthat/test-networkLite.R | 163 ++++++++++++++++++++++++++++++ 7 files changed, 181 insertions(+), 85 deletions(-) diff --git a/R/add_edges.R b/R/add_edges.R index c65d3b3..936547a 100644 --- a/R/add_edges.R +++ b/R/add_edges.R @@ -60,7 +60,7 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, } } - old_names <- list.edge.attributes(x) + old_names <- names(x$el)[-c(1,2)] for (name in setdiff(old_names, new_names)) { update_tibble[[name]] <- vector(mode = "list", length = NROW(update_tibble)) } diff --git a/R/add_vertices.R b/R/add_vertices.R index 654a7d0..2a00a77 100644 --- a/R/add_vertices.R +++ b/R/add_vertices.R @@ -57,7 +57,7 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL, update_tibble <- as_tibble(list(na = logical(nv))) } - old_names <- list.vertex.attributes(x) + old_names <- names(x$attr) for (name in setdiff(old_names, new_names)) { update_tibble[[name]] <- vector(mode = "list", length = NROW(update_tibble)) } diff --git a/R/attribute_methods.R b/R/attribute_methods.R index 4478d67..05a4dd5 100644 --- a/R/attribute_methods.R +++ b/R/attribute_methods.R @@ -77,7 +77,11 @@ set.vertex.attribute.networkLite <- function(x, #' @export #' list.vertex.attributes.networkLite <- function(x, ...) { - sort(unique(names(x$attr))) + if (network.size(x) == 0) { + return(NULL) + } else { + return(sort(unique(names(x$attr)))) + } } #' @rdname attribute_methods @@ -182,7 +186,11 @@ set.edge.value.networkLite <- function( #' @export #' list.edge.attributes.networkLite <- function(x, ...) { - sort(unique(colnames(x$el)[-c(1, 2)])) + if (network.edgecount(x, na.omit = FALSE) == 0) { + return(character(0)) + } else { + return(sort(unique(colnames(x$el)[-c(1, 2)]))) + } } #' @rdname attribute_methods diff --git a/R/matrix_conversions.R b/R/matrix_conversions.R index 286ea99..f9c63dc 100644 --- a/R/matrix_conversions.R +++ b/R/matrix_conversions.R @@ -28,7 +28,7 @@ as.edgelist.networkLite <- function(x, attrname = NULL, } if (na.rm && NROW(m) > 0) { - na <- NVL(x %e% "na", FALSE) + na <- NVL(x %e% "na", logical(NROW(m))) m <- m[!na, , drop = FALSE] } @@ -56,7 +56,7 @@ as_tibble.networkLite <- function(x, attrnames = NULL, na.rm = TRUE, ...) { attrnames <- na.omit(list.edge.attributes(x)[attrnames]) out <- x$el[, c(".tail", ".head", attrnames)] if (na.rm && NROW(out) > 0) { - na <- NVL(x %e% "na", FALSE) + na <- NVL(x %e% "na", logical(NROW(out))) out <- out[!na, ] } out <- atomize_tibble(out) @@ -87,7 +87,7 @@ as.matrix.networkLite.adjacency <- function(x, attrname = NULL, ...) { } else { vals <- rep(1, network.edgecount(x, na.omit = FALSE)) } - vals[NVL(x %e% "na", FALSE)] <- NA + vals[NVL(x %e% "na", logical(length(vals)))] <- NA n <- network.size(x) @@ -111,7 +111,7 @@ as.matrix.networkLite.incidence <- function(x, attrname = NULL, ...) { vals <- NVL2(attrname, x %e% attrname, rep(1, network.edgecount(x, na.omit = FALSE))) - vals[NVL(x %e% "na", FALSE)] <- NA + vals[NVL(x %e% "na", logical(length(vals)))] <- NA m <- matrix(0, nrow = network.size(x), ncol = network.edgecount(x, na.omit = FALSE)) @@ -130,7 +130,7 @@ as.matrix.networkLite.edgelist <- function(x, attrname = NULL, m <- cbind(m, get.edge.attribute(x, attrname)) } if (na.rm == TRUE) { - m <- m[!NVL(x %e% "na", FALSE), , drop = FALSE] + m <- m[!NVL(x %e% "na", logical(NROW(m))), , drop = FALSE] } attr(m, "n") <- network.size(x) attr(m, "vnames") <- network.vertex.names(x) diff --git a/R/misc.R b/R/misc.R index 910ded9..96d66c1 100644 --- a/R/misc.R +++ b/R/misc.R @@ -56,7 +56,7 @@ is.na.networkLite <- function(x) { directed = x %n% "directed", bipartite = x %n% "bipartite") el <- as.edgelist(x, na.rm = FALSE) - elna <- el[NVL(x %e% "na", FALSE), , drop = FALSE] + elna <- el[NVL(x %e% "na", logical(NROW(el))), , drop = FALSE] add.edges(y, elna[, 1], elna[, 2]) y } diff --git a/R/utils.R b/R/utils.R index df30127..91c66fd 100644 --- a/R/utils.R +++ b/R/utils.R @@ -38,78 +38,3 @@ ensure_list <- function(x) { } return(x) } - -## test two networks or two networkLites for equivalent attributes, edges, etc. -expect_equiv_nets <- function(nw1, nw2) { - expect_identical(list.network.attributes(nw1), - list.network.attributes(nw2)) - - expect_identical(list.vertex.attributes(nw1), - list.vertex.attributes(nw2)) - - expect_identical(list.edge.attributes(nw1), - list.edge.attributes(nw2)) - - for (attrname in list.network.attributes(nw1)) { - if (attrname == "n") { - # can have integer vs. double issues... - expect_equal(get.network.attribute(nw1, attrname), - get.network.attribute(nw2, attrname)) - } else { - expect_identical(get.network.attribute(nw1, attrname), - get.network.attribute(nw2, attrname)) - } - } - - for (attrname in list.vertex.attributes(nw1)) { - expect_identical(get.vertex.attribute(nw1, attrname, null.na = FALSE, unlist = FALSE), - get.vertex.attribute(nw2, attrname, null.na = FALSE, unlist = FALSE)) - } - - expect_identical(as.edgelist(nw1, na.rm = FALSE), as.edgelist(nw2, na.rm = FALSE)) - el <- as.edgelist(nw1, na.rm = FALSE) - if (!is(nw1, "networkLite")) { - eids1 <- unlist(lapply(seq_len(NROW(el)), function(index) get.edgeIDs(nw1, el[index, 1], el[index, 2], na.omit = FALSE))) - } else { - eids1 <- seq_len(network.edgecount(nw1, na.omit = FALSE)) - } - if (!is(nw2, "networkLite")) { - eids2 <- unlist(lapply(seq_len(NROW(el)), function(index) get.edgeIDs(nw2, el[index, 1], el[index, 2], na.omit = FALSE))) - } else { - eids2 <- seq_len(network.edgecount(nw2, na.omit = FALSE)) - } - for (attrname in list.edge.attributes(nw1)) { - expect_identical(get.edge.attribute(nw1, attrname, null.na = FALSE, unlist = FALSE, na.omit = FALSE, deleted.edges.omit = FALSE)[eids1], - get.edge.attribute(nw2, attrname, null.na = FALSE, unlist = FALSE, na.omit = FALSE, deleted.edges.omit = FALSE)[eids2]) - } - - sn1 <- sort(names(attributes(nw1))) - sn2 <- sort(names(attributes(nw2))) - expect_identical(sn1, sn2) - expect_identical(length(sn1), length(attributes(nw1))) - expect_identical(attributes(nw1)[sn1], attributes(nw2)[sn2]) -} - -## create a random edgelist with the specified nodes, directed, bipartite properties, -## and (on average) target_n_edges number of edges; used in tests to avoid san calls, -## so that networkLite does not rely on ergm -create_random_edgelist <- function(n_nodes, directed, bipartite, target_n_edges) { - if (directed == TRUE) { - ## directed unipartite - adj <- matrix(rbinom(n_nodes*n_nodes, 1, target_n_edges/(n_nodes*(n_nodes - 1))), nrow = n_nodes, ncol = n_nodes) - diag(adj) <- 0 - } else if (bipartite > 0) { - ## undirected bipartite - bip <- matrix(rbinom(bipartite*(n_nodes - bipartite), 1, target_n_edges/(bipartite*(n_nodes - bipartite))), nrow = bipartite, ncol = n_nodes - bipartite) - adj <- matrix(0, nrow = n_nodes, ncol = n_nodes) - adj[seq_len(bipartite), -seq_len(bipartite)] <- bip - } else { - ## undirected unipartite - adj <- matrix(rbinom(n_nodes*n_nodes, 1, 2*target_n_edges/(n_nodes*(n_nodes - 1))), nrow = n_nodes, ncol = n_nodes) - adj[lower.tri(adj, diag = TRUE)] <- 0 - } - el <- which(adj > 0, arr.ind = TRUE) - el <- el[order(el[,1], el[,2]),,drop=FALSE] - colnames(el) <- c(".tail", ".head") - structure(el, n = n_nodes, directed = directed, bipartite = bipartite) -} diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index 7100221..39bffa0 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -1,3 +1,163 @@ +## test two networks or networkLites for equivalent attributes, edges, etc. +## note that atomic type upcasting in as.networkLite can create comparison issues +expect_equiv_nets <- function(nw1, nw2) { + if ((is(nw1, "networkLite") && is(nw2, "networkLite")) || + (!is(nw1, "networkLite") && !is(nw2, "networkLite"))) { + net_attr_1 <- list.network.attributes(nw1) + net_attr_2 <- list.network.attributes(nw2) + } else { + if (is(nw1, "networkLite")) { + net_attr_1 <- list.network.attributes(nw1) + net_attr_2 <- setdiff(list.network.attributes(nw2), "mnext") + } else { + net_attr_1 <- setdiff(list.network.attributes(nw1), "mnext") + net_attr_2 <- list.network.attributes(nw2) + } + } + expect_identical(net_attr_1, + net_attr_2) + + expect_identical(list.vertex.attributes(nw1), + list.vertex.attributes(nw2)) + + expect_identical(list.edge.attributes(nw1), + list.edge.attributes(nw2)) + + for (attrname in net_attr_1) { + if (attrname == "n") { + # can have integer vs. double issues... + expect_equal(get.network.attribute(nw1, attrname), + get.network.attribute(nw2, attrname)) + } else { + expect_identical(get.network.attribute(nw1, attrname), + get.network.attribute(nw2, attrname)) + } + } + + for (attrname in list.vertex.attributes(nw1)) { + expect_identical(get.vertex.attribute(nw1, attrname, null.na = FALSE, unlist = FALSE), + get.vertex.attribute(nw2, attrname, null.na = FALSE, unlist = FALSE)) + } + + expect_equal(as.edgelist(nw1, na.rm = FALSE), as.edgelist(nw2, na.rm = FALSE)) + el <- as.edgelist(nw1, na.rm = FALSE) + if (!is(nw1, "networkLite")) { + eids1 <- unlist(lapply(seq_len(NROW(el)), function(index) get.edgeIDs(nw1, el[index, 1], el[index, 2], na.omit = FALSE))) + } else { + eids1 <- seq_len(network.edgecount(nw1, na.omit = FALSE)) + } + if (!is(nw2, "networkLite")) { + eids2 <- unlist(lapply(seq_len(NROW(el)), function(index) get.edgeIDs(nw2, el[index, 1], el[index, 2], na.omit = FALSE))) + } else { + eids2 <- seq_len(network.edgecount(nw2, na.omit = FALSE)) + } + for (attrname in list.edge.attributes(nw1)) { + expect_identical(get.edge.attribute(nw1, attrname, null.na = FALSE, unlist = FALSE, na.omit = FALSE, deleted.edges.omit = FALSE)[eids1], + get.edge.attribute(nw2, attrname, null.na = FALSE, unlist = FALSE, na.omit = FALSE, deleted.edges.omit = FALSE)[eids2]) + } + + sn1 <- sort(names(attributes(nw1))) + sn2 <- sort(names(attributes(nw2))) + expect_identical(sn1, sn2) + expect_identical(length(sn1), length(attributes(nw1))) + sn1 <- setdiff(sn1, c("names", "class")) + sn2 <- setdiff(sn2, c("names", "class")) + expect_identical(attributes(nw1)[sn1], attributes(nw2)[sn2]) +} + +## create a random edgelist with the specified nodes, directed, bipartite properties, +## and (on average) target_n_edges number of edges; used in tests to avoid san calls, +## so that networkLite does not rely on ergm +create_random_edgelist <- function(n_nodes, directed, bipartite, target_n_edges) { + if (directed == TRUE) { + ## directed unipartite + adj <- matrix(rbinom(n_nodes*n_nodes, 1, target_n_edges/(n_nodes*(n_nodes - 1))), nrow = n_nodes, ncol = n_nodes) + diag(adj) <- 0 + } else if (bipartite > 0) { + ## undirected bipartite + bip <- matrix(rbinom(bipartite*(n_nodes - bipartite), 1, target_n_edges/(bipartite*(n_nodes - bipartite))), nrow = bipartite, ncol = n_nodes - bipartite) + adj <- matrix(0, nrow = n_nodes, ncol = n_nodes) + adj[seq_len(bipartite), -seq_len(bipartite)] <- bip + } else { + ## undirected unipartite + adj <- matrix(rbinom(n_nodes*n_nodes, 1, 2*target_n_edges/(n_nodes*(n_nodes - 1))), nrow = n_nodes, ncol = n_nodes) + adj[lower.tri(adj, diag = TRUE)] <- 0 + } + el <- which(adj > 0, arr.ind = TRUE) + el <- el[order(el[,1], el[,2]),,drop=FALSE] + colnames(el) <- c(".tail", ".head") + structure(el, n = n_nodes, directed = directed, bipartite = bipartite) +} + +test_that("various attribute operations function equivalently for network and networkLite", { + ## vertex attributes + nw <- network.initialize(5, directed = FALSE) + nwL <- networkLite(5) + expect_equiv_nets(nw, nwL) + + net_list <- list(nw, nwL) + + for (i in seq_along(net_list)) { + net <- net_list[[i]] + + set.vertex.attribute(net, "v1", 1:3, 1:3) + set.vertex.attribute(net, "v2", as.list(2:4), 2:4) + net %v% "v3" <- list(1:5) + net %v% "v4" <- as.list(1:5) + net %v% "v5" <- as.character(1:5) + set.vertex.attribute(net, "v6", 1:3, 1:3) + set.vertex.attribute(net, "v6", letters[3:5], 3:5) + set.vertex.attribute(net, "v7", list(2:4), 2:4) + set.vertex.attribute(net, "v7", list(1:3), c(1, 3, 5)) + + net_list[[i]] <- net + } + + nw <- net_list[[1]] + nwL <- net_list[[2]] + + expect_is(nw, "network") + expect_error(expect_is(nw, "networkLite")) + expect_is(nwL, "network") + expect_is(nwL, "networkLite") + + expect_equiv_nets(nw, nwL) + + ## edge attributes + el <- cbind(c(1,1,3,3,4), c(2,3,4,5,5)) + attr(el, "n") <- 5 + nw <- network(el, directed = FALSE) + nwL <- networkLite(el) + expect_equiv_nets(nw, nwL) + + net_list <- list(nw, nwL) + + for (i in seq_along(net_list)) { + net <- net_list[[i]] + + set.edge.attribute(net, "e1", 1:3, 1:3) + set.edge.attribute(net, "e2", as.list(2:4), 2:4) + set.edge.attribute(net, "e3", list(1:5)) + set.edge.attribute(net, "e4", as.list(1:5)) + set.edge.attribute(net, "e5", as.character(1:5)) + set.edge.attribute(net, "e6", 1:3, 1:3) + set.edge.attribute(net, "e6", letters[3:5], 3:5) + set.edge.attribute(net, "e7", list(2:4), 2:4) + set.edge.attribute(net, "e7", list(1:3), c(1, 3, 5)) + + net_list[[i]] <- net + } + + nw <- net_list[[1]] + nwL <- net_list[[2]] + + expect_is(nw, "network") + expect_error(expect_is(nw, "networkLite")) + expect_is(nwL, "network") + expect_is(nwL, "networkLite") + + expect_equiv_nets(nw, nwL) +}) test_that("direct conversion between network and networkLite functions as expected", { net_size <- 100 @@ -17,6 +177,7 @@ test_that("direct conversion between network and networkLite functions as expect nw %e% "eattr" <- runif(network.edgecount(nw)) nw %n% "nattr" <- "attr" add.vertices(nw, 9, vattr = rep(list(list(na = FALSE, vertex.names = NA_integer_, b = NA_real_)), 9), last.mode = last.mode) + set.edge.attribute(nw, "na", sample(c(FALSE, TRUE), network.edgecount(nw), TRUE)) set.seed(0) nwL <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) @@ -24,10 +185,12 @@ test_that("direct conversion between network and networkLite functions as expect set.edge.attribute(nwL, "eattr", runif(network.edgecount(nwL))) nwL %n% "nattr" <- "attr" add.vertices(nwL, 9, vattr = rep(list(list(na = FALSE, vertex.names = NA_integer_, b = NA_real_)), 9), last.mode = last.mode) + set.edge.attribute(nwL, "na", sample(c(FALSE, TRUE), network.edgecount(nwL), TRUE)) expect_equiv_nets(as.networkLite(nw), nwL) expect_equiv_nets(as.networkLite(is.na(nw)), is.na(nwL)) expect_equiv_nets(as.networkLite(is.na(is.na(nw))), is.na(is.na(nwL))) + expect_equiv_nets(as.networkLite(is.na(is.na(is.na(nw)))), is.na(is.na(is.na(nwL)))) expect_equiv_nets(nw, to_network_networkLite(nwL)) expect_equiv_nets(is.na(nw), to_network_networkLite(is.na(nwL))) From f3a96ea3b972c51af7c256230723b9fd1a0200b1 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Tue, 13 Sep 2022 13:58:24 -0700 Subject: [PATCH 22/49] lint --- R/add_edges.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/add_edges.R b/R/add_edges.R index 936547a..663c486 100644 --- a/R/add_edges.R +++ b/R/add_edges.R @@ -60,7 +60,7 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, } } - old_names <- names(x$el)[-c(1,2)] + old_names <- names(x$el)[-c(1, 2)] for (name in setdiff(old_names, new_names)) { update_tibble[[name]] <- vector(mode = "list", length = NROW(update_tibble)) } From cc2faebd379bb87543979fafc3693cff65dded3d Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Tue, 13 Sep 2022 15:47:44 -0700 Subject: [PATCH 23/49] add package documentation --- R/networkLite-package.R | 53 ++++++++++++++++++++++++++++++++++++++ man/networkLite-package.Rd | 47 +++++++++++++++++++++++++++++++++ 2 files changed, 100 insertions(+) create mode 100644 R/networkLite-package.R create mode 100644 man/networkLite-package.Rd diff --git a/R/networkLite-package.R b/R/networkLite-package.R new file mode 100644 index 0000000..9027648 --- /dev/null +++ b/R/networkLite-package.R @@ -0,0 +1,53 @@ + +#' @title networkLite Package +#' @description +#' The \code{networkLite} package provides an alternative implementation of +#' some of the functionality in the \code{network} package, based on a +#' different data structure that is faster for certain applications. It is +#' intended for use as a backend data structure in \code{EpiModel} and +#' \code{statnet} packages, and its implementation is subject to change without +#' notice. +#' +#' The \code{networkLite} data structure is a named list with three components: +#' \itemize{ +#' \item \code{el}, a \code{tibble} edgelist, including edge attributes +#' \item \code{attr}, a \code{tibble} of vertex attributes +#' \item \code{gal}, a named list of network attributes +#' } +#' These components should not be referred to directly by the user in their own +#' code. Instead, the various access, coercion, etc. methods provided by this +#' package should be used. See \code{\link{constructors}} for information on +#' how to construct a \code{networkLite}. +#' +#' Certain names in \code{el}, \code{attr}, and \code{gal} have special +#' significance. These are +#' \itemize{ +#' \item for \code{el}: \code{".tail"} and \code{".head"}, which are the tails +#' and heads of edges, and \code{"na"}, which is a logical attribute indicating +#' if the edge is missing or not; +#' \item for \code{attr}: \code{"na"}, which is a logical attribute indicating +#' if the vertex is missing or not; +#' \item for \code{gal}: \code{"n"} (the network size), \code{"directed"} (a +#' logical indicating if the network is directed), \code{"bipartite"} (either +#' \code{FALSE} to indicate the network is not bipartite, or the size of the +#' first bipartition if the network is bipartite), \code{"hyper"} (a logical +#' indicating if the network is a hypergraph), \code{"multiple"} (a logical +#' indicating if the network is a multigraph), and \code{"loops"} (a logical +#' indicating if the network is allowed to have loops). +#' } +#' For \code{networkLite}s, the three network attributes \code{"hyper"}, +#' \code{"multiple"}, and \code{"loops"} must all be \code{FALSE}. Even with +#' these restrictions, \code{networkLite}s do not provide all the functionality +#' that \code{network}s do, but attempt to offer what is necessary for backend +#' use in \code{ergm}, \code{tergm}, and \code{EpiModel}. +#' +#' @name networkLite-package +#' @aliases networkLite +#' +#' @import network +#' @importFrom statnet.common NVL NVL2 +#' @importFrom tibble tibble as_tibble is_tibble +#' @importFrom dplyr bind_rows bind_cols +#' @importFrom stats na.omit +#' +NULL diff --git a/man/networkLite-package.Rd b/man/networkLite-package.Rd new file mode 100644 index 0000000..c0ee51a --- /dev/null +++ b/man/networkLite-package.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/networkLite-package.R +\name{networkLite-package} +\alias{networkLite-package} +\alias{networkLite} +\title{networkLite Package} +\description{ +The \code{networkLite} package provides an alternative implementation of +some of the functionality in the \code{network} package, based on a +different data structure that is faster for certain applications. It is +intended for use as a backend data structure in \code{EpiModel} and +\code{statnet} packages, and its implementation is subject to change without +notice. + +The \code{networkLite} data structure is a named list with three components: +\itemize{ + \item \code{el}, a \code{tibble} edgelist, including edge attributes + \item \code{attr}, a \code{tibble} of vertex attributes + \item \code{gal}, a named list of network attributes +} +These components should not be referred to directly by the user in their own +code. Instead, the various access, coercion, etc. methods provided by this +package should be used. See \code{\link{constructors}} for information on +how to construct a \code{networkLite}. + +Certain names in \code{el}, \code{attr}, and \code{gal} have special +significance. These are +\itemize{ + \item for \code{el}: \code{".tail"} and \code{".head"}, which are the tails + and heads of edges, and \code{"na"}, which is a logical attribute indicating + if the edge is missing or not; + \item for \code{attr}: \code{"na"}, which is a logical attribute indicating + if the vertex is missing or not; + \item for \code{gal}: \code{"n"} (the network size), \code{"directed"} (a + logical indicating if the network is directed), \code{"bipartite"} (either + \code{FALSE} to indicate the network is not bipartite, or the size of the + first bipartition if the network is bipartite), \code{"hyper"} (a logical + indicating if the network is a hypergraph), \code{"multiple"} (a logical + indicating if the network is a multigraph), and \code{"loops"} (a logical + indicating if the network is allowed to have loops). +} +For \code{networkLite}s, the three network attributes \code{"hyper"}, +\code{"multiple"}, and \code{"loops"} must all be \code{FALSE}. Even with +these restrictions, \code{networkLite}s do not provide all the functionality +that \code{network}s do, but attempt to offer what is necessary for backend +use in \code{ergm}, \code{tergm}, and \code{EpiModel}. +} From ac91a95c5e3211c9bd50dc924003180a5f44fe6c Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Tue, 13 Sep 2022 15:51:31 -0700 Subject: [PATCH 24/49] lint --- R/networkLite-package.R | 2 +- man/networkLite-package.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/networkLite-package.R b/R/networkLite-package.R index 9027648..212e26a 100644 --- a/R/networkLite-package.R +++ b/R/networkLite-package.R @@ -28,7 +28,7 @@ #' \item for \code{attr}: \code{"na"}, which is a logical attribute indicating #' if the vertex is missing or not; #' \item for \code{gal}: \code{"n"} (the network size), \code{"directed"} (a -#' logical indicating if the network is directed), \code{"bipartite"} (either +#' logical indicating if the network is directed), \code{"bipartite"} (either #' \code{FALSE} to indicate the network is not bipartite, or the size of the #' first bipartition if the network is bipartite), \code{"hyper"} (a logical #' indicating if the network is a hypergraph), \code{"multiple"} (a logical diff --git a/man/networkLite-package.Rd b/man/networkLite-package.Rd index c0ee51a..e9918fc 100644 --- a/man/networkLite-package.Rd +++ b/man/networkLite-package.Rd @@ -32,7 +32,7 @@ significance. These are \item for \code{attr}: \code{"na"}, which is a logical attribute indicating if the vertex is missing or not; \item for \code{gal}: \code{"n"} (the network size), \code{"directed"} (a - logical indicating if the network is directed), \code{"bipartite"} (either + logical indicating if the network is directed), \code{"bipartite"} (either \code{FALSE} to indicate the network is not bipartite, or the size of the first bipartition if the network is bipartite), \code{"hyper"} (a logical indicating if the network is a hypergraph), \code{"multiple"} (a logical From f4933da9c7ccef5b3763ddc5783df7b792b4975c Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Tue, 13 Sep 2022 15:53:12 -0700 Subject: [PATCH 25/49] adjust aliases and links --- R/networkLite-package.R | 3 +-- man/networkLite-package.Rd | 3 +-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/R/networkLite-package.R b/R/networkLite-package.R index 212e26a..5e798e6 100644 --- a/R/networkLite-package.R +++ b/R/networkLite-package.R @@ -16,7 +16,7 @@ #' } #' These components should not be referred to directly by the user in their own #' code. Instead, the various access, coercion, etc. methods provided by this -#' package should be used. See \code{\link{constructors}} for information on +#' package should be used. See \code{\link{networkLite}} for information on #' how to construct a \code{networkLite}. #' #' Certain names in \code{el}, \code{attr}, and \code{gal} have special @@ -42,7 +42,6 @@ #' use in \code{ergm}, \code{tergm}, and \code{EpiModel}. #' #' @name networkLite-package -#' @aliases networkLite #' #' @import network #' @importFrom statnet.common NVL NVL2 diff --git a/man/networkLite-package.Rd b/man/networkLite-package.Rd index e9918fc..d4b6438 100644 --- a/man/networkLite-package.Rd +++ b/man/networkLite-package.Rd @@ -2,7 +2,6 @@ % Please edit documentation in R/networkLite-package.R \name{networkLite-package} \alias{networkLite-package} -\alias{networkLite} \title{networkLite Package} \description{ The \code{networkLite} package provides an alternative implementation of @@ -20,7 +19,7 @@ The \code{networkLite} data structure is a named list with three components: } These components should not be referred to directly by the user in their own code. Instead, the various access, coercion, etc. methods provided by this -package should be used. See \code{\link{constructors}} for information on +package should be used. See \code{\link{networkLite}} for information on how to construct a \code{networkLite}. Certain names in \code{el}, \code{attr}, and \code{gal} have special From 08c12ea442d8181ef4836df7eb017a9687af86d6 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Tue, 13 Sep 2022 16:16:35 -0700 Subject: [PATCH 26/49] delete some duplicated imports --- R/constructors.R | 6 ------ 1 file changed, 6 deletions(-) diff --git a/R/constructors.R b/R/constructors.R index 7f83646..8479c03 100644 --- a/R/constructors.R +++ b/R/constructors.R @@ -1,10 +1,4 @@ -#' @import network -#' @importFrom statnet.common NVL NVL2 -#' @importFrom tibble tibble as_tibble is_tibble -#' @importFrom dplyr bind_rows bind_cols -#' @importFrom stats na.omit - #' @rdname constructors #' @title networkLite Constructor Utilities #' From d72949e376aa1ee0daa084aaed83783789a69b90 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 14 Sep 2022 05:25:23 -0700 Subject: [PATCH 27/49] simplify add.edges, add.vertices --- R/add_edges.R | 11 ++++------- R/add_vertices.R | 7 ------- 2 files changed, 4 insertions(+), 14 deletions(-) diff --git a/R/add_edges.R b/R/add_edges.R index 663c486..699add6 100644 --- a/R/add_edges.R +++ b/R/add_edges.R @@ -32,7 +32,6 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, na = logical(length(tail)))) new_names <- c("na") } else { - new_names <- unique(unlist(names.eval)) if (!is.list(names.eval)) names.eval <- as.list(rep(names.eval, length.out = length(tail))) @@ -40,16 +39,14 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, as.list(rep(vals.eval, length.out = length(names.eval))) for (i in seq_along(vals.eval)) { - given_names <- unlist(names.eval[[i]]) - null_names <- setdiff(new_names, given_names) - vals.eval[[i]] <- c(as.list(vals.eval[[i]]), vector(mode = "list", length = length(null_names))) - names(vals.eval[[i]]) <- c(given_names, null_names) + vals.eval[[i]] <- as.list(vals.eval[[i]]) + names(vals.eval[[i]]) <- names.eval[[i]] } + new_names <- unique(unlist(names.eval)) update_list <- lapply(new_names, function(name) lapply(vals.eval, `[[`, name)) names(update_list) <- new_names - update_tibble <- dplyr::bind_cols(as_tibble(list(.tail = tail, .head = head)), - as_tibble(update_list)) + update_tibble <- as_tibble(c(list(.tail = tail, .head = head), update_list)) if ("na" %in% new_names) { update_tibble[["na"]] <- lapply(update_tibble[["na"]], diff --git a/R/add_vertices.R b/R/add_vertices.R index 2a00a77..53cec3d 100644 --- a/R/add_vertices.R +++ b/R/add_vertices.R @@ -34,13 +34,6 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL, } new_names <- unique(unlist(lapply(vattr, names))) - for (i in seq_along(vattr)) { - given_names <- names(vattr[[i]]) - null_names <- setdiff(new_names, given_names) - vattr[[i]] <- c(vattr[[i]], vector(mode = "list", length = length(null_names))) - names(vattr[[i]]) <- c(given_names, null_names) - } - update_list <- lapply(new_names, function(name) lapply(vattr, `[[`, name)) names(update_list) <- new_names update_tibble <- as_tibble(update_list) From 55c0daf16960452fdd841e862bc31d93762a0315 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 14 Sep 2022 05:49:58 -0700 Subject: [PATCH 28/49] further add.edges/vertices updates --- R/add_edges.R | 30 ++++++++++++++---------------- R/add_vertices.R | 21 ++++++++++----------- 2 files changed, 24 insertions(+), 27 deletions(-) diff --git a/R/add_edges.R b/R/add_edges.R index 699add6..96ed371 100644 --- a/R/add_edges.R +++ b/R/add_edges.R @@ -24,15 +24,12 @@ #' @export add.edges.networkLite <- function(x, tail, head, names.eval = NULL, vals.eval = NULL, ...) { + ## convert to atomic... tail <- NVL(unlist(tail), integer(0)) head <- NVL(unlist(head), integer(0)) - if (length(names.eval) == 0 || length(vals.eval) == 0 || - length(unlist(names.eval)) == 0 || length(unlist(vals.eval)) == 0) { - update_tibble <- as_tibble(list(.tail = tail, .head = head, - na = logical(length(tail)))) - new_names <- c("na") - } else { + ## if we were passed any attribute information... + if (length(unlist(names.eval)) > 0) { if (!is.list(names.eval)) names.eval <- as.list(rep(names.eval, length.out = length(tail))) if (!is.list(vals.eval)) vals.eval <- @@ -45,19 +42,20 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, new_names <- unique(unlist(names.eval)) update_list <- lapply(new_names, function(name) lapply(vals.eval, `[[`, name)) - names(update_list) <- new_names - update_tibble <- as_tibble(c(list(.tail = tail, .head = head), update_list)) + names(update_list) <- new_names + } else { + update_list <- list() + } - if ("na" %in% new_names) { - update_tibble[["na"]] <- lapply(update_tibble[["na"]], - function(val) if (is.null(val) || is.na(val)) FALSE else val) - } else { - new_names <- c(new_names, "na") - update_tibble[["na"]] <- logical(NROW(update_tibble)) - } + if ("na" %in% names(update_list)) { + update_list[["na"]] <- lapply(update_list[["na"]], function(val) if (is.null(val) || is.na(val)) FALSE else val) + } else { + update_list <- c(update_list, list(na = logical(length(tail)))) } + new_names <- names(update_list) # including "na" + update_tibble <- as_tibble(c(list(.tail = tail, .head = head), update_list)) - old_names <- names(x$el)[-c(1, 2)] + old_names <- setdiff(names(x$el), c(".tail", ".head")) for (name in setdiff(old_names, new_names)) { update_tibble[[name]] <- vector(mode = "list", length = NROW(update_tibble)) } diff --git a/R/add_vertices.R b/R/add_vertices.R index 53cec3d..32463fb 100644 --- a/R/add_vertices.R +++ b/R/add_vertices.R @@ -26,7 +26,8 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL, offset <- oldsize } - if (!is.null(vattr)) { + ## if we were passed any attribute information... + if (length(unlist(vattr)) > 0) { if (is.list(vattr)) { vattr <- rep(vattr, length.out = nv) } else { @@ -36,19 +37,17 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL, new_names <- unique(unlist(lapply(vattr, names))) update_list <- lapply(new_names, function(name) lapply(vattr, `[[`, name)) names(update_list) <- new_names - update_tibble <- as_tibble(update_list) + } else { + update_list <- list() + } - if ("na" %in% new_names) { - update_tibble[["na"]] <- lapply(update_tibble[["na"]], - function(val) if (is.null(val) || is.na(val)) FALSE else val) - } else { - new_names <- c(new_names, "na") - update_tibble[["na"]] <- logical(NROW(update_tibble)) - } + if ("na" %in% names(update_list)) { + update_list[["na"]] <- lapply(update_list[["na"]], function(val) if (is.null(val) || is.na(val)) FALSE else val) } else { - new_names <- c("na") - update_tibble <- as_tibble(list(na = logical(nv))) + update_list <- c(update_list, list(na = logical(nv))) } + new_names <- names(update_list) # including "na" + update_tibble <- as_tibble(update_list) old_names <- names(x$attr) for (name in setdiff(old_names, new_names)) { From 7697943f1f8eabfed867e45aa6a637250a50a247 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 14 Sep 2022 06:11:45 -0700 Subject: [PATCH 29/49] minor adjustments --- R/add_edges.R | 5 +++-- R/add_vertices.R | 3 ++- R/attribute_methods.R | 2 +- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/R/add_edges.R b/R/add_edges.R index 96ed371..0dcce44 100644 --- a/R/add_edges.R +++ b/R/add_edges.R @@ -52,10 +52,11 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, } else { update_list <- c(update_list, list(na = logical(length(tail)))) } - new_names <- names(update_list) # including "na" update_tibble <- as_tibble(c(list(.tail = tail, .head = head), update_list)) - old_names <- setdiff(names(x$el), c(".tail", ".head")) + new_names <- names(update_tibble) # including ".tail", ".head", and "na" + old_names <- names(x$el) + for (name in setdiff(old_names, new_names)) { update_tibble[[name]] <- vector(mode = "list", length = NROW(update_tibble)) } diff --git a/R/add_vertices.R b/R/add_vertices.R index 32463fb..c78d313 100644 --- a/R/add_vertices.R +++ b/R/add_vertices.R @@ -46,10 +46,11 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL, } else { update_list <- c(update_list, list(na = logical(nv))) } - new_names <- names(update_list) # including "na" update_tibble <- as_tibble(update_list) + new_names <- names(update_tibble) # including "na" old_names <- names(x$attr) + for (name in setdiff(old_names, new_names)) { update_tibble[[name]] <- vector(mode = "list", length = NROW(update_tibble)) } diff --git a/R/attribute_methods.R b/R/attribute_methods.R index 05a4dd5..90f7e20 100644 --- a/R/attribute_methods.R +++ b/R/attribute_methods.R @@ -189,7 +189,7 @@ list.edge.attributes.networkLite <- function(x, ...) { if (network.edgecount(x, na.omit = FALSE) == 0) { return(character(0)) } else { - return(sort(unique(colnames(x$el)[-c(1, 2)]))) + return(sort(unique(setdiff(names(x$el), c(".tail", ".head"))))) } } From ff346f726082d7abe02af6a2b4f10634e76f5f62 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 14 Sep 2022 06:16:37 -0700 Subject: [PATCH 30/49] defaulting null.na to FALSE in get.edge.attribute for consistency with network --- R/attribute_methods.R | 4 +++- man/attribute_methods.Rd | 4 ++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/R/attribute_methods.R b/R/attribute_methods.R index 90f7e20..5362902 100644 --- a/R/attribute_methods.R +++ b/R/attribute_methods.R @@ -78,6 +78,7 @@ set.vertex.attribute.networkLite <- function(x, #' list.vertex.attributes.networkLite <- function(x, ...) { if (network.size(x) == 0) { + ## as in network... return(NULL) } else { return(sort(unique(names(x$attr)))) @@ -119,7 +120,7 @@ list.network.attributes.networkLite <- function(x, ...) { #' @rdname attribute_methods #' @export #' -get.edge.attribute.networkLite <- function(x, attrname, ..., null.na = TRUE, unlist = TRUE) { +get.edge.attribute.networkLite <- function(x, attrname, ..., null.na = FALSE, unlist = TRUE) { if (attrname %in% list.edge.attributes(x)) { out <- x$el[[attrname]] } else { @@ -187,6 +188,7 @@ set.edge.value.networkLite <- function( #' list.edge.attributes.networkLite <- function(x, ...) { if (network.edgecount(x, na.omit = FALSE) == 0) { + ## as in network... return(character(0)) } else { return(sort(unique(setdiff(names(x$el), c(".tail", ".head"))))) diff --git a/man/attribute_methods.Rd b/man/attribute_methods.Rd index 5509826..88cbd8c 100644 --- a/man/attribute_methods.Rd +++ b/man/attribute_methods.Rd @@ -29,9 +29,9 @@ \method{list.network.attributes}{networkLite}(x, ...) -\method{get.edge.attribute}{networkLite}(x, attrname, ..., null.na = TRUE, unlist = TRUE) +\method{get.edge.attribute}{networkLite}(x, attrname, ..., null.na = FALSE, unlist = TRUE) -\method{get.edge.value}{networkLite}(x, attrname, ..., null.na = TRUE, unlist = TRUE) +\method{get.edge.value}{networkLite}(x, attrname, ..., null.na = FALSE, unlist = TRUE) \method{set.edge.attribute}{networkLite}( x, From 3276dd11de4b3d7a7f09223ee4f5dd4d3f6ae0ff Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 14 Sep 2022 06:47:26 -0700 Subject: [PATCH 31/49] edge attribute updates --- R/as_networkLite.R | 5 ++++- R/matrix_conversions.R | 6 +++--- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/R/as_networkLite.R b/R/as_networkLite.R index 9cbd26e..e662f58 100644 --- a/R/as_networkLite.R +++ b/R/as_networkLite.R @@ -40,7 +40,10 @@ as.networkLite.network <- function(x, ...) { set.network.attribute(rv, name, value) } - eids <- unlist(lapply(seq_len(NROW(el)), function(index) get.edgeIDs(x, el[index, 1], el[index, 2], na.omit = FALSE))) + eids <- unlist(lapply(seq_len(NROW(el)), + function(index) { + get.edgeIDs(x, el[index, 1], el[index, 2], na.omit = FALSE) + })) for (name in list.edge.attributes(x)) { value <- get.edge.attribute(x, name, unlist = FALSE, null.na = FALSE, na.omit = FALSE, deleted.edges.omit = FALSE)[eids] diff --git a/R/matrix_conversions.R b/R/matrix_conversions.R index f9c63dc..0d9ba7e 100644 --- a/R/matrix_conversions.R +++ b/R/matrix_conversions.R @@ -83,7 +83,7 @@ as.matrix.networkLite.adjacency <- function(x, attrname = NULL, ...) { el <- as.edgelist(x, na.rm = FALSE) if (!is.null(attrname)) { - vals <- x %e% attrname + vals <- get.edge.attribute(x, attrname, null.na = TRUE, unlist = TRUE) } else { vals <- rep(1, network.edgecount(x, na.omit = FALSE)) } @@ -109,7 +109,7 @@ as.matrix.networkLite.adjacency <- function(x, attrname = NULL, ...) { as.matrix.networkLite.incidence <- function(x, attrname = NULL, ...) { el <- as.edgelist(x, na.rm = FALSE) - vals <- NVL2(attrname, x %e% attrname, + vals <- NVL2(attrname, get.edge.attribute(x, attrname, null.na = TRUE, unlist = TRUE), rep(1, network.edgecount(x, na.omit = FALSE))) vals[NVL(x %e% "na", logical(length(vals)))] <- NA @@ -127,7 +127,7 @@ as.matrix.networkLite.edgelist <- function(x, attrname = NULL, m <- matrix(c(x$el$.tail, x$el$.head), ncol = 2) if (!is.null(attrname)) { - m <- cbind(m, get.edge.attribute(x, attrname)) + m <- cbind(m, get.edge.attribute(x, attrname, null.na = TRUE, unlist = TRUE)) } if (na.rm == TRUE) { m <- m[!NVL(x %e% "na", logical(NROW(m))), , drop = FALSE] From b00581a7fffebb2fe7174b321c75ee5e8e7c5496 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 14 Sep 2022 08:00:10 -0700 Subject: [PATCH 32/49] update constructors and documentation --- R/constructors.R | 68 ++++++++++++++++++++++++++++----------------- man/constructors.Rd | 49 ++++++++++++++++++++------------ 2 files changed, 73 insertions(+), 44 deletions(-) diff --git a/R/constructors.R b/R/constructors.R index 8479c03..c13422f 100644 --- a/R/constructors.R +++ b/R/constructors.R @@ -4,11 +4,29 @@ #' #' @description Constructor methods for \code{networkLite} objects. #' -#' @param x Either an \code{edgelist} class network representation (including -#' network attributes in its \code{attributes} list), or a number -#' specifying the network size. -#' @param attr A named list of vertex attributes for the network represented by -#' \code{x}. +#' @param x Either an \code{edgelist} class network representation, including +#' network attributes as \code{attr}-style attributes on the +#' \code{edgelist}, or a number specifying the network size. The +#' \code{edgelist} may be either a \code{tibble} or a \code{matrix}. If +#' a \code{tibble} is passed, it should have integer columns named +#' \code{".tail"} and \code{".head"} for the tails and heads of edges, +#' and may include edge attributes as additional columns. If a +#' \code{matrix} is passed, it should have two columns, the first being +#' the tails of edges and the second being the heads of edges; edge +#' attributes are not supported for \code{matrix} arguments. Edges +#' should be sorted, first on tails then on heads. See +#' \code{\link[network]{as.edgelist}} for information on producing such +#' \code{edgelist} objects from \code{network} objects. +#' +#' The \code{edgelist} \emph{must} have the \code{"n"} attribute +#' indicating the network size, and may include additional named +#' \code{attr}-style attributes that will be interpreted as network +#' attributes and copied to the \code{networkLite}. Exceptions to this +#' are attributes named \code{"class"}, \code{"dim"}, \code{"dimnames"}, +#' \code{"vnames"}, \code{"row.names"}, \code{"names"}, and +#' \code{"mnext"}; these are not copied from the \code{edgelist} to the +#' \code{networkLite}. +#' @param attr A named list of vertex attributes, coerced to \code{tibble}. #' @param directed,bipartite Common network attributes that may be set via #' arguments to the \code{networkLite.numeric} method. #' @param ... additional arguments @@ -20,17 +38,12 @@ #' with network attributes attached in its \code{attributes} list, and a named #' list of vertex attributes \code{attr}, and returns a \code{networkLite} #' object, which is a named list with fields \code{el}, \code{attr}, and -#' \code{gal}; the fields \code{el} and \code{attr} match the arguments \code{x} -#' and \code{attr} (the latter coerced to \code{tibble}) respectively, and the -#' field \code{gal} is the list of network attributes (copied from -#' \code{attributes(x)}). Missing network attributes \code{directed} and -#' \code{bipartite} are defaulted to \code{FALSE}; the network size attribute -#' \code{n} must not be missing. Attributes \code{class}, \code{dim}, -#' \code{dimnames}, \code{vnames}, and \code{mnext} (if present) are not copied -#' from \code{x} to the \code{networkLite}. (For convenience, a \code{matrix} -#' method, identical to the \code{edgelist} method, is also defined, to handle -#' cases where the edgelist is, for whatever reason, not classed as an -#' \code{edgelist}.) +#' \code{gal}. The fields \code{el} and \code{attr} are \code{tibble}s +#' corresponding to the \code{x} and \code{attr} arguments, respectively, and +#' the field \code{gal} is the list of network attributes (copied from +#' \code{attributes(x)}, with the exceptions noted above). Missing network +#' attributes \code{directed} and \code{bipartite} are defaulted to +#' \code{FALSE}; the network size attribute \code{n} must not be missing. #' #' The \code{numeric} method takes a number \code{x} as well as the network #' attributes \code{directed} and \code{bipartite} (defaulting to \code{FALSE}), @@ -45,8 +58,8 @@ #' calls to \code{ergm} and \code{tergm} \code{simulate} functions. #' #' @return -#' A networkLite object with edge list \code{el}, vertex attributes \code{attr}, -#' and network attributes \code{gal}. +#' A \code{networkLite} object with edgelist \code{el}, vertex attributes +#' \code{attr}, and network attributes \code{gal}. #' #' @export #' @@ -66,19 +79,22 @@ networkLite <- function(x, ...) { networkLite.edgelist <- function( x, attr = list(vertex.names = seq_len(attributes(x)[["n"]]), - na = logical(attributes(x)[["n"]])), + na = logical(attributes(x)[["n"]])), ...) { - nw <- list(el = x, + if (is_tibble(x)) { + el <- x + } else { + el <- as_tibble(list(.tail = as.integer(x[, 1]), + .head = as.integer(x[, 2]))) + } + + nw <- list(el = el, attr = as_tibble(attr), gal = attributes(x)[setdiff(names(attributes(x)), c("class", "dim", "dimnames", - "vnames", "mnext"))]) - - if (!is_tibble(x)) { - nw$el <- as_tibble(list(.tail = as.integer(x[, 1]), - .head = as.integer(x[, 2]))) - } + "vnames", "row.names", "names", + "mnext"))]) nw$el[["na"]] <- NVL(nw$el[["na"]], logical(NROW(nw$el))) nw$el[["na"]][is.na(nw$el[["na"]])] <- FALSE diff --git a/man/constructors.Rd b/man/constructors.Rd index f53e5d9..e272862 100644 --- a/man/constructors.Rd +++ b/man/constructors.Rd @@ -29,21 +29,39 @@ networkLite(x, ...) networkLite_initialize(x, directed = FALSE, bipartite = FALSE, ...) } \arguments{ -\item{x}{Either an \code{edgelist} class network representation (including -network attributes in its \code{attributes} list), or a number -specifying the network size.} +\item{x}{Either an \code{edgelist} class network representation, including + network attributes as \code{attr}-style attributes on the + \code{edgelist}, or a number specifying the network size. The + \code{edgelist} may be either a \code{tibble} or a \code{matrix}. If + a \code{tibble} is passed, it should have integer columns named + \code{".tail"} and \code{".head"} for the tails and heads of edges, + and may include edge attributes as additional columns. If a + \code{matrix} is passed, it should have two columns, the first being + the tails of edges and the second being the heads of edges; edge + attributes are not supported for \code{matrix} arguments. Edges + should be sorted, first on tails then on heads. See + \code{\link[network]{as.edgelist}} for information on producing such + \code{edgelist} objects from \code{network} objects. + + The \code{edgelist} \emph{must} have the \code{"n"} attribute + indicating the network size, and may include additional named + \code{attr}-style attributes that will be interpreted as network + attributes and copied to the \code{networkLite}. Exceptions to this + are attributes named \code{"class"}, \code{"dim"}, \code{"dimnames"}, + \code{"vnames"}, \code{"row.names"}, \code{"names"}, and + \code{"mnext"}; these are not copied from the \code{edgelist} to the + \code{networkLite}.} \item{...}{additional arguments} -\item{attr}{A named list of vertex attributes for the network represented by -\code{x}.} +\item{attr}{A named list of vertex attributes, coerced to \code{tibble}.} \item{directed, bipartite}{Common network attributes that may be set via arguments to the \code{networkLite.numeric} method.} } \value{ -A networkLite object with edge list \code{el}, vertex attributes \code{attr}, -and network attributes \code{gal}. +A \code{networkLite} object with edgelist \code{el}, vertex attributes +\code{attr}, and network attributes \code{gal}. } \description{ Constructor methods for \code{networkLite} objects. @@ -56,17 +74,12 @@ The \code{edgelist} method takes an \code{edgelist} class object \code{x} with network attributes attached in its \code{attributes} list, and a named list of vertex attributes \code{attr}, and returns a \code{networkLite} object, which is a named list with fields \code{el}, \code{attr}, and -\code{gal}; the fields \code{el} and \code{attr} match the arguments \code{x} -and \code{attr} (the latter coerced to \code{tibble}) respectively, and the -field \code{gal} is the list of network attributes (copied from -\code{attributes(x)}). Missing network attributes \code{directed} and -\code{bipartite} are defaulted to \code{FALSE}; the network size attribute -\code{n} must not be missing. Attributes \code{class}, \code{dim}, -\code{dimnames}, \code{vnames}, and \code{mnext} (if present) are not copied -from \code{x} to the \code{networkLite}. (For convenience, a \code{matrix} -method, identical to the \code{edgelist} method, is also defined, to handle -cases where the edgelist is, for whatever reason, not classed as an -\code{edgelist}.) +\code{gal}. The fields \code{el} and \code{attr} are \code{tibble}s +corresponding to the \code{x} and \code{attr} arguments, respectively, and +the field \code{gal} is the list of network attributes (copied from +\code{attributes(x)}, with the exceptions noted above). Missing network +attributes \code{directed} and \code{bipartite} are defaulted to +\code{FALSE}; the network size attribute \code{n} must not be missing. The \code{numeric} method takes a number \code{x} as well as the network attributes \code{directed} and \code{bipartite} (defaulting to \code{FALSE}), From 625d4879bbdcd67b8e7de60f02eda007e7dd87a1 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 14 Sep 2022 08:03:14 -0700 Subject: [PATCH 33/49] tergmLite -> EpiModel --- R/constructors.R | 5 +++-- man/constructors.Rd | 5 +++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/R/constructors.R b/R/constructors.R index c13422f..8be77a7 100644 --- a/R/constructors.R +++ b/R/constructors.R @@ -54,8 +54,9 @@ #' an empty \code{networkLite}, and its \code{x} argument should be a number #' indicating the size of the \code{networkLite} to create. #' -#' Within \code{tergmLite}, the \code{networkLite} data structure is used in the -#' calls to \code{ergm} and \code{tergm} \code{simulate} functions. +#' Within \code{EpiModel}, the \code{networkLite} data structure is used in the +#' calls to \code{ergm} and \code{tergm} \code{simulate} and \code{summary} +#' functions. #' #' @return #' A \code{networkLite} object with edgelist \code{el}, vertex attributes diff --git a/man/constructors.Rd b/man/constructors.Rd index e272862..f8155f2 100644 --- a/man/constructors.Rd +++ b/man/constructors.Rd @@ -90,8 +90,9 @@ The constructor \code{networkLite_initialize} is also available for creating an empty \code{networkLite}, and its \code{x} argument should be a number indicating the size of the \code{networkLite} to create. -Within \code{tergmLite}, the \code{networkLite} data structure is used in the -calls to \code{ergm} and \code{tergm} \code{simulate} functions. +Within \code{EpiModel}, the \code{networkLite} data structure is used in the +calls to \code{ergm} and \code{tergm} \code{simulate} and \code{summary} +functions. } \examples{ edgelist <- cbind(c(1,2,3), c(2,4,7)) From 43cee7b0f32bc878487c4fbf698716c8f44b9308 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 14 Sep 2022 08:21:51 -0700 Subject: [PATCH 34/49] lint --- R/add_edges.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/add_edges.R b/R/add_edges.R index 0dcce44..5dafa4b 100644 --- a/R/add_edges.R +++ b/R/add_edges.R @@ -42,9 +42,9 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, new_names <- unique(unlist(names.eval)) update_list <- lapply(new_names, function(name) lapply(vals.eval, `[[`, name)) - names(update_list) <- new_names + names(update_list) <- new_names } else { - update_list <- list() + update_list <- list() } if ("na" %in% names(update_list)) { From ef57a1ef85324ca1124643ade72f30a14d29d27b Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 14 Sep 2022 08:47:37 -0700 Subject: [PATCH 35/49] updates to handling of absent edge attributes --- R/matrix_conversions.R | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/R/matrix_conversions.R b/R/matrix_conversions.R index 0d9ba7e..d3a9379 100644 --- a/R/matrix_conversions.R +++ b/R/matrix_conversions.R @@ -24,7 +24,17 @@ as.edgelist.networkLite <- function(x, attrname = NULL, m <- cbind(m, get.edge.attribute(x, attrname, null.na = TRUE, unlist = TRUE)) } } else { - m <- x$el[c(".tail", ".head", attrname)] + if (is.null(attrname)) { + tibble_list <- list(x$el$.tail, + x$el$.head) + names(tibble_list) <- c(".tail", ".head") + } else { + tibble_list <- list(x$el$.tail, + x$el$.head, + get.edge.attribute(x, attrname, null.na = FALSE, unlist = FALSE)) + names(tibble_list) <- c(".tail", ".head", attrname) + } + m <- as_tibble(tibble_list) } if (na.rm && NROW(m) > 0) { @@ -54,7 +64,10 @@ as.edgelist.networkLite <- function(x, attrname = NULL, as_tibble.networkLite <- function(x, attrnames = NULL, na.rm = TRUE, ...) { if (is.logical(attrnames) || is.numeric(attrnames)) attrnames <- na.omit(list.edge.attributes(x)[attrnames]) - out <- x$el[, c(".tail", ".head", attrnames)] + attr_list <- lapply(attrnames, function(attrname) get.edge.attribute(x, attrname, null.na = FALSE, unlist = FALSE)) + names(attr_list) <- attrnames + tibble_list <- c(list(.tail = x$el$.tail, .head = x$el$.head), attr_list) + out <- as_tibble(tibble_list) if (na.rm && NROW(out) > 0) { na <- NVL(x %e% "na", logical(NROW(out))) out <- out[!na, ] From f22136b4e27a24a077a729aaa2368d13d6842669 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 14 Sep 2022 12:58:38 -0700 Subject: [PATCH 36/49] initialization updates and more tests --- R/constructors.R | 6 +++ tests/testthat/test-networkLite.R | 89 +++++++++++++++++++++++++++++++ 2 files changed, 95 insertions(+) diff --git a/R/constructors.R b/R/constructors.R index 8be77a7..5923885 100644 --- a/R/constructors.R +++ b/R/constructors.R @@ -84,8 +84,14 @@ networkLite.edgelist <- function( ...) { if (is_tibble(x)) { + if (!(".tail" %in% names(x)) || !(".head" %in% names(x))) { + stop("tibble edgelist must include column names '.tail' and '.head'") + } el <- x } else { + if (NCOL(x) != 2) { + stop("matrix edgelist must have two columns") + } el <- as_tibble(list(.tail = as.integer(x[, 1]), .head = as.integer(x[, 2]))) } diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index 39bffa0..d254760 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -159,6 +159,93 @@ test_that("various attribute operations function equivalently for network and ne expect_equiv_nets(nw, nwL) }) +test_that("initially atomic attribute assigns non-atomic values consistently", { + nw <- network.initialize(5, directed = FALSE) + nw %v% "verts" <- 1:5 + nwL <- as.networkLite(nw) + expect_equiv_nets(nw, nwL) + expect_true(is.atomic(nwL$attr$verts)) + set.vertex.attribute(nw, "verts", list(list(1),list(2:3),list(c("a","b"))), c(1,4,5)) + set.vertex.attribute(nwL, "verts", list(list(1),list(2:3),list(c("a","b"))), c(1,4,5)) + expect_equiv_nets(nw, nwL) + expect_false(is.atomic(nwL$attr$verts)) + expect_identical(nwL$attr$verts, list(list(1), 2L, 3L, list(2:3), list(c("a","b")))) + expect_identical(get.vertex.attribute(nwL, "verts", unlist = FALSE, null.na = FALSE), + list(list(1), 2L, 3L, list(2:3), list(c("a","b")))) + expect_identical(get.vertex.attribute(nw, "verts", unlist = FALSE, null.na = FALSE), + list(list(1), 2L, 3L, list(2:3), list(c("a","b")))) +}) + +test_that("initialization errors or lack thereof", { + el <- cbind(c(1,1,3,3,4), c(2,3,4,5,5)) + attr(el, "n") <- 5 + nw <- network(el, directed = FALSE) + el <- as.edgelist(nw, output = "tibble") + nwL <- networkLite(el) + expect_equiv_nets(nw, nwL) + names(el) <- c("tail", ".head") + expect_error(networkLite(el), "'.tail' and '.head'") + nw %e% "eattr" <- runif(5) + el <- as.edgelist(nw, output = "tibble") + nwL <- networkLite(el) + expect_error(expect_equiv_nets(nw, nwL)) + el_attr <- as.edgelist(nw, attrname = "eattr", output = "tibble") + nwL <- networkLite(el_attr) + expect_equiv_nets(nw, nwL) + delete.edge.attribute(nw, "eattr") + set.edge.attribute(nw, "na", sample(c(FALSE,TRUE), 5, TRUE)) + el_attr <- as.edgelist(nw, attrname = "na", output = "tibble", na.rm = FALSE) + nwL <- networkLite(el_attr) + expect_equiv_nets(nw, nwL) + set.edge.attribute(nw, "na", FALSE) + el <- as.edgelist(nw) + el <- el[,1,drop=FALSE] + attr(el, "n") <- 5 + expect_error(networkLite(el), "two columns") +}) + +test_that("more tibble tests", { + nw <- network(create_random_edgelist(100L, FALSE, FALSE, 100L), directed = FALSE, bipartite = FALSE, matrix.type = "edgelist") + nw %e% "e1" <- runif(network.edgecount(nw)) + nw %e% "e2" <- runif(network.edgecount(nw)) + nw %e% "na" <- sample(c(FALSE, TRUE), network.edgecount(nw), TRUE) + + tbl <- as_tibble(nw, na.rm = FALSE) + tbl <- tbl[order(tbl$.tail, tbl$.head),] + class(tbl) <- c("edgelist", class(tbl)) + nwL <- networkLite(tbl) + expect_error(expect_equiv_nets(nw, nwL)) + expect_equal(list.edge.attributes(nwL), c("na")) + + tbl <- as_tibble(nw, attrnames = "e1", na.rm = FALSE) + tbl <- tbl[order(tbl$.tail, tbl$.head),] + class(tbl) <- c("edgelist", class(tbl)) + nwL <- networkLite(tbl) + expect_error(expect_equiv_nets(nw, nwL)) + expect_equal(list.edge.attributes(nwL), c("e1", "na")) + + tbl <- as_tibble(nw, attrnames = c("e1", "e2"), na.rm = FALSE) + tbl <- tbl[order(tbl$.tail, tbl$.head),] + class(tbl) <- c("edgelist", class(tbl)) + nwL <- networkLite(tbl) + expect_error(expect_equiv_nets(nw, nwL)) + expect_equal(list.edge.attributes(nwL), c("e1", "e2", "na")) + + tbl <- as_tibble(nw, attrnames = c("e1", "e2", "na"), na.rm = FALSE) + tbl <- tbl[order(tbl$.tail, tbl$.head),] + class(tbl) <- c("edgelist", class(tbl)) + nwL <- networkLite(tbl) + expect_equiv_nets(nw, nwL) + expect_equal(list.edge.attributes(nwL), c("e1", "e2", "na")) + + tbl <- as_tibble(nw, attrnames = c("e1", "e2", "na"), na.rm = TRUE) + tbl <- tbl[order(tbl$.tail, tbl$.head),] + class(tbl) <- c("edgelist", class(tbl)) + nwL <- networkLite(tbl) + expect_error(expect_equiv_nets(nw, nwL)) + expect_equal(list.edge.attributes(nwL), c("e1", "e2", "na")) +}) + test_that("direct conversion between network and networkLite functions as expected", { net_size <- 100 bip_size <- 40 @@ -213,10 +300,12 @@ test_that("network and networkLite produce identical matrices, edgelists, and ti set.seed(0) nw <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") nw %e% "eattr" <- runif(network.edgecount(nw)) + nw %e% "na" <- sample(c(FALSE, TRUE), network.edgecount(nw), TRUE) set.seed(0) nwL <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) set.edge.attribute(nwL, "eattr", runif(network.edgecount(nwL))) + set.edge.attribute(nwL, "na", sample(c(FALSE, TRUE), network.edgecount(nwL), TRUE)) for(attrname in list(NULL, "eattr", "na")) { for(na.rm in list(FALSE, TRUE)) { From 0c4d41d43eff63df99103e6452da7ee60b1f0651 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Fri, 16 Sep 2022 06:07:49 -0700 Subject: [PATCH 37/49] documentation, attribute handling in + and -, tests --- R/constructors.R | 2 + R/misc.R | 16 ++++--- man/constructors.Rd | 4 +- tests/testthat/test-networkLite.R | 70 +++++++++++++++++++++++++++++++ 4 files changed, 86 insertions(+), 6 deletions(-) diff --git a/R/constructors.R b/R/constructors.R index 5923885..511a560 100644 --- a/R/constructors.R +++ b/R/constructors.R @@ -27,6 +27,8 @@ #' \code{"mnext"}; these are not copied from the \code{edgelist} to the #' \code{networkLite}. #' @param attr A named list of vertex attributes, coerced to \code{tibble}. +#' Each element of \code{attr} should be an atomic vector or list of +#' length equal to the number of nodes in the network. #' @param directed,bipartite Common network attributes that may be set via #' arguments to the \code{networkLite.numeric} method. #' @param ... additional arguments diff --git a/R/misc.R b/R/misc.R index 96d66c1..9c6090e 100644 --- a/R/misc.R +++ b/R/misc.R @@ -81,12 +81,15 @@ is.na.networkLite <- function(x) { stop("adding networkLites with missing edges is not currently supported") } - out <- e1 if (network.edgecount(e2, na.omit = FALSE) > 0) { edgelist <- dplyr::bind_rows(ensure_list(list(e1$el, e2$el))) edgelist <- edgelist[!duplicated(edgelist[, c(".tail", ".head")]), ] - out$el <- edgelist[order(edgelist$.tail, edgelist$.head), ] + edgelist <- edgelist[order(edgelist$.tail, edgelist$.head), ] + } else { + edgelist <- e1$el } + out <- networkLite(e1 %n% "n", e1 %n% "directed", e1 %n% "bipartite") + out <- add.edges(out, edgelist$.tail, edgelist$.head) out } @@ -105,12 +108,15 @@ is.na.networkLite <- function(x) { " supported") } - out <- e1 if (network.edgecount(e2, na.omit = FALSE) > 0) { edgelist <- dplyr::bind_rows(ensure_list(list(e2$el, e1$el))) nd <- !duplicated(edgelist[, c(".tail", ".head")]) - out$el <- out$el[nd[-seq_len(network.edgecount(e2, na.omit = FALSE))], ] - out$el <- out$el[order(out$el$.tail, out$el$.head), ] + edgelist <- e1$el[nd[-seq_len(network.edgecount(e2, na.omit = FALSE))], ] + edgelist <- edgelist[order(edgelist$.tail, edgelist$.head), ] + } else { + edgelist <- e1$el } + out <- networkLite(e1 %n% "n", e1 %n% "directed", e1 %n% "bipartite") + out <- add.edges(out, edgelist$.tail, edgelist$.head) out } diff --git a/man/constructors.Rd b/man/constructors.Rd index f8155f2..cdfc353 100644 --- a/man/constructors.Rd +++ b/man/constructors.Rd @@ -54,7 +54,9 @@ networkLite_initialize(x, directed = FALSE, bipartite = FALSE, ...) \item{...}{additional arguments} -\item{attr}{A named list of vertex attributes, coerced to \code{tibble}.} +\item{attr}{A named list of vertex attributes, coerced to \code{tibble}. +Each element of \code{attr} should be an atomic vector or list of +length equal to the number of nodes in the network.} \item{directed, bipartite}{Common network attributes that may be set via arguments to the \code{networkLite.numeric} method.} diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index d254760..392aceb 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -159,6 +159,76 @@ test_that("various attribute operations function equivalently for network and ne expect_equiv_nets(nw, nwL) }) +test_that("is.na, +, and - treat attributes as for network", { + net_size <- 100 + bip_size <- 40 + edges_target <- net_size + + for(directed in list(FALSE, TRUE)) { + for(bipartite in list(FALSE, bip_size)) { + if(directed && bipartite) { + next + } + + for(last.mode in list(FALSE, TRUE)) { + set.seed(0) + nw0 <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") + nw0 %v% "b" <- runif(net_size) + nw0 %e% "eattr" <- runif(network.edgecount(nw0)) + nw0 %n% "nattr" <- "attr" + add.vertices(nw0, 9, vattr = rep(list(list(na = FALSE, vertex.names = NA_integer_, b = NA_real_)), 9), last.mode = last.mode) + + set.seed(1) + nw1 <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") + nw1 %v% "b" <- runif(net_size) + nw1 %e% "eattr" <- runif(network.edgecount(nw1)) + nw1 %n% "nattr" <- "attr" + add.vertices(nw1, 9, vattr = rep(list(list(na = FALSE, vertex.names = NA_integer_, b = NA_real_)), 9), last.mode = last.mode) + + nw2 <- network.initialize(nw0 %n% "n", directed = nw0 %n% "directed", bipartite = nw0 %n% "bipartite") + + set.seed(0) + nwL0 <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) + nwL0 %v% "b" <- runif(net_size) + set.edge.attribute(nwL0, "eattr", runif(network.edgecount(nwL0))) + nwL0 %n% "nattr" <- "attr" + add.vertices(nwL0, 9, vattr = rep(list(list(na = FALSE, vertex.names = NA_integer_, b = NA_real_)), 9), last.mode = last.mode) + + set.seed(1) + nwL1 <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) + nwL1 %v% "b" <- runif(net_size) + set.edge.attribute(nwL1, "eattr", runif(network.edgecount(nwL1))) + nwL1 %n% "nattr" <- "attr" + add.vertices(nwL1, 9, vattr = rep(list(list(na = FALSE, vertex.names = NA_integer_, b = NA_real_)), 9), last.mode = last.mode) + + nwL2 <- networkLite(nwL0 %n% "n", directed = nwL0 %n% "directed", bipartite = nwL0 %n% "bipartite") + + expect_equiv_nets(nw0, nwL0) + expect_equiv_nets(is.na(nw0), is.na(nwL0)) + expect_equiv_nets(is.na(is.na(nw0)), is.na(is.na(nwL0))) + expect_equiv_nets(nw1, nwL1) + expect_equiv_nets(nw0 + nw1, nwL0 + nwL1) + expect_equiv_nets(nw0 - nw1, nwL0 - nwL1) + expect_equiv_nets(nw0 + nw2, nwL0 + nwL2) + expect_equiv_nets(nw0 - nw2, nwL0 - nwL2) + expect_equiv_nets(nw2 + nw1, nwL2 + nwL1) + expect_equiv_nets(nw2 - nw1, nwL2 - nwL1) + + set.seed(2) + set.edge.attribute(nw0, "na", sample(c(FALSE, TRUE), network.edgecount(nw0, na.omit = FALSE), TRUE)) + set.seed(2) + set.edge.attribute(nwL0, "na", sample(c(FALSE, TRUE), network.edgecount(nwL0, na.omit = FALSE), TRUE)) + expect_equiv_nets(nw0, nwL0) + expect_equiv_nets(is.na(nw0), is.na(nwL0)) + expect_equiv_nets(is.na(is.na(nw0)), is.na(is.na(nwL0))) + expect_equiv_nets(is.na(is.na(is.na(nw0))), is.na(is.na(is.na(nwL0)))) + expect_error(nwL0 + nwL1, "missing edges") + expect_error(nwL0 - nwL1, "missing edges") + } + } + } +}) + test_that("initially atomic attribute assigns non-atomic values consistently", { nw <- network.initialize(5, directed = FALSE) nw %v% "verts" <- 1:5 From a37a8b9faf278d344c9eef217f8cc235f83c635e Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Fri, 16 Sep 2022 14:53:31 -0700 Subject: [PATCH 38/49] two optimizations and documentation update --- R/attribute_methods.R | 4 ++-- R/networkLite-package.R | 3 ++- R/utils.R | 1 + man/networkLite-package.Rd | 3 ++- 4 files changed, 7 insertions(+), 4 deletions(-) diff --git a/R/attribute_methods.R b/R/attribute_methods.R index 5362902..2dfbd2c 100644 --- a/R/attribute_methods.R +++ b/R/attribute_methods.R @@ -41,7 +41,7 @@ get.vertex.attribute.networkLite <- function(x, attrname, ..., null.na = TRUE, u } if (null.na == TRUE && is.list(out)) { - out <- lapply(out, NVL, NA) + out <- lapply(out, function(val) if (!is.null(val)) val else NA) } if (unlist == TRUE) { @@ -128,7 +128,7 @@ get.edge.attribute.networkLite <- function(x, attrname, ..., null.na = FALSE, un } if (null.na == TRUE && is.list(out)) { - out <- lapply(out, NVL, NA) + out <- lapply(out, function(val) if (!is.null(val)) val else NA) } if (unlist == TRUE) { diff --git a/R/networkLite-package.R b/R/networkLite-package.R index 5e798e6..8f2529b 100644 --- a/R/networkLite-package.R +++ b/R/networkLite-package.R @@ -26,7 +26,8 @@ #' and heads of edges, and \code{"na"}, which is a logical attribute indicating #' if the edge is missing or not; #' \item for \code{attr}: \code{"na"}, which is a logical attribute indicating -#' if the vertex is missing or not; +#' if the vertex is missing or not, and \code{"vertex.names"}, which provides +#' names for the vertices in the network; #' \item for \code{gal}: \code{"n"} (the network size), \code{"directed"} (a #' logical indicating if the network is directed), \code{"bipartite"} (either #' \code{FALSE} to indicate the network is not bipartite, or the size of the diff --git a/R/utils.R b/R/utils.R index 91c66fd..2bf8c23 100644 --- a/R/utils.R +++ b/R/utils.R @@ -12,6 +12,7 @@ atomize_tibble <- function(x) { for (name in names(x)) { value <- x[[name]] if (length(value) > 0 && + !is.atomic(value) && all(unlist(lapply(value, is.atomic))) && all(unlist(lapply(value, length)) == 1)) { x[[name]] <- unlist(value) diff --git a/man/networkLite-package.Rd b/man/networkLite-package.Rd index d4b6438..1c9b6ed 100644 --- a/man/networkLite-package.Rd +++ b/man/networkLite-package.Rd @@ -29,7 +29,8 @@ significance. These are and heads of edges, and \code{"na"}, which is a logical attribute indicating if the edge is missing or not; \item for \code{attr}: \code{"na"}, which is a logical attribute indicating - if the vertex is missing or not; + if the vertex is missing or not, and \code{"vertex.names"}, which provides + names for the vertices in the network; \item for \code{gal}: \code{"n"} (the network size), \code{"directed"} (a logical indicating if the network is directed), \code{"bipartite"} (either \code{FALSE} to indicate the network is not bipartite, or the size of the From 548035b3a9c5b1e3e598c8df996d4bf1e989be2d Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Sat, 17 Sep 2022 16:23:31 -0700 Subject: [PATCH 39/49] some optimizations, more tests, and documentation --- R/attribute_methods.R | 44 ++++++++++++++++---- man/attribute_methods.Rd | 10 ++++- tests/testthat/test-networkLite.R | 68 +++++++++++++++++++++++++++++++ 3 files changed, 111 insertions(+), 11 deletions(-) diff --git a/R/attribute_methods.R b/R/attribute_methods.R index 2dfbd2c..67f3533 100644 --- a/R/attribute_methods.R +++ b/R/attribute_methods.R @@ -15,6 +15,8 @@ #' @param null.na Logical. If \code{TRUE}, replace \code{NULL} attribute values #' with \code{NA} in \code{get.vertex.attribute} and #' \code{get.edge.attribute}. Applied before the \code{unlist} argument. +#' Note that the behavior of \code{null.na} in \code{network} is +#' somewhat different. #' @param unlist Logical. In \code{get.vertex.attribute} and #' \code{get.edge.attribute}, if \code{unlist} is \code{TRUE}, we call #' \code{unlist} on the attribute value before returning it, and if @@ -25,7 +27,11 @@ #' \code{FALSE}, we return the attribute value without any modification. #' @param ... additional arguments #' -#' @details Allows basic attribute manipulation for \code{networkLite}s. +#' @details Allows basic attribute manipulation for \code{networkLite}s. Note +#' that an edge or vertex attribute not present in the +#' \code{networkLite} is treated as a list of \code{NULL}s of length +#' equal to the number of edges or vertices (respectively) before +#' applying the \code{null.na} and \code{unlist} arguments. #' #' @return Behavior and return values are analogous to those of the #' corresponding \code{network} methods, with network data structured @@ -34,12 +40,21 @@ #' @export #' get.vertex.attribute.networkLite <- function(x, attrname, ..., null.na = TRUE, unlist = TRUE) { - if (attrname %in% list.vertex.attributes(x)) { - out <- x$attr[[attrname]] - } else { - out <- vector(mode = "list", length = network.size(x)) + if (!(attrname %in% list.vertex.attributes(x))) { + ## special case handling relevant to netsim efficiency + if (null.na == TRUE && unlist == TRUE) { + return(rep(NA, length.out = network.size(x))) + } else if (null.na == TRUE && unlist == FALSE) { + return(as.list(rep(NA, length.out = network.size(x)))) + } else if (null.na == FALSE && unlist == TRUE) { + return(NULL) + } else { + return(vector(mode = "list", length = network.size(x))) + } } + out <- x$attr[[attrname]] + if (null.na == TRUE && is.list(out)) { out <- lapply(out, function(val) if (!is.null(val)) val else NA) } @@ -67,6 +82,7 @@ set.vertex.attribute.networkLite <- function(x, x$attr[[attrname]] <- vector(mode = "list", length = network.size(x)) } + ## may upcast atomic types if both are atomic x$attr[[attrname]][v] <- value on.exit(eval.parent(call("<-", xn, x))) @@ -121,12 +137,21 @@ list.network.attributes.networkLite <- function(x, ...) { #' @export #' get.edge.attribute.networkLite <- function(x, attrname, ..., null.na = FALSE, unlist = TRUE) { - if (attrname %in% list.edge.attributes(x)) { - out <- x$el[[attrname]] - } else { - out <- vector(mode = "list", length = network.edgecount(x, na.omit = FALSE)) + if (!(attrname %in% list.edge.attributes(x))) { + ## special case handling consistent as for vertex attributes + if (null.na == TRUE && unlist == TRUE) { + return(rep(NA, length.out = network.edgecount(x, na.omit = FALSE))) + } else if (null.na == TRUE && unlist == FALSE) { + return(as.list(rep(NA, length.out = network.edgecount(x, na.omit = FALSE)))) + } else if (null.na == FALSE && unlist == TRUE) { + return(NULL) + } else { + return(vector(mode = "list", length = network.edgecount(x, na.omit = FALSE))) + } } + out <- x$el[[attrname]] + if (null.na == TRUE && is.list(out)) { out <- lapply(out, function(val) if (!is.null(val)) val else NA) } @@ -158,6 +183,7 @@ set.edge.attribute.networkLite <- function( x$el[[attrname]] <- vector(mode = "list", length = network.edgecount(x, na.omit = FALSE)) } + ## may upcast atomic types if both are atomic x$el[[attrname]][e] <- value on.exit(eval.parent(call("<-", xn, x))) diff --git a/man/attribute_methods.Rd b/man/attribute_methods.Rd index 88cbd8c..33a3bf0 100644 --- a/man/attribute_methods.Rd +++ b/man/attribute_methods.Rd @@ -67,7 +67,9 @@ character vector.} \item{null.na}{Logical. If \code{TRUE}, replace \code{NULL} attribute values with \code{NA} in \code{get.vertex.attribute} and -\code{get.edge.attribute}. Applied before the \code{unlist} argument.} +\code{get.edge.attribute}. Applied before the \code{unlist} argument. +Note that the behavior of \code{null.na} in \code{network} is +somewhat different.} \item{unlist}{Logical. In \code{get.vertex.attribute} and \code{get.edge.attribute}, if \code{unlist} is \code{TRUE}, we call @@ -95,5 +97,9 @@ S3 attribute methods for the \code{networkLite} class, for generics defined in the \code{network} package. } \details{ -Allows basic attribute manipulation for \code{networkLite}s. +Allows basic attribute manipulation for \code{networkLite}s. Note + that an edge or vertex attribute not present in the + \code{networkLite} is treated as a list of \code{NULL}s of length + equal to the number of edges or vertices (respectively) before + applying the \code{null.na} and \code{unlist} arguments. } diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index 392aceb..0c603ff 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -89,6 +89,74 @@ create_random_edgelist <- function(n_nodes, directed, bipartite, target_n_edges) structure(el, n = n_nodes, directed = directed, bipartite = bipartite) } +test_that("setting vertex and edge attributes in strange ways", { + el <- cbind(c(1,2,3,3), c(2,5,4,5)) + attr(el, "n") <- 5 + nw <- network(el, directed = FALSE, bipartite = FALSE, matrix.type = "edgelist") + set.edge.attribute(nw, "ae1", 1:4) + set.edge.attribute(nw, "ae2", 1:4) + set.vertex.attribute(nw, "av1", letters[1:5]) + set.vertex.attribute(nw, "av2", letters[1:5]) + + set.edge.attribute(nw, "ae1", 1:2, c(1,2,4)) + set.edge.attribute(nw, "ae2", 1:3, c(3,1,4,2)) + set.vertex.attribute(nw, "av1", letters[1:7]) + set.vertex.attribute(nw, "av2", c("1","2","3"), 1:2) + + nwL <- networkLite(el) + set.edge.attribute(nwL, "ae1", 1:4) + set.edge.attribute(nwL, "ae2", 1:4) + set.vertex.attribute(nwL, "av1", letters[1:5]) + set.vertex.attribute(nwL, "av2", letters[1:5]) + nwL <- atomize(nwL) + + set.edge.attribute(nwL, "ae1", 1:2, c(1,2,4)) + set.edge.attribute(nwL, "ae2", 1:3, c(3,1,4,2)) + set.vertex.attribute(nwL, "av1", letters[1:7]) + set.vertex.attribute(nwL, "av2", c("1","2","3"), 1:2) + + expect_equiv_nets(nw, nwL) + + set.edge.attribute(nw, "ae1", list(list(1,2), list(3)), c(1,2,4)) + set.edge.attribute(nw, "ae2", list(list("a"), network.initialize(3), 1), c(3,1,4,2)) + set.vertex.attribute(nw, "av1", list(list(network.initialize(3)), 2, 3, "a", "b")) + set.vertex.attribute(nw, "av2", list(list(network.initialize(3)), 2, 3, "a", "b"), 4:5) + + set.edge.attribute(nwL, "ae1", list(list(1,2), list(3)), c(1,2,4)) + set.edge.attribute(nwL, "ae2", list(list("a"), network.initialize(3), 1), c(3,1,4,2)) + set.vertex.attribute(nwL, "av1", list(list(network.initialize(3)), 2, 3, "a", "b", "c")) + set.vertex.attribute(nwL, "av2", list(list(network.initialize(3)), 2, 3, "a", "b"), 4:5) + + expect_equiv_nets(nw, nwL) + +}) + +test_that("accessing non-present attributes", { + nwL <- networkLite(0) + expect_identical(logical(0), get.vertex.attribute(nwL, "not_here", null.na = TRUE, unlist = TRUE)) + expect_identical(list(), get.vertex.attribute(nwL, "not_here", null.na = TRUE, unlist = FALSE)) + expect_identical(NULL, get.vertex.attribute(nwL, "not_here", null.na = FALSE, unlist = TRUE)) + expect_identical(list(), get.vertex.attribute(nwL, "not_here", null.na = FALSE, unlist = FALSE)) + + expect_identical(logical(0), get.edge.attribute(nwL, "not_here", null.na = TRUE, unlist = TRUE)) + expect_identical(list(), get.edge.attribute(nwL, "not_here", null.na = TRUE, unlist = FALSE)) + expect_identical(NULL, get.edge.attribute(nwL, "not_here", null.na = FALSE, unlist = TRUE)) + expect_identical(list(), get.edge.attribute(nwL, "not_here", null.na = FALSE, unlist = FALSE)) + + el <- cbind(c(1,1,2),c(2,3,4)) + attr(el, "n") <- 4 + nwL <- networkLite(el) + expect_identical(c(NA,NA,NA,NA), get.vertex.attribute(nwL, "not_here", null.na = TRUE, unlist = TRUE)) + expect_identical(list(NA,NA,NA,NA), get.vertex.attribute(nwL, "not_here", null.na = TRUE, unlist = FALSE)) + expect_identical(NULL, get.vertex.attribute(nwL, "not_here", null.na = FALSE, unlist = TRUE)) + expect_identical(list(NULL,NULL,NULL,NULL), get.vertex.attribute(nwL, "not_here", null.na = FALSE, unlist = FALSE)) + + expect_identical(c(NA,NA,NA), get.edge.attribute(nwL, "not_here", null.na = TRUE, unlist = TRUE)) + expect_identical(list(NA,NA,NA), get.edge.attribute(nwL, "not_here", null.na = TRUE, unlist = FALSE)) + expect_identical(NULL, get.edge.attribute(nwL, "not_here", null.na = FALSE, unlist = TRUE)) + expect_identical(list(NULL,NULL,NULL), get.edge.attribute(nwL, "not_here", null.na = FALSE, unlist = FALSE)) +}) + test_that("various attribute operations function equivalently for network and networkLite", { ## vertex attributes nw <- network.initialize(5, directed = FALSE) From b679cd059eb0b0f74e6eb4ad904e00d958f77ee3 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Mon, 19 Sep 2022 14:01:13 -0700 Subject: [PATCH 40/49] attribute handling updates, documentation, and tests --- NAMESPACE | 3 + R/as_networkLite.R | 11 ++- R/attribute_methods.R | 67 +++++++++++----- R/constructors.R | 11 ++- R/matrix_conversions.R | 4 +- R/utils.R | 51 ++++++++++--- man/as_networkLite.Rd | 8 +- man/atomize.Rd | 38 ++++++++++ man/attribute_methods.Rd | 24 +++++- man/constructors.Rd | 10 ++- tests/testthat/test-networkLite.R | 122 ++++++++++++++++++++++++++++++ 11 files changed, 307 insertions(+), 42 deletions(-) create mode 100644 man/atomize.Rd diff --git a/NAMESPACE b/NAMESPACE index 7d25253..f4079af 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,6 +11,8 @@ S3method(as.network,networkLite) S3method(as.networkLite,network) S3method(as.networkLite,networkLite) S3method(as_tibble,networkLite) +S3method(atomize,networkLite) +S3method(atomize,tbl_df) S3method(delete.edge.attribute,networkLite) S3method(delete.network.attribute,networkLite) S3method(delete.vertex.attribute,networkLite) @@ -34,6 +36,7 @@ S3method(set.edge.value,networkLite) S3method(set.network.attribute,networkLite) S3method(set.vertex.attribute,networkLite) export(as.networkLite) +export(atomize) export(networkLite) export(networkLite_initialize) export(to_network_networkLite) diff --git a/R/as_networkLite.R b/R/as_networkLite.R index e662f58..ed0b13a 100644 --- a/R/as_networkLite.R +++ b/R/as_networkLite.R @@ -8,7 +8,12 @@ #' \code{loops} must be \code{FALSE} for \code{networkLite}s; #' attempting to convert a \code{network} to a \code{networkLite} when #' this is not the case will result in an error. +#' +#' The \code{...} are passed to \code{\link{atomize}} and can be used +#' to set the \code{upcast} argument controlling attribute conversion. #' @param x A \code{network} or \code{networkLite} object. +#' @param atomize Logical; should we call \code{\link{atomize}} on the +#' \code{networkLite} before returning it? #' @param ... additional arguments #' @return A corresponding \code{networkLite} object. #' @seealso \code{\link{to_network_networkLite}} @@ -19,7 +24,7 @@ as.networkLite <- function(x, ...) { #' @rdname as_networkLite #' @export -as.networkLite.network <- function(x, ...) { +as.networkLite.network <- function(x, ..., atomize = TRUE) { if (is.hyper(x) || is.multiplex(x) || has.loops(x)) { stop("cannot coerce `network` to `networkLite` unless `hyper`,", " `multiple`, and `loops` are all `FALSE`") @@ -54,7 +59,9 @@ as.networkLite.network <- function(x, ...) { attr(rv, name) <- attr(x, name) } - rv <- atomize(rv) + if (atomize == TRUE) { + rv <- atomize(rv, ...) + } rv } diff --git a/R/attribute_methods.R b/R/attribute_methods.R index 67f3533..de3e6c5 100644 --- a/R/attribute_methods.R +++ b/R/attribute_methods.R @@ -9,7 +9,9 @@ #' @param attrname The name of an attribute in \code{x}; must be a length one #' character vector. #' @param value The attribute value to set in vertex, edge, and network -#' attribute setters. +#' attribute setters. For vertex and edge attribute methods, +#' \code{value} should be either an atomic vector or a list, of length +#' equal to that of \code{v} or \code{e}. #' @param v Indices at which to set vertex attribute values. #' @param e Indices at which to set edge attribute values. #' @param null.na Logical. If \code{TRUE}, replace \code{NULL} attribute values @@ -25,6 +27,10 @@ #' if \code{unlist} is \code{TRUE}, we call \code{unlist} on the #' attribute value before returning it, and if \code{unlist} is #' \code{FALSE}, we return the attribute value without any modification. +#' @param upcast Logical. Are we allowed to upcast atomic types when setting +#' vertex or edge attribute values on the \code{networkLite}? Setting +#' \code{upcast = FALSE} prevents upcasting, while setting +#' \code{upcast = TRUE} allows but does not guarantee upcasting. #' @param ... additional arguments #' #' @details Allows basic attribute manipulation for \code{networkLite}s. Note @@ -75,16 +81,24 @@ set.vertex.attribute.networkLite <- function(x, attrname, value, v = seq_len(network.size(x)), - ...) { + ..., + upcast = TRUE) { xn <- substitute(x) - if (!(attrname %in% list.vertex.attributes(x))) { - x$attr[[attrname]] <- vector(mode = "list", length = network.size(x)) + if (missing(v)) { + ## just set everything + x$attr[[attrname]] <- rep(value, length.out = network.size(x)) + } else { + if (!(attrname %in% list.vertex.attributes(x))) { + ## new attr; set up as list since v isn't missing + x$attr[[attrname]] <- vector(mode = "list", length = network.size(x)) + } else if (upcast == FALSE && !identical(class(value), class(x$attr[[attrname]]))) { + ## existing attr; need to watch upcasting + x$attr[[attrname]] <- as.list(x$attr[[attrname]]) + } + x$attr[[attrname]][v] <- value } - ## may upcast atomic types if both are atomic - x$attr[[attrname]][v] <- value - on.exit(eval.parent(call("<-", xn, x))) invisible(x) } @@ -175,17 +189,24 @@ get.edge.value.networkLite <- get.edge.attribute.networkLite #' set.edge.attribute.networkLite <- function( x, attrname, value, - e = seq_len(network.edgecount(x, na.omit = FALSE)), ...) { + e = seq_len(network.edgecount(x, na.omit = FALSE)), ..., upcast = TRUE) { xn <- substitute(x) - if (!(attrname %in% list.edge.attributes(x))) { - x$el[[attrname]] <- vector(mode = "list", length = network.edgecount(x, na.omit = FALSE)) + if (missing(e)) { + ## just set everything + x$el[[attrname]] <- rep(value, length.out = network.edgecount(x, na.omit = FALSE)) + } else { + if (!(attrname %in% list.edge.attributes(x))) { + ## new attr; set up as list since e isn't missing + x$el[[attrname]] <- vector(mode = "list", length = network.edgecount(x, na.omit = FALSE)) + } else if (upcast == FALSE && !identical(class(value), class(x$el[[attrname]]))) { + ## existing attr; need to watch upcasting + x$el[[attrname]] <- as.list(x$el[[attrname]]) + } + x$el[[attrname]][e] <- value } - ## may upcast atomic types if both are atomic - x$el[[attrname]][e] <- value - on.exit(eval.parent(call("<-", xn, x))) invisible(x) } @@ -195,15 +216,25 @@ set.edge.attribute.networkLite <- function( #' set.edge.value.networkLite <- function( x, attrname, value, - e = seq_len(network.edgecount(x, na.omit = FALSE)), ...) { + e = seq_len(network.edgecount(x, na.omit = FALSE)), ..., upcast = TRUE) { xn <- substitute(x) - if (!(attrname %in% list.edge.attributes(x))) { - x$el[[attrname]] <- vector(mode = "list", length = network.edgecount(x, na.omit = FALSE)) - } + value <- value[cbind(x$el$.tail[e], x$el$.head[e])] - x$el[[attrname]][e] <- value[as.matrix(x$el[e, c(".tail", ".head")])] + if (missing(e)) { + ## just set everything + x$el[[attrname]] <- rep(value, length.out = network.edgecount(x, na.omit = FALSE)) + } else { + if (!(attrname %in% list.edge.attributes(x))) { + ## new attr; set up as list since e isn't missing + x$el[[attrname]] <- vector(mode = "list", length = network.edgecount(x, na.omit = FALSE)) + } else if (upcast == FALSE && !identical(class(value), class(x$el[[attrname]]))) { + ## existing attr; need to watch upcasting + x$el[[attrname]] <- as.list(x$el[[attrname]]) + } + x$el[[attrname]][e] <- value + } on.exit(eval.parent(call("<-", xn, x))) invisible(x) diff --git a/R/constructors.R b/R/constructors.R index 511a560..5e5a7ce 100644 --- a/R/constructors.R +++ b/R/constructors.R @@ -31,6 +31,9 @@ #' length equal to the number of nodes in the network. #' @param directed,bipartite Common network attributes that may be set via #' arguments to the \code{networkLite.numeric} method. +#' @param atomize Logical; should we call \code{\link{atomize}} on the +#' \code{networkLite} before returning it? Note that unlike +#' \code{\link{as.networkLite}}, the default value here is \code{FALSE}. #' @param ... additional arguments #' #' @details Currently there are several distinct \code{networkLite} constructor @@ -83,7 +86,8 @@ networkLite.edgelist <- function( x, attr = list(vertex.names = seq_len(attributes(x)[["n"]]), na = logical(attributes(x)[["n"]])), - ...) { + ..., + atomize = FALSE) { if (is_tibble(x)) { if (!(".tail" %in% names(x)) || !(".head" %in% names(x))) { @@ -141,6 +145,11 @@ networkLite.edgelist <- function( nw$gal[["n"]] <- as.numeric(nw$gal[["n"]]) class(nw) <- c("networkLite", "network") + + if (atomize == TRUE) { + nw <- atomize(nw, ...) + } + return(nw) } diff --git a/R/matrix_conversions.R b/R/matrix_conversions.R index d3a9379..9fe2aed 100644 --- a/R/matrix_conversions.R +++ b/R/matrix_conversions.R @@ -43,7 +43,7 @@ as.edgelist.networkLite <- function(x, attrname = NULL, } if (output == "tibble") { - m <- atomize_tibble(m) + m <- atomize(m, ...) } attr(m, "dimnames") <- NULL @@ -72,7 +72,7 @@ as_tibble.networkLite <- function(x, attrnames = NULL, na.rm = TRUE, ...) { na <- NVL(x %e% "na", logical(NROW(out))) out <- out[!na, ] } - out <- atomize_tibble(out) + out <- atomize(out, ...) attr(out, "n") <- network.size(x) attr(out, "vnames") <- network.vertex.names(x) if (is.bipartite(x)) attr(out, "bipartite") <- x %n% "bipartite" diff --git a/R/utils.R b/R/utils.R index 2bf8c23..94fd58e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,20 +1,47 @@ -## atomize a networkLite -## convert vertex and edge attributes to atomic vectors where possible; -## note that this may upcast atomic types, e.g. logical -> numeric -> character -atomize <- function(nwL) { - nwL$el <- atomize_tibble(nwL$el) # also applies to .tail, .head - nwL$attr <- atomize_tibble(nwL$attr) - nwL +#' @rdname atomize +#' @title Convert Lists to Atomic Vectors Where Possible +#' @param x A \code{networkLite} or \code{tibble} object. +#' @param upcast logical; are we allowed to upcast atomic types when converting +#' lists to atomic vectors? +#' @param ... additional arguments +#' @details The \code{tibble} method examines each column of the \code{tibble} +#' and replaces the column with the result of calling \code{unlist} on +#' the column if all of the following are true: the column +#' \code{is.list} of length greater than zero, each element of which +#' \code{is.atomic} of length one, and either \code{upcast} is +#' \code{TRUE} or there is only one unique class amongst all elements +#' of the column. +#' +#' The \code{networkLite} method applies the \code{tibble} method to +#' the edgelist and vertex attribute \code{tibble}s in the +#' \code{networkLite}. +#' +#' @export +#' +atomize <- function(x, ...) { + UseMethod("atomize") } -## atomize a tibble; as for networkLites -atomize_tibble <- function(x) { +#' @rdname atomize +#' @export +#' +atomize.networkLite <- function(x, ..., upcast = TRUE) { + x$el <- atomize(x$el, ..., upcast = upcast) # also applies to .tail, .head + x$attr <- atomize(x$attr, ..., upcast = upcast) + x +} + +#' @rdname atomize +#' @export +#' +atomize.tbl_df <- function(x, ..., upcast = TRUE) { for (name in names(x)) { value <- x[[name]] - if (length(value) > 0 && - !is.atomic(value) && + if (is.list(value) && + length(value) > 0 && all(unlist(lapply(value, is.atomic))) && - all(unlist(lapply(value, length)) == 1)) { + all(unlist(lapply(value, length)) == 1) && + (upcast == TRUE || length(unique(unlist(lapply(value, class)))) == 1)) { x[[name]] <- unlist(value) } } diff --git a/man/as_networkLite.Rd b/man/as_networkLite.Rd index 7daf0b7..c230cdc 100644 --- a/man/as_networkLite.Rd +++ b/man/as_networkLite.Rd @@ -8,7 +8,7 @@ \usage{ as.networkLite(x, ...) -\method{as.networkLite}{network}(x, ...) +\method{as.networkLite}{network}(x, ..., atomize = TRUE) \method{as.networkLite}{networkLite}(x, ...) } @@ -16,6 +16,9 @@ as.networkLite(x, ...) \item{x}{A \code{network} or \code{networkLite} object.} \item{...}{additional arguments} + +\item{atomize}{Logical; should we call \code{\link{atomize}} on the +\code{networkLite} before returning it?} } \value{ A corresponding \code{networkLite} object. @@ -32,6 +35,9 @@ Convert to \code{networkLite} Representation \code{loops} must be \code{FALSE} for \code{networkLite}s; attempting to convert a \code{network} to a \code{networkLite} when this is not the case will result in an error. + + The \code{...} are passed to \code{\link{atomize}} and can be used + to set the \code{upcast} argument controlling attribute conversion. } \seealso{ \code{\link{to_network_networkLite}} diff --git a/man/atomize.Rd b/man/atomize.Rd new file mode 100644 index 0000000..f8fece2 --- /dev/null +++ b/man/atomize.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{atomize} +\alias{atomize} +\alias{atomize.networkLite} +\alias{atomize.tbl_df} +\title{Convert Lists to Atomic Vectors Where Possible} +\usage{ +atomize(x, ...) + +\method{atomize}{networkLite}(x, ..., upcast = TRUE) + +\method{atomize}{tbl_df}(x, ..., upcast = TRUE) +} +\arguments{ +\item{x}{A \code{networkLite} or \code{tibble} object.} + +\item{...}{additional arguments} + +\item{upcast}{logical; are we allowed to upcast atomic types when converting +lists to atomic vectors?} +} +\description{ +Convert Lists to Atomic Vectors Where Possible +} +\details{ +The \code{tibble} method examines each column of the \code{tibble} + and replaces the column with the result of calling \code{unlist} on + the column if all of the following are true: the column + \code{is.list} of length greater than zero, each element of which + \code{is.atomic} of length one, and either \code{upcast} is + \code{TRUE} or there is only one unique class amongst all elements + of the column. + + The \code{networkLite} method applies the \code{tibble} method to + the edgelist and vertex attribute \code{tibble}s in the + \code{networkLite}. +} diff --git a/man/attribute_methods.Rd b/man/attribute_methods.Rd index 33a3bf0..90b504e 100644 --- a/man/attribute_methods.Rd +++ b/man/attribute_methods.Rd @@ -19,7 +19,14 @@ \usage{ \method{get.vertex.attribute}{networkLite}(x, attrname, ..., null.na = TRUE, unlist = TRUE) -\method{set.vertex.attribute}{networkLite}(x, attrname, value, v = seq_len(network.size(x)), ...) +\method{set.vertex.attribute}{networkLite}( + x, + attrname, + value, + v = seq_len(network.size(x)), + ..., + upcast = TRUE +) \method{list.vertex.attributes}{networkLite}(x, ...) @@ -38,7 +45,8 @@ attrname, value, e = seq_len(network.edgecount(x, na.omit = FALSE)), - ... + ..., + upcast = TRUE ) \method{set.edge.value}{networkLite}( @@ -46,7 +54,8 @@ attrname, value, e = seq_len(network.edgecount(x, na.omit = FALSE)), - ... + ..., + upcast = TRUE ) \method{list.edge.attributes}{networkLite}(x, ...) @@ -81,10 +90,17 @@ attribute value before returning it, and if \code{unlist} is \code{FALSE}, we return the attribute value without any modification.} \item{value}{The attribute value to set in vertex, edge, and network -attribute setters.} +attribute setters. For vertex and edge attribute methods, +\code{value} should be either an atomic vector or a list, of length +equal to that of \code{v} or \code{e}.} \item{v}{Indices at which to set vertex attribute values.} +\item{upcast}{Logical. Are we allowed to upcast atomic types when setting +vertex or edge attribute values on the \code{networkLite}? Setting +\code{upcast = FALSE} prevents upcasting, while setting +\code{upcast = TRUE} allows but does not guarantee upcasting.} + \item{e}{Indices at which to set edge attribute values.} } \value{ diff --git a/man/constructors.Rd b/man/constructors.Rd index cdfc353..3a170a3 100644 --- a/man/constructors.Rd +++ b/man/constructors.Rd @@ -14,14 +14,16 @@ networkLite(x, ...) x, attr = list(vertex.names = seq_len(attributes(x)[["n"]]), na = logical(attributes(x)[["n"]])), - ... + ..., + atomize = FALSE ) \method{networkLite}{matrix}( x, attr = list(vertex.names = seq_len(attributes(x)[["n"]]), na = logical(attributes(x)[["n"]])), - ... + ..., + atomize = FALSE ) \method{networkLite}{numeric}(x, directed = FALSE, bipartite = FALSE, ...) @@ -58,6 +60,10 @@ networkLite_initialize(x, directed = FALSE, bipartite = FALSE, ...) Each element of \code{attr} should be an atomic vector or list of length equal to the number of nodes in the network.} +\item{atomize}{Logical; should we call \code{\link{atomize}} on the +\code{networkLite} before returning it? Note that unlike +\code{\link{as.networkLite}}, the default value here is \code{FALSE}.} + \item{directed, bipartite}{Common network attributes that may be set via arguments to the \code{networkLite.numeric} method.} } diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index 0c603ff..c9eeb04 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -89,6 +89,128 @@ create_random_edgelist <- function(n_nodes, directed, bipartite, target_n_edges) structure(el, n = n_nodes, directed = directed, bipartite = bipartite) } +test_that("setting vertex and edge attributes", { + nw <- network.initialize(5, directed = FALSE) + + nw[1,2] <- 1 + nw[1,3] <- 1 + nw[2,4] <- 1 + nw[3,5] <- 1 + + set.vertex.attribute(nw, "v1", list(1,2L)) + set.vertex.attribute(nw, "v2", list(1,2L,"a")) + set.vertex.attribute(nw, "v3", c(1,2)) + set.edge.attribute(nw, "e1", list(1,2L)) + set.edge.attribute(nw, "e2", list(1,2L,"a")) + set.edge.attribute(nw, "e3", c(1,2)) + + nwL <- as.networkLite(nw) + set.vertex.attribute(nwL, "v1", list(1,2L)) + set.vertex.attribute(nwL, "v2", list(1,2L,"a")) + set.vertex.attribute(nwL, "v3", c(1,2)) + set.edge.attribute(nwL, "e1", list(1,2L)) + set.edge.attribute(nwL, "e2", list(1,2L,"a")) + set.edge.attribute(nwL, "e3", c(1,2)) + + expect_equiv_nets(nw, nwL) + + expect_identical(nwL$el[["e3"]], c(1,2,1,2)) + + set.edge.attribute(nwL, "e3", c(1L, 2L), c(1,3), upcast = FALSE) + expect_identical(nwL$el[["e3"]], list(1L,2,2L,2)) + set.edge.attribute(nwL, "e3", c(1,2)) + expect_identical(nwL$el[["e3"]], c(1,2,1,2)) + nwL <- atomize(nwL) + expect_identical(nwL$el[["e3"]], c(1,2,1,2)) + set.edge.attribute(nwL, "e3", c(1L, 2L), c(1,3), upcast = TRUE) + expect_identical(nwL$el[["e3"]], c(1,2,2,2)) + delete.edge.attribute(nwL, "e3") + set.edge.attribute(nwL, "e3", c(1L,2L,3L,4L)) + expect_identical(nwL$el[["e3"]], c(1L,2L,3L,4L)) + set.edge.attribute(nwL, "e3", c(1, 2), c(1,3), upcast = FALSE) + expect_identical(nwL$el[["e3"]], list(1,2L,2,4L)) + set.edge.attribute(nwL, "e3", c(1L,2L,3L,4L)) + expect_identical(nwL$el[["e3"]], c(1L,2L,3L,4L)) + set.edge.attribute(nwL, "e3", c(1, 2), c(1,3), upcast = TRUE) + expect_identical(nwL$el[["e3"]], c(1,2,2,4)) + set.edge.attribute(nwL, "e3", list(1, 2)) + expect_identical(nwL$el[["e3"]], list(1,2,1,2)) + + expect_identical(nwL$attr[["v3"]], c(1,2,1,2,1)) + + set.vertex.attribute(nwL, "v3", c(1L, 2L), c(1,3), upcast = FALSE) + expect_identical(nwL$attr[["v3"]], list(1L,2,2L,2,1)) + set.vertex.attribute(nwL, "v3", c(1,2)) + expect_identical(nwL$attr[["v3"]], c(1,2,1,2,1)) + nwL <- atomize(nwL) + expect_identical(nwL$attr[["v3"]], c(1,2,1,2,1)) + set.vertex.attribute(nwL, "v3", c(1L, 2L), c(1,3), upcast = TRUE) + expect_identical(nwL$attr[["v3"]], c(1,2,2,2,1)) + delete.vertex.attribute(nwL, "v3") + set.vertex.attribute(nwL, "v3", c(1L,2L,3L,4L,5L)) + expect_identical(nwL$attr[["v3"]], c(1L,2L,3L,4L,5L)) + set.vertex.attribute(nwL, "v3", c(1, 2), c(1,3), upcast = FALSE) + expect_identical(nwL$attr[["v3"]], list(1,2L,2,4L,5L)) + set.vertex.attribute(nwL, "v3", c(1L,2L,3L,4L,5L)) + expect_identical(nwL$attr[["v3"]], c(1L,2L,3L,4L,5L)) + set.vertex.attribute(nwL, "v3", c(1, 2), c(1,3), upcast = TRUE) + expect_identical(nwL$attr[["v3"]], c(1,2,2,4,5)) + set.vertex.attribute(nwL, "v3", list(1, 2)) + expect_identical(nwL$attr[["v3"]], list(1,2,1,2,1)) +}) + +test_that("atomize and upcast work as intended", { + nw <- network.initialize(5, directed = FALSE) + + nw[1,2] <- 1 + nw[1,3] <- 1 + nw[2,4] <- 1 + nw[3,5] <- 1 + + set.vertex.attribute(nw, "v1", list(1,2,"a","b",FALSE)) + set.vertex.attribute(nw, "v2", list(1,2,NULL,4,5)) + set.vertex.attribute(nw, "v3", list(1,2,3L,4,5)) + set.vertex.attribute(nw, "v4", list(1,2,3,4,5)) + set.edge.attribute(nw, "e1", list(1,2,"a",FALSE)) + set.edge.attribute(nw, "e2", list(1,2,NULL,4)) + set.edge.attribute(nw, "e3", list(1,2,3L,4)) + set.edge.attribute(nw, "e4", list(1,2,3,4)) + + nwL <- as.networkLite(nw) + nwL_na <- as.networkLite(nw, atomize = FALSE) + nwL_nu <- as.networkLite(nw, upcast = FALSE) + + expect_identical(nwL$el[["e1"]], c("1","2","a","FALSE")) + expect_identical(nwL$el[["e2"]], list(1,2,NULL,4)) + expect_identical(nwL$el[["e3"]], c(1,2,3,4)) + expect_identical(nwL$el[["e4"]], c(1,2,3,4)) + + expect_identical(nwL$attr[["v1"]], c("1","2","a","b","FALSE")) + expect_identical(nwL$attr[["v2"]], list(1,2,NULL,4,5)) + expect_identical(nwL$attr[["v3"]], c(1,2,3,4,5)) + expect_identical(nwL$attr[["v4"]], c(1,2,3,4,5)) + + expect_identical(nwL_na$el[["e1"]], list(1,2,"a",FALSE)) + expect_identical(nwL_na$el[["e2"]], list(1,2,NULL,4)) + expect_identical(nwL_na$el[["e3"]], list(1,2,3L,4)) + expect_identical(nwL_na$el[["e4"]], list(1,2,3,4)) + + expect_identical(nwL_na$attr[["v1"]], list(1,2,"a","b",FALSE)) + expect_identical(nwL_na$attr[["v2"]], list(1,2,NULL,4,5)) + expect_identical(nwL_na$attr[["v3"]], list(1,2,3L,4,5)) + expect_identical(nwL_na$attr[["v4"]], list(1,2,3,4,5)) + + expect_identical(nwL_nu$el[["e1"]], list(1,2,"a",FALSE)) + expect_identical(nwL_nu$el[["e2"]], list(1,2,NULL,4)) + expect_identical(nwL_nu$el[["e3"]], list(1,2,3L,4)) + expect_identical(nwL_nu$el[["e4"]], c(1,2,3,4)) + + expect_identical(nwL_nu$attr[["v1"]], list(1,2,"a","b",FALSE)) + expect_identical(nwL_nu$attr[["v2"]], list(1,2,NULL,4,5)) + expect_identical(nwL_nu$attr[["v3"]], list(1,2,3L,4,5)) + expect_identical(nwL_nu$attr[["v4"]], c(1,2,3,4,5)) +}) + test_that("setting vertex and edge attributes in strange ways", { el <- cbind(c(1,2,3,3), c(2,5,4,5)) attr(el, "n") <- 5 From 175fd8a6d9cc181b3bed115e3157d350f6941434 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Mon, 19 Sep 2022 14:07:01 -0700 Subject: [PATCH 41/49] documentation update --- R/attribute_methods.R | 8 +++++--- man/attribute_methods.Rd | 8 +++++--- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/R/attribute_methods.R b/R/attribute_methods.R index de3e6c5..6373957 100644 --- a/R/attribute_methods.R +++ b/R/attribute_methods.R @@ -9,9 +9,11 @@ #' @param attrname The name of an attribute in \code{x}; must be a length one #' character vector. #' @param value The attribute value to set in vertex, edge, and network -#' attribute setters. For vertex and edge attribute methods, -#' \code{value} should be either an atomic vector or a list, of length -#' equal to that of \code{v} or \code{e}. +#' attribute setters. For \code{set.vertex.attribute} and +#' \code{set.edge.attribute}, \code{value} should be either an atomic +#' vector or a list, of length equal to that of \code{v} or \code{e}. +#' For \code{set.edge.value}, it should be an \code{n} by \code{n} +#' matrix where \code{n} is the network size of \code{x}. #' @param v Indices at which to set vertex attribute values. #' @param e Indices at which to set edge attribute values. #' @param null.na Logical. If \code{TRUE}, replace \code{NULL} attribute values diff --git a/man/attribute_methods.Rd b/man/attribute_methods.Rd index 90b504e..2a4c9ae 100644 --- a/man/attribute_methods.Rd +++ b/man/attribute_methods.Rd @@ -90,9 +90,11 @@ attribute value before returning it, and if \code{unlist} is \code{FALSE}, we return the attribute value without any modification.} \item{value}{The attribute value to set in vertex, edge, and network -attribute setters. For vertex and edge attribute methods, -\code{value} should be either an atomic vector or a list, of length -equal to that of \code{v} or \code{e}.} +attribute setters. For \code{set.vertex.attribute} and +\code{set.edge.attribute}, \code{value} should be either an atomic +vector or a list, of length equal to that of \code{v} or \code{e}. +For \code{set.edge.value}, it should be an \code{n} by \code{n} +matrix where \code{n} is the network size of \code{x}.} \item{v}{Indices at which to set vertex attribute values.} From 44cc8dff9060156eebd90262b2b3b2a7a18164d7 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 21 Sep 2022 09:21:03 -0700 Subject: [PATCH 42/49] various updates --- R/add_edges.R | 14 +++++++------- R/add_vertices.R | 6 +++--- R/constructors.R | 11 +++++++++-- R/misc.R | 14 ++++++++------ R/networkLite-package.R | 14 ++++++++++---- man/networkLite-package.Rd | 14 ++++++++++---- tests/testthat/test-networkLite.R | 28 ++++++++++++++++++++++++++++ 7 files changed, 75 insertions(+), 26 deletions(-) diff --git a/R/add_edges.R b/R/add_edges.R index 5dafa4b..7e0ed06 100644 --- a/R/add_edges.R +++ b/R/add_edges.R @@ -25,8 +25,8 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, vals.eval = NULL, ...) { ## convert to atomic... - tail <- NVL(unlist(tail), integer(0)) - head <- NVL(unlist(head), integer(0)) + tail <- NVL(as.integer(unlist(tail)), integer(0)) + head <- NVL(as.integer(unlist(head)), integer(0)) ## if we were passed any attribute information... if (length(unlist(names.eval)) > 0) { @@ -48,7 +48,7 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, } if ("na" %in% names(update_list)) { - update_list[["na"]] <- lapply(update_list[["na"]], function(val) if (is.null(val) || is.na(val)) FALSE else val) + update_list[["na"]] <- lapply(update_list[["na"]], isTRUE) } else { update_list <- c(update_list, list(na = logical(length(tail)))) } @@ -123,8 +123,8 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, w <- w[w[, 1] != w[, 2], , drop = FALSE] } w <- w[order(w[, 1], w[, 2]), , drop = FALSE] - x$el <- as_tibble(list(.tail = w[, 1], - .head = w[, 2], + x$el <- as_tibble(list(.tail = as.integer(w[, 1]), + .head = as.integer(w[, 2]), na = logical(NROW(w)))) } else { if (!add.edges) { @@ -153,12 +153,12 @@ add.edges.networkLite <- function(x, tail, head, names.eval = NULL, w <- w[order(w[, 1], w[, 2]), , drop = FALSE] if (names.eval == "na") { vals[is.na(vals)] <- FALSE - tbl_list <- list(w[, 1], w[, 2], vals) + tbl_list <- list(as.integer(w[, 1]), as.integer(w[, 2]), vals) names(tbl_list) <- c(".tail", ".head", names.eval) } else { - tbl_list <- list(w[, 1], w[, 2], vals, logical(NROW(w))) + tbl_list <- list(as.integer(w[, 1]), as.integer(w[, 2]), vals, logical(NROW(w))) names(tbl_list) <- c(".tail", ".head", names.eval, "na") } x$el <- as_tibble(tbl_list) diff --git a/R/add_vertices.R b/R/add_vertices.R index c78d313..2788e20 100644 --- a/R/add_vertices.R +++ b/R/add_vertices.R @@ -42,7 +42,7 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL, } if ("na" %in% names(update_list)) { - update_list[["na"]] <- lapply(update_list[["na"]], function(val) if (is.null(val) || is.na(val)) FALSE else val) + update_list[["na"]] <- lapply(update_list[["na"]], isTRUE) } else { update_list <- c(update_list, list(na = logical(nv))) } @@ -59,8 +59,8 @@ add.vertices.networkLite <- function(x, nv, vattr = NULL, } x$attr <- dplyr::bind_rows(ensure_list(list(x$attr[seq_len(offset), ], - update_tibble, - x$attr[offset + seq_len(oldsize - offset), ]))) + update_tibble, + x$attr[offset + seq_len(oldsize - offset), ]))) } on.exit(eval.parent(call("<-", xn, x))) diff --git a/R/constructors.R b/R/constructors.R index 5e5a7ce..0c17648 100644 --- a/R/constructors.R +++ b/R/constructors.R @@ -109,8 +109,15 @@ networkLite.edgelist <- function( "vnames", "row.names", "names", "mnext"))]) - nw$el[["na"]] <- NVL(nw$el[["na"]], logical(NROW(nw$el))) - nw$el[["na"]][is.na(nw$el[["na"]])] <- FALSE + if ("na" %in% names(nw$el)) { + if (is.logical(nw$el[["na"]])) { + nw$el[["na"]][is.na(nw$el[["na"]])] <- FALSE + } else { + nw$el[["na"]] <- lapply(nw$el[["na"]], isTRUE) + } + } else { + nw$el[["na"]] <- logical(NROW(nw$el)) + } # network size attribute is required if (is.null(nw$gal[["n"]])) { diff --git a/R/misc.R b/R/misc.R index 9c6090e..e461685 100644 --- a/R/misc.R +++ b/R/misc.R @@ -82,11 +82,12 @@ is.na.networkLite <- function(x) { } if (network.edgecount(e2, na.omit = FALSE) > 0) { - edgelist <- dplyr::bind_rows(ensure_list(list(e1$el, e2$el))) - edgelist <- edgelist[!duplicated(edgelist[, c(".tail", ".head")]), ] + edgelist <- tibble(.tail = c(e1$el$.tail, e2$el$.tail), + .head = c(e1$el$.head, e2$el$.head)) + edgelist <- edgelist[!duplicated(edgelist), ] edgelist <- edgelist[order(edgelist$.tail, edgelist$.head), ] } else { - edgelist <- e1$el + edgelist <- tibble(.tail = e1$el$.tail, .head = e1$el$.head) } out <- networkLite(e1 %n% "n", e1 %n% "directed", e1 %n% "bipartite") out <- add.edges(out, edgelist$.tail, edgelist$.head) @@ -109,12 +110,13 @@ is.na.networkLite <- function(x) { } if (network.edgecount(e2, na.omit = FALSE) > 0) { - edgelist <- dplyr::bind_rows(ensure_list(list(e2$el, e1$el))) - nd <- !duplicated(edgelist[, c(".tail", ".head")]) + edgelist <- tibble(.tail = c(e2$el$.tail, e1$el$.tail), + .head = c(e2$el$.head, e1$el$.head)) + nd <- !duplicated(edgelist) edgelist <- e1$el[nd[-seq_len(network.edgecount(e2, na.omit = FALSE))], ] edgelist <- edgelist[order(edgelist$.tail, edgelist$.head), ] } else { - edgelist <- e1$el + edgelist <- tibble(.tail = e1$el$.tail, .head = e1$el$.head) } out <- networkLite(e1 %n% "n", e1 %n% "directed", e1 %n% "bipartite") out <- add.edges(out, edgelist$.tail, edgelist$.head) diff --git a/R/networkLite-package.R b/R/networkLite-package.R index 8f2529b..eb82ff3 100644 --- a/R/networkLite-package.R +++ b/R/networkLite-package.R @@ -22,12 +22,18 @@ #' Certain names in \code{el}, \code{attr}, and \code{gal} have special #' significance. These are #' \itemize{ -#' \item for \code{el}: \code{".tail"} and \code{".head"}, which are the tails -#' and heads of edges, and \code{"na"}, which is a logical attribute indicating -#' if the edge is missing or not; +#' \item for \code{el}: \code{".tail"} and \code{".head"}, of class integer, +#' which are the tails and heads of edges, and must be preserved as atomic +#' integer vectors with no \code{NA}s; \code{"na"}, which is a logical +#' attribute indicating if the edge is missing or not, and should take +#' \code{TRUE}/\code{FALSE} values only (behavior for other values is +#' undefined, and \code{NA}s are not allowed); \code{"na"} may be structured +#' as either an atomic logical vector or a list #' \item for \code{attr}: \code{"na"}, which is a logical attribute indicating #' if the vertex is missing or not, and \code{"vertex.names"}, which provides -#' names for the vertices in the network; +#' names for the vertices in the network; the attribute \code{"na"} should +#' take values \code{TRUE} or \code{FALSE} only (behavior for other values is +#' undefined) #' \item for \code{gal}: \code{"n"} (the network size), \code{"directed"} (a #' logical indicating if the network is directed), \code{"bipartite"} (either #' \code{FALSE} to indicate the network is not bipartite, or the size of the diff --git a/man/networkLite-package.Rd b/man/networkLite-package.Rd index 1c9b6ed..bc2006a 100644 --- a/man/networkLite-package.Rd +++ b/man/networkLite-package.Rd @@ -25,12 +25,18 @@ how to construct a \code{networkLite}. Certain names in \code{el}, \code{attr}, and \code{gal} have special significance. These are \itemize{ - \item for \code{el}: \code{".tail"} and \code{".head"}, which are the tails - and heads of edges, and \code{"na"}, which is a logical attribute indicating - if the edge is missing or not; + \item for \code{el}: \code{".tail"} and \code{".head"}, of class integer, + which are the tails and heads of edges, and must be preserved as atomic + integer vectors with no \code{NA}s; \code{"na"}, which is a logical + attribute indicating if the edge is missing or not, and should take + \code{TRUE}/\code{FALSE} values only (behavior for other values is + undefined, and \code{NA}s are not allowed); \code{"na"} may be structured + as either an atomic logical vector or a list \item for \code{attr}: \code{"na"}, which is a logical attribute indicating if the vertex is missing or not, and \code{"vertex.names"}, which provides - names for the vertices in the network; + names for the vertices in the network; the attribute \code{"na"} should + take values \code{TRUE} or \code{FALSE} only (behavior for other values is + undefined) \item for \code{gal}: \code{"n"} (the network size), \code{"directed"} (a logical indicating if the network is directed), \code{"bipartite"} (either \code{FALSE} to indicate the network is not bipartite, or the size of the diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index c9eeb04..26f13db 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -89,6 +89,34 @@ create_random_edgelist <- function(n_nodes, directed, bipartite, target_n_edges) structure(el, n = n_nodes, directed = directed, bipartite = bipartite) } +test_that("add edges, add vertices, and ensure_list", { + el <- cbind(1:3, 2:4) + attr(el, "n") <- 5 + nwL <- networkLite(el) + set.edge.attribute(nwL, "e1", 1:3) # compatible atomics + set.edge.attribute(nwL, "e2", 1:3 + 0.5) # incompatible atomics + set.edge.attribute(nwL, "e3", letters[1:3]) # NULL atomic + ## no e4 here # atomic NULL + set.edge.attribute(nwL, "e5", list("a","b","c")) # NULL list + ## no e6 here # list NULL + set.edge.attribute(nwL, "e7", list("a","b","c")) # atomic list + set.edge.attribute(nwL, "e8", c(FALSE, FALSE, TRUE)) # list atomic + + tail <- c(1,3) + head <- c(4,5) + names <- c("e1", "e2", "e4", "e6", "e7", "e8") + names <- rep(list(names), length.out = 2) + vals <- list(list(1L, 1L, FALSE, list(1), "a", list("a")), + list(2L, 2L, TRUE, list(2), "b", list("b"))) + + nwL <- add.edges(nwL, tail = tail, head = head, names.eval = names, vals.eval = vals) + expect_identical(nwL$el$na, logical(5)) + nwL <- add.edges(nwL, tail = c(1,1), head = c(3,5), names.eval = list("na", "na"), vals.eval = list(list(FALSE),list(TRUE))) + expect_identical(nwL$el$na, as.list(c(rep(FALSE, 3), TRUE, rep(FALSE, 3)))) + nwL <- atomize(nwL, upcast = FALSE) + nwL <- atomize(nwL, upcast = TRUE) +}) + test_that("setting vertex and edge attributes", { nw <- network.initialize(5, directed = FALSE) From 87d89a1bbcd9840566fd2a7b7916fb01057e3a81 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 7 Dec 2022 06:12:07 -0800 Subject: [PATCH 43/49] add valid.eids.networkLite --- DESCRIPTION | 2 +- NAMESPACE | 1 + R/misc.R | 12 ++++++++++++ man/valid.eids.Rd | 20 ++++++++++++++++++++ 4 files changed, 34 insertions(+), 1 deletion(-) create mode 100644 man/valid.eids.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 9819798..20400d5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -34,5 +34,5 @@ Imports: dplyr Suggests: testthat -RoxygenNote: 7.2.1 +RoxygenNote: 7.2.2 Encoding: UTF-8 diff --git a/NAMESPACE b/NAMESPACE index f4079af..d85860f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -35,6 +35,7 @@ S3method(set.edge.attribute,networkLite) S3method(set.edge.value,networkLite) S3method(set.network.attribute,networkLite) S3method(set.vertex.attribute,networkLite) +S3method(valid.eids,networkLite) export(as.networkLite) export(atomize) export(networkLite) diff --git a/R/misc.R b/R/misc.R index e461685..393488a 100644 --- a/R/misc.R +++ b/R/misc.R @@ -122,3 +122,15 @@ is.na.networkLite <- function(x) { out <- add.edges(out, edgelist$.tail, edgelist$.head) out } + +#' @rdname valid.eids +#' @title valid.eids +#' @param x A \code{networkLite} object. +#' @details Returns \code{seq_len(network.edgecount(x, na.omit = FALSE))}, to +#' support the edge attribute assignment operator \code{\%e\%<-}. Note +#' that the edge id of an edge in \code{x} is simply its row index +#' within \code{x$el}. +#' @export +valid.eids.networkLite <- function(x, ...) { + seq_len(network.edgecount(x, na.omit = FALSE)) +} diff --git a/man/valid.eids.Rd b/man/valid.eids.Rd new file mode 100644 index 0000000..864b2fd --- /dev/null +++ b/man/valid.eids.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/misc.R +\name{valid.eids.networkLite} +\alias{valid.eids.networkLite} +\title{valid.eids} +\usage{ +\method{valid.eids}{networkLite}(x, ...) +} +\arguments{ +\item{x}{A \code{networkLite} object.} +} +\description{ +valid.eids +} +\details{ +Returns \code{seq_len(network.edgecount(x, na.omit = FALSE))}, to + support the edge attribute assignment operator \code{\%e\%<-}. Note + that the edge id of an edge in \code{x} is simply its row index + within \code{x$el}. +} From 9bcecc2c90c0f14519cece4229eecb8329417d98 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 7 Dec 2022 06:22:41 -0800 Subject: [PATCH 44/49] add delete.edges.networkLite --- NAMESPACE | 1 + R/delete_edges.R | 20 ++++++++++++++++++++ man/delete_edges.Rd | 19 +++++++++++++++++++ 3 files changed, 40 insertions(+) create mode 100644 R/delete_edges.R create mode 100644 man/delete_edges.Rd diff --git a/NAMESPACE b/NAMESPACE index d85860f..2754811 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -14,6 +14,7 @@ S3method(as_tibble,networkLite) S3method(atomize,networkLite) S3method(atomize,tbl_df) S3method(delete.edge.attribute,networkLite) +S3method(delete.edges,networkLite) S3method(delete.network.attribute,networkLite) S3method(delete.vertex.attribute,networkLite) S3method(get.edge.attribute,networkLite) diff --git a/R/delete_edges.R b/R/delete_edges.R new file mode 100644 index 0000000..ee0c250 --- /dev/null +++ b/R/delete_edges.R @@ -0,0 +1,20 @@ +#' @rdname delete_edges +#' @title Delete edges from a networkLite. +#' @param x A \code{networkLite} object. +#' @param eid Edge ids (between \code{1} and +#' \code{network.edgecount(x, na.omit = FALSE)}) to delete in +#' \code{x}. Note that the edge id of an edge in \code{x} is simply +#' its row index in \code{x$el}. +#' @export +delete.edges.networkLite <- function(x, eid, ...) { + xn <- substitute(x) + + eid <- as.integer(eid) + eid <- eid[eid >= 1 & eid <= network.edgecount(x, na.omit = FALSE)] + if (length(eid) > 0) { + x$el <- x$el[-eid, ] + } + + on.exit(eval.parent(call("<-", xn, x))) + invisible(x) +} diff --git a/man/delete_edges.Rd b/man/delete_edges.Rd new file mode 100644 index 0000000..2f528dd --- /dev/null +++ b/man/delete_edges.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/delete_edges.R +\name{delete.edges.networkLite} +\alias{delete.edges.networkLite} +\title{Delete edges from a networkLite.} +\usage{ +\method{delete.edges}{networkLite}(x, eid, ...) +} +\arguments{ +\item{x}{A \code{networkLite} object.} + +\item{eid}{Edge ids (between \code{1} and +\code{network.edgecount(x, na.omit = FALSE)}) to delete in +\code{x}. Note that the edge id of an edge in \code{x} is simply +its row index in \code{x$el}.} +} +\description{ +Delete edges from a networkLite. +} From b74e6a6d552d13446e6bf19f18d4531234674205 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 7 Dec 2022 06:32:28 -0800 Subject: [PATCH 45/49] add delete.vertices.networkLite --- NAMESPACE | 1 + R/delete_vertices.R | 38 ++++++++++++++++++++++++++++++++++++++ man/delete_vertices.Rd | 18 ++++++++++++++++++ 3 files changed, 57 insertions(+) create mode 100644 R/delete_vertices.R create mode 100644 man/delete_vertices.Rd diff --git a/NAMESPACE b/NAMESPACE index 2754811..78ab4f1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,6 +17,7 @@ S3method(delete.edge.attribute,networkLite) S3method(delete.edges,networkLite) S3method(delete.network.attribute,networkLite) S3method(delete.vertex.attribute,networkLite) +S3method(delete.vertices,networkLite) S3method(get.edge.attribute,networkLite) S3method(get.edge.value,networkLite) S3method(get.network.attribute,networkLite) diff --git a/R/delete_vertices.R b/R/delete_vertices.R new file mode 100644 index 0000000..2824063 --- /dev/null +++ b/R/delete_vertices.R @@ -0,0 +1,38 @@ +#' @rdname delete_vertices +#' @title Delete vertices from a networkLite. +#' @param x A \code{networkLite} object. +#' @param vid Vertex ids (between \code{1} and \code{network.size(x)}) to delete +#' from \code{x}. Note that edges involving deleted vertices will +#' also be deleted. +#' @export +delete.vertices.networkLite <- function(x, vid, ...) { + xn <- substitute(x) + + vid <- as.integer(vid) + vid <- vid[vid >= 1 & vid <= network.size(x)] + if (length(vid) > 0) { + # drop edges with deleted nodes + x$el <- x$el[!(x$el$.tail %in% vid | x$el$.head %in% vid), ] + + # drop vertex attributes for deleted nodes + x$attr <- x$attr[-vid, ] + + # remap nodal indices for remaining edges + a <- seq_len(network.size(x)) + b <- integer(network.size(x)) + b[vid] <- 1L + b <- cumsum(b) + a <- a - b + x$el$.tail <- a[x$el$.tail] + x$el$.head <- a[x$el$.head] + + # update network attributes + x %n% "n" <- x %n% "n" - length(vid) + if (is.bipartite(x)) { + x %n% "bipartite" <- x %n% "bipartite" - sum(vid <= x %n% "bipartite") + } + } + + on.exit(eval.parent(call("<-", xn, x))) + invisible(x) +} diff --git a/man/delete_vertices.Rd b/man/delete_vertices.Rd new file mode 100644 index 0000000..5d7af6e --- /dev/null +++ b/man/delete_vertices.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/delete_vertices.R +\name{delete.vertices.networkLite} +\alias{delete.vertices.networkLite} +\title{Delete vertices from a networkLite.} +\usage{ +\method{delete.vertices}{networkLite}(x, vid, ...) +} +\arguments{ +\item{x}{A \code{networkLite} object.} + +\item{vid}{Vertex ids (between \code{1} and \code{network.size(x)}) to delete +from \code{x}. Note that edges involving deleted vertices will +also be deleted.} +} +\description{ +Delete vertices from a networkLite. +} From 6f17e76b9a00b8dbee12073d44c39589c5240b9a Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Wed, 7 Dec 2022 06:51:21 -0800 Subject: [PATCH 46/49] documentation updates --- R/delete_edges.R | 2 ++ R/delete_vertices.R | 2 ++ R/misc.R | 1 + man/delete_edges.Rd | 2 ++ man/delete_vertices.Rd | 2 ++ man/valid.eids.Rd | 2 ++ 6 files changed, 11 insertions(+) diff --git a/R/delete_edges.R b/R/delete_edges.R index ee0c250..88d1c79 100644 --- a/R/delete_edges.R +++ b/R/delete_edges.R @@ -1,3 +1,4 @@ + #' @rdname delete_edges #' @title Delete edges from a networkLite. #' @param x A \code{networkLite} object. @@ -5,6 +6,7 @@ #' \code{network.edgecount(x, na.omit = FALSE)}) to delete in #' \code{x}. Note that the edge id of an edge in \code{x} is simply #' its row index in \code{x$el}. +#' @param ... additional arguments. #' @export delete.edges.networkLite <- function(x, eid, ...) { xn <- substitute(x) diff --git a/R/delete_vertices.R b/R/delete_vertices.R index 2824063..ff6bc34 100644 --- a/R/delete_vertices.R +++ b/R/delete_vertices.R @@ -1,9 +1,11 @@ + #' @rdname delete_vertices #' @title Delete vertices from a networkLite. #' @param x A \code{networkLite} object. #' @param vid Vertex ids (between \code{1} and \code{network.size(x)}) to delete #' from \code{x}. Note that edges involving deleted vertices will #' also be deleted. +#' @param ... additional arguments. #' @export delete.vertices.networkLite <- function(x, vid, ...) { xn <- substitute(x) diff --git a/R/misc.R b/R/misc.R index 393488a..b31b3cc 100644 --- a/R/misc.R +++ b/R/misc.R @@ -126,6 +126,7 @@ is.na.networkLite <- function(x) { #' @rdname valid.eids #' @title valid.eids #' @param x A \code{networkLite} object. +#' @param ... additional arguments. #' @details Returns \code{seq_len(network.edgecount(x, na.omit = FALSE))}, to #' support the edge attribute assignment operator \code{\%e\%<-}. Note #' that the edge id of an edge in \code{x} is simply its row index diff --git a/man/delete_edges.Rd b/man/delete_edges.Rd index 2f528dd..d678fe8 100644 --- a/man/delete_edges.Rd +++ b/man/delete_edges.Rd @@ -13,6 +13,8 @@ \code{network.edgecount(x, na.omit = FALSE)}) to delete in \code{x}. Note that the edge id of an edge in \code{x} is simply its row index in \code{x$el}.} + +\item{...}{additional arguments.} } \description{ Delete edges from a networkLite. diff --git a/man/delete_vertices.Rd b/man/delete_vertices.Rd index 5d7af6e..98acdd1 100644 --- a/man/delete_vertices.Rd +++ b/man/delete_vertices.Rd @@ -12,6 +12,8 @@ \item{vid}{Vertex ids (between \code{1} and \code{network.size(x)}) to delete from \code{x}. Note that edges involving deleted vertices will also be deleted.} + +\item{...}{additional arguments.} } \description{ Delete vertices from a networkLite. diff --git a/man/valid.eids.Rd b/man/valid.eids.Rd index 864b2fd..1933cb9 100644 --- a/man/valid.eids.Rd +++ b/man/valid.eids.Rd @@ -8,6 +8,8 @@ } \arguments{ \item{x}{A \code{networkLite} object.} + +\item{...}{additional arguments.} } \description{ valid.eids From 48b72831694beaafd7c6c85be2a3be1e36b2e0c3 Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Fri, 9 Dec 2022 07:45:04 -0800 Subject: [PATCH 47/49] add some tests for delete.edges and delete.vertices --- tests/testthat/test-networkLite.R | 63 +++++++++++++++++++++---------- 1 file changed, 44 insertions(+), 19 deletions(-) diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index 26f13db..c8042a0 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -1,6 +1,6 @@ ## test two networks or networkLites for equivalent attributes, edges, etc. ## note that atomic type upcasting in as.networkLite can create comparison issues -expect_equiv_nets <- function(nw1, nw2) { +expect_equiv_nets <- function(nw1, nw2, skip.mnext = FALSE) { if ((is(nw1, "networkLite") && is(nw2, "networkLite")) || (!is(nw1, "networkLite") && !is(nw2, "networkLite"))) { net_attr_1 <- list.network.attributes(nw1) @@ -14,6 +14,12 @@ expect_equiv_nets <- function(nw1, nw2) { net_attr_2 <- list.network.attributes(nw2) } } + + if (skip.mnext == TRUE) { + net_attr_1 <- setdiff(net_attr_1, "mnext") + net_attr_2 <- setdiff(net_attr_2, "mnext") + } + expect_identical(net_attr_1, net_attr_2) @@ -537,7 +543,7 @@ test_that("more tibble tests", { test_that("direct conversion between network and networkLite functions as expected", { net_size <- 100 bip_size <- 40 - edges_target <- net_size + edges_target <- 2*net_size for(directed in list(FALSE, TRUE)) { for(bipartite in list(FALSE, bip_size)) { @@ -546,29 +552,48 @@ test_that("direct conversion between network and networkLite functions as expect } for(last.mode in list(FALSE, TRUE)) { - set.seed(0) - nw <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") - nw %v% "b" <- runif(net_size) - nw %e% "eattr" <- runif(network.edgecount(nw)) - nw %n% "nattr" <- "attr" - add.vertices(nw, 9, vattr = rep(list(list(na = FALSE, vertex.names = NA_integer_, b = NA_real_)), 9), last.mode = last.mode) - set.edge.attribute(nw, "na", sample(c(FALSE, TRUE), network.edgecount(nw), TRUE)) + for(delete in list(FALSE, TRUE)) { + set.seed(0) + nw <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") + nw %v% "b" <- runif(net_size) + nw %e% "eattr" <- runif(network.edgecount(nw)) + nw %n% "nattr" <- "attr" + add.vertices(nw, 9, vattr = rep(list(list(na = FALSE, vertex.names = NA_integer_, b = NA_real_)), 9), last.mode = last.mode) + set.edge.attribute(nw, "na", sample(c(FALSE, TRUE), network.edgecount(nw), TRUE)) + if(delete) { + el <- as.edgelist(nw, attrname = "na", na.rm = FALSE) + w1 <- sample(which(as.logical(el[,3])))[1:3] + w2 <- sample(which(!as.logical(el[,3])))[1:4] + delete.edges(nw, unlist(get.dyads.eids(nw, el[w1,1], el[w1,2], na.omit = FALSE))) + delete.edges(nw, unlist(get.dyads.eids(nw, el[w2,1], el[w2,2], na.omit = FALSE))) + vd <- sample(seq_len(net_size), 10, FALSE) + delete.vertices(nw, vd) + } - set.seed(0) - nwL <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) - nwL %v% "b" <- runif(net_size) - set.edge.attribute(nwL, "eattr", runif(network.edgecount(nwL))) - nwL %n% "nattr" <- "attr" - add.vertices(nwL, 9, vattr = rep(list(list(na = FALSE, vertex.names = NA_integer_, b = NA_real_)), 9), last.mode = last.mode) - set.edge.attribute(nwL, "na", sample(c(FALSE, TRUE), network.edgecount(nwL), TRUE)) + set.seed(0) + nwL <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) + nwL %v% "b" <- runif(net_size) + set.edge.attribute(nwL, "eattr", runif(network.edgecount(nwL))) + nwL %n% "nattr" <- "attr" + add.vertices(nwL, 9, vattr = rep(list(list(na = FALSE, vertex.names = NA_integer_, b = NA_real_)), 9), last.mode = last.mode) + set.edge.attribute(nwL, "na", sample(c(FALSE, TRUE), network.edgecount(nwL), TRUE)) + if(delete) { + el <- as.edgelist(nwL, attrname = "na", na.rm = FALSE) + w1 <- sample(which(as.logical(el[,3])))[1:3] + w2 <- sample(which(!as.logical(el[,3])))[1:4] + delete.edges(nwL, c(w1,w2)) + vd <- sample(seq_len(net_size), 10, FALSE) + delete.vertices(nwL, vd) + } + } expect_equiv_nets(as.networkLite(nw), nwL) expect_equiv_nets(as.networkLite(is.na(nw)), is.na(nwL)) expect_equiv_nets(as.networkLite(is.na(is.na(nw))), is.na(is.na(nwL))) expect_equiv_nets(as.networkLite(is.na(is.na(is.na(nw)))), is.na(is.na(is.na(nwL)))) - expect_equiv_nets(nw, to_network_networkLite(nwL)) - expect_equiv_nets(is.na(nw), to_network_networkLite(is.na(nwL))) + expect_equiv_nets(nw, to_network_networkLite(nwL), skip.mnext = TRUE) + expect_equiv_nets(is.na(nw), to_network_networkLite(is.na(nwL)), skip.mnext = TRUE) } } } @@ -806,7 +831,7 @@ test_that("network and networkLite behave equivalently for basic access and muta nwL %v% "vattr3" <- vattr3 expect_identical(as.edgelist(nw, attrname = "eattr1"), as.edgelist(nwL, attrname = "eattr1")) -# expect_identical(as.edgelist(nw, attrname = "eattr2"), as.edgelist(nwL, attrname = "eattr2")) + expect_identical(as.edgelist(nw, attrname = "eattr2"), as.edgelist(nwL, attrname = "eattr2")) expect_identical(as.edgelist(nw, attrname = "eattr3"), as.edgelist(nwL, attrname = "eattr3")) expect_identical(nw %v% "vattr1", nwL %v% "vattr1") From 991b467261b38e34995cab2d709386b4e3fc53da Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Fri, 9 Dec 2022 08:26:22 -0800 Subject: [PATCH 48/49] add some basic %e%<- tests --- tests/testthat/test-networkLite.R | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index c8042a0..0a1cb8d 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -95,6 +95,36 @@ create_random_edgelist <- function(n_nodes, directed, bipartite, target_n_edges) structure(el, n = n_nodes, directed = directed, bipartite = bipartite) } +test_that("%e%<- behaves as expected", { + net_size <- 100 + bip_size <- 40 + edges_target <- net_size + + for(directed in list(FALSE, TRUE)) { + for(bipartite in list(FALSE, bip_size)) { + if(directed && bipartite) { + next + } + + set.seed(0) + nw <- network(create_random_edgelist(net_size, directed, bipartite, edges_target), directed = directed, bipartite = bipartite, matrix.type = "edgelist") + vals <- runif(network.edgecount(nw)) + valmat <- matrix(runif(network.size(nw)*network.size(nw)), nrow = network.size(nw)) + nw %e% "a1" <- vals + nw %e% "a2" <- valmat + + set.seed(0) + nwL <- networkLite(create_random_edgelist(net_size, directed, bipartite, edges_target)) + vals <- runif(network.edgecount(nwL)) + valmat <- matrix(runif(network.size(nwL)*network.size(nwL)), nrow = network.size(nwL)) + nwL %e% "a1" <- vals + nwL %e% "a2" <- valmat + + expect_equiv_nets(nw, nwL) + } + } +}) + test_that("add edges, add vertices, and ensure_list", { el <- cbind(1:3, 2:4) attr(el, "n") <- 5 From 04439d7b7cc674abcda5b7c8fc75b9b9471c121e Mon Sep 17 00:00:00 2001 From: chad-klumb Date: Sat, 24 Dec 2022 15:26:06 -0800 Subject: [PATCH 49/49] set default upcast = FALSE --- R/attribute_methods.R | 6 +++--- R/utils.R | 4 ++-- man/atomize.Rd | 4 ++-- man/attribute_methods.Rd | 6 +++--- tests/testthat/test-networkLite.R | 2 +- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/R/attribute_methods.R b/R/attribute_methods.R index 6373957..8d6c7df 100644 --- a/R/attribute_methods.R +++ b/R/attribute_methods.R @@ -84,7 +84,7 @@ set.vertex.attribute.networkLite <- function(x, value, v = seq_len(network.size(x)), ..., - upcast = TRUE) { + upcast = FALSE) { xn <- substitute(x) if (missing(v)) { @@ -191,7 +191,7 @@ get.edge.value.networkLite <- get.edge.attribute.networkLite #' set.edge.attribute.networkLite <- function( x, attrname, value, - e = seq_len(network.edgecount(x, na.omit = FALSE)), ..., upcast = TRUE) { + e = seq_len(network.edgecount(x, na.omit = FALSE)), ..., upcast = FALSE) { xn <- substitute(x) @@ -218,7 +218,7 @@ set.edge.attribute.networkLite <- function( #' set.edge.value.networkLite <- function( x, attrname, value, - e = seq_len(network.edgecount(x, na.omit = FALSE)), ..., upcast = TRUE) { + e = seq_len(network.edgecount(x, na.omit = FALSE)), ..., upcast = FALSE) { xn <- substitute(x) diff --git a/R/utils.R b/R/utils.R index 94fd58e..6ac7306 100644 --- a/R/utils.R +++ b/R/utils.R @@ -25,7 +25,7 @@ atomize <- function(x, ...) { #' @rdname atomize #' @export #' -atomize.networkLite <- function(x, ..., upcast = TRUE) { +atomize.networkLite <- function(x, ..., upcast = FALSE) { x$el <- atomize(x$el, ..., upcast = upcast) # also applies to .tail, .head x$attr <- atomize(x$attr, ..., upcast = upcast) x @@ -34,7 +34,7 @@ atomize.networkLite <- function(x, ..., upcast = TRUE) { #' @rdname atomize #' @export #' -atomize.tbl_df <- function(x, ..., upcast = TRUE) { +atomize.tbl_df <- function(x, ..., upcast = FALSE) { for (name in names(x)) { value <- x[[name]] if (is.list(value) && diff --git a/man/atomize.Rd b/man/atomize.Rd index f8fece2..7e91ebf 100644 --- a/man/atomize.Rd +++ b/man/atomize.Rd @@ -8,9 +8,9 @@ \usage{ atomize(x, ...) -\method{atomize}{networkLite}(x, ..., upcast = TRUE) +\method{atomize}{networkLite}(x, ..., upcast = FALSE) -\method{atomize}{tbl_df}(x, ..., upcast = TRUE) +\method{atomize}{tbl_df}(x, ..., upcast = FALSE) } \arguments{ \item{x}{A \code{networkLite} or \code{tibble} object.} diff --git a/man/attribute_methods.Rd b/man/attribute_methods.Rd index 2a4c9ae..09dc4cb 100644 --- a/man/attribute_methods.Rd +++ b/man/attribute_methods.Rd @@ -25,7 +25,7 @@ value, v = seq_len(network.size(x)), ..., - upcast = TRUE + upcast = FALSE ) \method{list.vertex.attributes}{networkLite}(x, ...) @@ -46,7 +46,7 @@ value, e = seq_len(network.edgecount(x, na.omit = FALSE)), ..., - upcast = TRUE + upcast = FALSE ) \method{set.edge.value}{networkLite}( @@ -55,7 +55,7 @@ value, e = seq_len(network.edgecount(x, na.omit = FALSE)), ..., - upcast = TRUE + upcast = FALSE ) \method{list.edge.attributes}{networkLite}(x, ...) diff --git a/tests/testthat/test-networkLite.R b/tests/testthat/test-networkLite.R index 0a1cb8d..460a305 100644 --- a/tests/testthat/test-networkLite.R +++ b/tests/testthat/test-networkLite.R @@ -240,7 +240,7 @@ test_that("atomize and upcast work as intended", { set.edge.attribute(nw, "e3", list(1,2,3L,4)) set.edge.attribute(nw, "e4", list(1,2,3,4)) - nwL <- as.networkLite(nw) + nwL <- as.networkLite(nw, upcast = TRUE) nwL_na <- as.networkLite(nw, atomize = FALSE) nwL_nu <- as.networkLite(nw, upcast = FALSE)