From 5006f56e01de6b147fa7e61d216d641a5e7537df Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Bojanowski?= Date: Fri, 9 May 2025 15:12:32 +0200 Subject: [PATCH 01/13] Add c.network.list() --- R/c.network.list.R | 52 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) create mode 100644 R/c.network.list.R diff --git a/R/c.network.list.R b/R/c.network.list.R new file mode 100644 index 000000000..4719cbd6a --- /dev/null +++ b/R/c.network.list.R @@ -0,0 +1,52 @@ +#' @rdname network.list +#' +#' @param check_attr logical; should the attributes of the combined network +#' lists be checked for consistency. If `TRUE` inconsistencies result in +#' errors. +#' +#' @importFrom purrr map +#' @export + +c.network.list <- function(..., check_attr = TRUE) { + dots <- list(...) + + # Merge network lists + lapply(dots, function(x) { + attributes(x) <- NULL + x + }) -> l_networks + rval <- do.call("c", l_networks) + + if(check_attr) { + # Names of attributes to check with `all.equal()` + attr_names <- c("coefficients", "control", "response", + "formula", "constraints", "reference") + for(an in attr_names) { + al <- map(dots, ~ attr(.x, an)) + ok <- Reduce(all.equal, al) + if(!ok) stop(paste0("network lists do not have identical values on attribute ", an)) + } + + # Check if "stats" have identical columns + l_stats <- map(dots, ~ attr(.x, "stats")) + ok <- Reduce( + function(x, y) identical(colnames(x), colnames(y)), + l_stats + ) + if(!ok) stop("network lists do not have identical columns of 'stats' attribute") + } + structure( + rval, + class = "network.list", + coefficients = attr(dots[[1]], "coefficients"), + control = attr(dots[[1]], "control"), + response = attr(dots[[1]], "response"), + stats = structure( + do.call("rbind", map(dots, ~attr(.x, "stats"))), + monitored = do.call("c", map(dots, ~ attr(attr(.x, "stats"), "monitored"))) + ), + formula = attr(dots[[1]], "formula"), + constraints = attr(dots[[1]], "constraints"), + reference = attr(dots[[1]], "reference") + ) +} From f36a19474a14c74f331d34ad62e82ee708287469 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Bojanowski?= Date: Fri, 9 May 2025 15:46:41 +0200 Subject: [PATCH 02/13] Add c.network.list.R to Collate field --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 541ac92e8..baffdd71e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -98,6 +98,7 @@ Collate: 'approx.hotelling.diff.test.R' 'as.network.numeric.R' 'build_term_index.R' + 'c.network.list.R' 'check.ErgmTerm.R' 'control.ergm.R' 'control.ergm.bridge.R' From eb9e2415dee8f89e9768b75d47a42642a4bd7a0c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Bojanowski?= Date: Fri, 9 May 2025 17:03:12 +0200 Subject: [PATCH 03/13] Fix attribute checking --- R/c.network.list.R | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/R/c.network.list.R b/R/c.network.list.R index 4719cbd6a..4a16b444c 100644 --- a/R/c.network.list.R +++ b/R/c.network.list.R @@ -10,31 +10,40 @@ c.network.list <- function(..., check_attr = TRUE) { dots <- list(...) - # Merge network lists + # Check a list elements using all.equal or identical + check_list <- function(lst, fun = all.equal) { + r <- vapply(lst[-1], function(x) isTRUE(fun(x, lst[[1]])), logical(1)) + all(r) + } + + # Merge network lists without attributes lapply(dots, function(x) { attributes(x) <- NULL x }) -> l_networks rval <- do.call("c", l_networks) + # Check attributes if(check_attr) { # Names of attributes to check with `all.equal()` attr_names <- c("coefficients", "control", "response", "formula", "constraints", "reference") for(an in attr_names) { al <- map(dots, ~ attr(.x, an)) - ok <- Reduce(all.equal, al) - if(!ok) stop(paste0("network lists do not have identical values on attribute ", an)) + ok <- check_list(al, all.equal) + if(!ok) stop(paste0("network lists do not have equal values on attribute ", an)) } # Check if "stats" have identical columns l_stats <- map(dots, ~ attr(.x, "stats")) - ok <- Reduce( - function(x, y) identical(colnames(x), colnames(y)), - l_stats + ok <- check_list( + lapply(l_stats, function(x) colnames(x)), + fun = identical ) if(!ok) stop("network lists do not have identical columns of 'stats' attribute") } + # Return the list of networks with attributes merged or taken from the + # first object structure( rval, class = "network.list", From 39e9b73ed6e66cdc9ad15dd29caad3bc31410b9d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Bojanowski?= Date: Tue, 13 May 2025 17:22:39 +0200 Subject: [PATCH 04/13] Use statnet.common::all_identical() Uses the new variant of all_identical() allowing arbitary pairwise-comparison function. --- R/c.network.list.R | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/R/c.network.list.R b/R/c.network.list.R index 4a16b444c..e9ac67809 100644 --- a/R/c.network.list.R +++ b/R/c.network.list.R @@ -10,12 +10,6 @@ c.network.list <- function(..., check_attr = TRUE) { dots <- list(...) - # Check a list elements using all.equal or identical - check_list <- function(lst, fun = all.equal) { - r <- vapply(lst[-1], function(x) isTRUE(fun(x, lst[[1]])), logical(1)) - all(r) - } - # Merge network lists without attributes lapply(dots, function(x) { attributes(x) <- NULL @@ -30,13 +24,13 @@ c.network.list <- function(..., check_attr = TRUE) { "formula", "constraints", "reference") for(an in attr_names) { al <- map(dots, ~ attr(.x, an)) - ok <- check_list(al, all.equal) + ok <- all_identical(al, all.equal) if(!ok) stop(paste0("network lists do not have equal values on attribute ", an)) } # Check if "stats" have identical columns l_stats <- map(dots, ~ attr(.x, "stats")) - ok <- check_list( + ok <- all_identical( lapply(l_stats, function(x) colnames(x)), fun = identical ) From e582833050e5aed5a1e5f77a778c069b33de12db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Bojanowski?= Date: Mon, 19 May 2025 17:18:17 +0200 Subject: [PATCH 05/13] Move c.network.list() to network.list.R --- R/c.network.list.R | 55 ------------------------------------------ R/network.list.R | 60 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 60 insertions(+), 55 deletions(-) delete mode 100644 R/c.network.list.R diff --git a/R/c.network.list.R b/R/c.network.list.R deleted file mode 100644 index e9ac67809..000000000 --- a/R/c.network.list.R +++ /dev/null @@ -1,55 +0,0 @@ -#' @rdname network.list -#' -#' @param check_attr logical; should the attributes of the combined network -#' lists be checked for consistency. If `TRUE` inconsistencies result in -#' errors. -#' -#' @importFrom purrr map -#' @export - -c.network.list <- function(..., check_attr = TRUE) { - dots <- list(...) - - # Merge network lists without attributes - lapply(dots, function(x) { - attributes(x) <- NULL - x - }) -> l_networks - rval <- do.call("c", l_networks) - - # Check attributes - if(check_attr) { - # Names of attributes to check with `all.equal()` - attr_names <- c("coefficients", "control", "response", - "formula", "constraints", "reference") - for(an in attr_names) { - al <- map(dots, ~ attr(.x, an)) - ok <- all_identical(al, all.equal) - if(!ok) stop(paste0("network lists do not have equal values on attribute ", an)) - } - - # Check if "stats" have identical columns - l_stats <- map(dots, ~ attr(.x, "stats")) - ok <- all_identical( - lapply(l_stats, function(x) colnames(x)), - fun = identical - ) - if(!ok) stop("network lists do not have identical columns of 'stats' attribute") - } - # Return the list of networks with attributes merged or taken from the - # first object - structure( - rval, - class = "network.list", - coefficients = attr(dots[[1]], "coefficients"), - control = attr(dots[[1]], "control"), - response = attr(dots[[1]], "response"), - stats = structure( - do.call("rbind", map(dots, ~attr(.x, "stats"))), - monitored = do.call("c", map(dots, ~ attr(attr(.x, "stats"), "monitored"))) - ), - formula = attr(dots[[1]], "formula"), - constraints = attr(dots[[1]], "constraints"), - reference = attr(dots[[1]], "reference") - ) -} diff --git a/R/network.list.R b/R/network.list.R index c5a25f7ad..1d6662aca 100644 --- a/R/network.list.R +++ b/R/network.list.R @@ -100,3 +100,63 @@ summary.network.list <- function (object, stats.print=TRUE, } object } + + + + + +#' @rdname network.list +#' +#' @param check_attr Logical: should the attributes of the combined network +#' lists be checked for consistency. If `TRUE` inconsistencies result in +#' errors. +#' +#' @importFrom purrr map +#' @export + +c.network.list <- function(..., check_attr = TRUE) { + dots <- list(...) + + # Merge network lists without attributes + lapply(dots, function(x) { + attributes(x) <- NULL + x + }) -> l_networks + rval <- do.call("c", l_networks) + + # Check attributes + if(check_attr) { + # Names of attributes to check with `all.equal()` + attr_names <- c("coefficients", "control", "response", + "formula", "constraints", "reference") + for(an in attr_names) { + al <- map(dots, ~ attr(.x, an)) + ok <- all_identical(al, all.equal) + if(!ok) stop(paste0("network lists do not have equal values on attribute ", an)) + } + + # Check if "stats" have identical columns + l_stats <- map(dots, ~ attr(.x, "stats")) + ok <- all_identical( + lapply(l_stats, function(x) colnames(x)), + fun = identical + ) + if(!ok) stop("network lists do not have identical columns of 'stats' attribute") + } + # Return the list of networks with attributes merged or taken from the + # first object + structure( + rval, + class = "network.list", + coefficients = attr(dots[[1]], "coefficients"), + control = attr(dots[[1]], "control"), + response = attr(dots[[1]], "response"), + stats = structure( + do.call("rbind", map(dots, ~attr(.x, "stats"))), + monitored = do.call("c", map(dots, ~ attr(attr(.x, "stats"), "monitored"))) + ), + formula = attr(dots[[1]], "formula"), + constraints = attr(dots[[1]], "constraints"), + reference = attr(dots[[1]], "reference") + ) +} From 072e73af86f9d2a8e20b045d886ea3ba3667a007 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Bojanowski?= Date: Mon, 19 May 2025 18:13:34 +0200 Subject: [PATCH 06/13] Drop old file from Collate --- DESCRIPTION | 1 - 1 file changed, 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index baffdd71e..541ac92e8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -98,7 +98,6 @@ Collate: 'approx.hotelling.diff.test.R' 'as.network.numeric.R' 'build_term_index.R' - 'c.network.list.R' 'check.ErgmTerm.R' 'control.ergm.R' 'control.ergm.bridge.R' From f0842b964070242602e9fc7e5c8e134f4a935611 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Bojanowski?= Date: Thu, 22 May 2025 18:03:13 +0200 Subject: [PATCH 07/13] Use .p not fun argument --- R/network.list.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/network.list.R b/R/network.list.R index 1d6662aca..ce0bd7238 100644 --- a/R/network.list.R +++ b/R/network.list.R @@ -139,7 +139,7 @@ c.network.list <- function(..., check_attr = TRUE) { l_stats <- map(dots, ~ attr(.x, "stats")) ok <- all_identical( lapply(l_stats, function(x) colnames(x)), - fun = identical + .p = identical ) if(!ok) stop("network lists do not have identical columns of 'stats' attribute") } From 2b4b6224b3a5621a3e542815acc125718ea2b01e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Bojanowski?= Date: Thu, 22 May 2025 19:19:20 +0200 Subject: [PATCH 08/13] Export c.network.list() method --- NAMESPACE | 1 + 1 file changed, 1 insertion(+) diff --git a/NAMESPACE b/NAMESPACE index aa5bc8111..1beb1c1d8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -33,6 +33,7 @@ S3method(as.rlebdm,matrix) S3method(as.rlebdm,network) S3method(as.rlebdm,rlebdm) S3method(c,ergm_model) +S3method(c,network.list) S3method(coef,ergm) S3method(compress,rlebdm) S3method(degreedist,network) From 701be2a728e4d628a41592b896fc4211be8d8301 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Bojanowski?= Date: Thu, 22 May 2025 19:19:44 +0200 Subject: [PATCH 09/13] Add c.network.list() example --- R/network.list.R | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/R/network.list.R b/R/network.list.R index ce0bd7238..41efc39bc 100644 --- a/R/network.list.R +++ b/R/network.list.R @@ -113,6 +113,18 @@ summary.network.list <- function (object, stats.print=TRUE, #' #' @importFrom purrr map #' @export +#' +#' @examples +#' # Simulate some more +#' g.sim2 <- simulate(~edges+kstar(2), nsim=3, coef=c(-1.8, 0.03), +#' basis=g.use, control=control.simulate( +#' MCMC.burnin=100000, +#' MCMC.interval=1000)) +#' +#' # Merge the simulations +#' g.simall <- c(g.sim, g.sim2) +#' length(g.simall) # 6 +#' c.network.list <- function(..., check_attr = TRUE) { dots <- list(...) From 95a81caa2113f24fdbfc22ae0278ae4aabe969e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Bojanowski?= Date: Thu, 22 May 2025 19:18:51 +0200 Subject: [PATCH 10/13] Test c.network.list() --- tests/testthat/test-network.list.R | 42 ++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) create mode 100644 tests/testthat/test-network.list.R diff --git a/tests/testthat/test-network.list.R b/tests/testthat/test-network.list.R new file mode 100644 index 000000000..9de562ad6 --- /dev/null +++ b/tests/testthat/test-network.list.R @@ -0,0 +1,42 @@ +suppressMessages({ + data("faux.desert.high", package = "ergm") + fit1 <- ergm( + faux.desert.high ~ mm("sex"), + control = control.ergm( + force.main=TRUE, + MCMLE.maxit = 1, + seed = 1 + ) + ) + fit2 <- ergm( + faux.desert.high ~ mm("sex"), + control = control.ergm( + force.main=TRUE, + MCMLE.maxit = 1, + seed = 2 + ) + ) + s1 <- simulate(fit1, 10) + s2 <- simulate(fit2, 10) +}) + +test_that("there is no error if attributes match", { + expect_silent( + c(s1, s1) + ) + expect_silent( + c(s1, s1) + ) +}) + +test_that("there is an error if attributes don't match", { + expect_error( + c(s1, s2) + ) +}) + +test_that("there is no error if attributes are to be ignored", { + expect_silent( + c(s1, s2, check_attr = FALSE) + ) +}) From 31cde4c18efc07d7a731ac48032e84d773d0bff8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Bojanowski?= Date: Thu, 22 May 2025 19:21:01 +0200 Subject: [PATCH 11/13] Roxygenize --- man/network.list.Rd | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/man/network.list.Rd b/man/network.list.Rd index 60b1444f2..4e584a2db 100644 --- a/man/network.list.Rd +++ b/man/network.list.Rd @@ -5,6 +5,7 @@ \alias{network.list.list} \alias{print.network.list} \alias{summary.network.list} +\alias{c.network.list} \title{A convenience container for a list of \code{\link[network:network]{network}} objects, output by \code{\link[=simulate.ergm]{simulate.ergm()}} among others.} \usage{ @@ -19,6 +20,8 @@ network.list(object, ...) net.summary = FALSE, ... ) + +\method{c}{network.list}(..., check_attr = TRUE) } \arguments{ \item{object, x}{a \code{list} of networks or a \code{network.list} object.} @@ -32,6 +35,10 @@ lower-level functions.} \item{net.print}{Logical: If TRUE, print network overviews.} \item{net.summary}{Logical: If TRUE, print network summaries.} + +\item{check_attr}{Logical: should the attributes of the combined network +lists be checked for consistency. If \code{TRUE} inconsistencies result in +errors.} } \description{ A convenience container for a list of \code{\link[network:network]{network}} objects, output @@ -67,6 +74,16 @@ g.sim <- simulate(~edges+kstar(2), nsim=3, coef=c(-1.8, 0.03), print(g.sim) summary(g.sim) +# Simulate some more +g.sim2 <- simulate(~edges+kstar(2), nsim=3, coef=c(-1.8, 0.03), + basis=g.use, control=control.simulate( + MCMC.burnin=100000, + MCMC.interval=1000)) + +# Merge the simulations +g.simall <- c(g.sim, g.sim2) +length(g.simall) # 6 + } \seealso{ \code{\link[=simulate.ergm]{simulate.ergm()}} From 04baa72765d06bf6b6723927f167caf86483c972 Mon Sep 17 00:00:00 2001 From: "Pavel N. Krivitsky" Date: Wed, 28 May 2025 12:27:22 +1000 Subject: [PATCH 12/13] Simplified some of the code in c.network.list() and fixed formatting. --- R/network.list.R | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/R/network.list.R b/R/network.list.R index 41efc39bc..585614797 100644 --- a/R/network.list.R +++ b/R/network.list.R @@ -130,30 +130,27 @@ c.network.list <- function(..., check_attr = TRUE) { dots <- list(...) # Merge network lists without attributes - lapply(dots, function(x) { - attributes(x) <- NULL - x - }) -> l_networks - rval <- do.call("c", l_networks) + rval <- do.call("c", map(dots, unclass)) # Check attributes - if(check_attr) { + if (check_attr) { # Names of attributes to check with `all.equal()` attr_names <- c("coefficients", "control", "response", "formula", "constraints", "reference") - for(an in attr_names) { + for (an in attr_names) { al <- map(dots, ~ attr(.x, an)) ok <- all_identical(al, all.equal) - if(!ok) stop(paste0("network lists do not have equal values on attribute ", an)) + if (!ok) stop("network lists do not have equal values on attribute ", an) } # Check if "stats" have identical columns l_stats <- map(dots, ~ attr(.x, "stats")) ok <- all_identical( - lapply(l_stats, function(x) colnames(x)), + map(l_stats, function(x) colnames(x)), .p = identical ) - if(!ok) stop("network lists do not have identical columns of 'stats' attribute") + if (!ok) stop("network lists do not have identical columns of ", + sQuote("stats"), " attribute") } # Return the list of networks with attributes merged or taken from the # first object From 80fe538cd136cc0577990ce526bc4f2d4b106a59 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C5=82=20Bojanowski?= Date: Fri, 30 May 2025 19:02:29 +0200 Subject: [PATCH 13/13] Simplify tests of c.network.list --- tests/testthat/test-network.list.R | 24 +++++------------------- 1 file changed, 5 insertions(+), 19 deletions(-) diff --git a/tests/testthat/test-network.list.R b/tests/testthat/test-network.list.R index 9de562ad6..a9b9133f4 100644 --- a/tests/testthat/test-network.list.R +++ b/tests/testthat/test-network.list.R @@ -1,23 +1,9 @@ suppressMessages({ - data("faux.desert.high", package = "ergm") - fit1 <- ergm( - faux.desert.high ~ mm("sex"), - control = control.ergm( - force.main=TRUE, - MCMLE.maxit = 1, - seed = 1 - ) - ) - fit2 <- ergm( - faux.desert.high ~ mm("sex"), - control = control.ergm( - force.main=TRUE, - MCMLE.maxit = 1, - seed = 2 - ) - ) - s1 <- simulate(fit1, 10) - s2 <- simulate(fit2, 10) + net0 <- network.initialize(36) + net0 %v% "x" <- rep(1:2, length = network.size(net0)) + k <- c(-2, -3, -3, -2) + s1 <- simulate(net0 ~ mm("x", levels2=TRUE), nsim=10, coef = k) + s2 <- simulate(net0 ~ mm("x", levels2=TRUE), nsim=10, coef = k * 0.01) }) test_that("there is no error if attributes match", {