fixallbut() constraint now also accepts an rlebdm as input.

statnet · Dec 22, 2024 · e71e4fc · e71e4fc
1 parent 6724034
commit e71e4fc
Show file tree

Hide file tree

Showing 4 changed files with 31 additions and 23 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,5 +1,5 @@
 Package: ergm
-Version: 4.8.0-7504
+Version: 4.8.0-7505
 Date: 2024-12-22
 Title: Fit, Simulate and Diagnose Exponential-Family Models for Networks
 Authors@R: c(

diff --git a/R/InitErgmConstraint.R b/R/InitErgmConstraint.R
@@ -415,7 +415,7 @@ InitErgmConstraint.observed <- function(nw, arglist, ...){
 }
 
 warn_netsize <- function(.n, ...){
-  mismatch <- vapply(list(...), function(x) is.network(x) && network.size(x) != .n, logical(1))
+  mismatch <- map_lgl(list(...), function(x) (is.network(x) && network.size(x) != .n) || (is(x, "rlebdm") && nrow(x) != .n))
   if(any(mismatch))
     ergm_Init_warning("Network size of argument(s) ", paste.and(sQuote(...names()[mismatch])), " differs from that of the response network.")
 }
@@ -477,7 +477,7 @@ InitErgmConstraint.fixedas<-function(nw, arglist,...){
 #'
 #' @usage
 #' # fixallbut(free.dyads)
-#' @param free.dyads edgelist or network. Networks will be converted to the corresponding edgelist.
+#' @param free.dyads a two-column edge list, a [`network`], or an [`rlebdm`]. Networks will be converted to the corresponding edgelist.
 #'
 #' @template ergmConstraint-general
 #'
@@ -487,23 +487,24 @@ InitErgmConstraint.fixedas<-function(nw, arglist,...){
 InitErgmConstraint.fixallbut<-function(nw, arglist,...){
   a <- check.ErgmTerm(nw, arglist,
                       varnames = c("free.dyads"),
-                      vartypes = c("network,matrix"),
+                      vartypes = c("network,matrix,rlebdm"),
                       defaultvalues = list(NULL),
                       required = c(TRUE))
   free.dyads <- a$free.dyads
 
   warn_netsize(network.size(nw), free.dyads = free.dyads)
 
   list(
-    free_dyads = function(){
-      if(is.network(free.dyads)) free.dyads <- as.edgelist(free.dyads)
-      else free.dyads <- as.edgelist(free.dyads,
-                                     n=nw%n%"n",
-                                     directed=nw%n%"directed",
-                                     bipartite=nw%n%"bipartite",
-                                     loops=nw%n%"loops")
-      as.rlebdm(free.dyads)
-    },
+    free_dyads =
+      if(is(free.dyads, "rlebdm")) free.dyads
+      else function()
+        as.rlebdm(if(is.network(free.dyads)) as.edgelist(free.dyads)
+                  else as.edgelist(free.dyads,
+                                   n=nw%n%"n",
+                                   directed=nw%n%"directed",
+                                   bipartite=nw%n%"bipartite",
+                                   loops=nw%n%"loops")
+                  ),
     dependence = FALSE)
 }
 

diff --git a/man/fixallbut-ergmConstraint-ea96b2e0.Rd b/man/fixallbut-ergmConstraint-ea96b2e0.Rd
diff --git a/tests/testthat/test-constraints.R b/tests/testthat/test-constraints.R
@@ -74,18 +74,25 @@ test_that("fixedas with network input", {
   expect_true(all(!sapply(s1,function(x)as.data.frame(t(as.edgelist(absent))) %in% as.data.frame(t(as.edgelist(x))))))
 })
 
-test_that("fixallbut with network input", {
-  net1 <- network(10,directed=FALSE,density=0.5)
-  free.dyads <- matrix(sample(2:9,8,replace=FALSE),4,2)
+net1 <- network(10,directed=FALSE,density=0.5)
+fdel <- matrix(sample(2:9,8,replace=FALSE),4,2)
 
-  t1 <- ergm(net1~edges, constraint = ~fixallbut(free.dyads = free.dyads))
-  s1 <- simulate(t1, 100)
+for(free.dyads in list(
+                    fdel,
+                    fdnw <- as.network(structure(fdel, n = 10), directed = FALSE),
+                    fd <- as.rlebdm(fdnw)
+                  )){
+  test_that(sprintf("fixallbut with %s input", class(free.dyads)[1]), {
+    t1 <- ergm(net1~edges, constraint = ~fixallbut(free.dyads = free.dyads))
+    s1 <- simulate(t1, 100)
 
-  fixed.dyads <- as.edgelist(!update(net1,free.dyads,matrix.type="edgelist"))
-  fixed.dyads.state <- net1[fixed.dyads]
+    fixed.dyads <- as.edgelist(!update(net1,fdel,matrix.type="edgelist"))
+    fixed.dyads.state <- net1[fixed.dyads]
+
+    expect_true(all(sapply(s1,function(x) all.equal(x[fixed.dyads],fixed.dyads.state))))
+  })
+}
 
-  expect_true(all(sapply(s1,function(x) all.equal(x[fixed.dyads],fixed.dyads.state))))
-})
 
 test_that("constraint conflict is detected", {
   data(florentine)