Add c.network.list()

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)

R/network.list.R

@@ -100,3 +100,72 @@
   }
   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
+#'
+#' @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(...)
+
+  # Merge network lists without attributes
+  rval <- do.call("c", map(dots, unclass))
+
+  # 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("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(
+      map(l_stats, function(x) colnames(x)),
+      .p = identical
+    )
+    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
+  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")
+  )
+}

tests/testthat/test-network.list.R

@@ -0,0 +1,28 @@
+suppressMessages({
+  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", {
+  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)
+  )
+})