Coied the b*.size() and *_along() functions from 'ergm' and made use of them.

Author: krivit

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: ergm.multi
 Version: 0.3.0-4181
-Date: 2025-06-10
+Date: 2025-06-12
 Title: Fit, Simulate and Diagnose Exponential-Family Models for Multiple or Multilayer Networks
 Authors@R: c(person(c("Pavel", "N."), "Krivitsky", role=c("aut","cre"), email="pavel@statnet.org", comment=c(ORCID="0000-0002-9101-3362")),
              person(c("Mark", "S."), "Handcock", role=c("ctb"), email="handcock@stat.ucla.edu"),

R/InitErgmConstraint.R

@@ -58,8 +58,8 @@
 ##          n <- network.size(lhs.nw)
 ##          storage.mode(n) <- "integer"
 ##          a <- c(ergm_get_vattr(attr, lhs.nw)) # Strip attributes, which confuse rle().
-##          if(NVL(lhs.nw%n%"bipartite",0)){
-##            bip <- lhs.nw %n% "bipartite"
+##          if(NVL(lhs.b1.size(nw),0)){
+##            bip <- lhs.b1.size(nw)
 ##            ea <- a[seq_len(bip)]
 ##            aa <- a[bip+seq_len(n-bip)]
 ##            if(length(rle(ea)$lengths)!=length(unique(rle(ea)$values)) || length(rle(aa)$lengths)!=length(unique(rle(aa)$values))) stop("Current implementation of block-diagonal sampling requires that the blocks of the egos and the alters be contiguous. See ", sQuote("ergmConstraint?blockdiag"), " for more information.")

R/InitErgmProposal.blockdiag.R

@@ -109,7 +109,7 @@
 #' @keywords internal
 #' @export
 ergm_block_diag_samp_info <- function(nw, a){
-  bip <- nw %n% "bipartite"
+  bip <- b1.size(nw)
   if(bip){
     ea <- a[seq_len(bip)]
     aa <- a[bip+seq_len(network.size(nw)-bip)]
@@ -135,7 +135,9 @@ ergm_block_diag_samp_info <- function(nw, a){
     w <- cumsum(a$lengths*(a$lengths-1)) # cumulative block weights ~ # dyads in the block
     w <- w/max(w)
     # Note that this automagically takes care of singleton blocks by giving them weight 0.
-    out <- list(nblk=as.integer(length(w)),  pos=as.integer(b), cumwt=as.double(w), ndyads=sum(as.double(a$lengths*(a$lengths-1)/(if(is.directed(nw)) 1 else 2))))
+    out <- list(nblk = as.integer(length(w)),  pos = as.integer(b),
+                cumwt = as.double(w),
+                ndyads = sum(choose(a$lengths, 2L) * (1L + is.directed(nw))))
   }
   structure(out, class="ergm_block_diag_samp_info")
 }

R/InitErgmTerm.R

@@ -163,7 +163,7 @@ InitErgmTerm.b1degreeL <- function(nw, arglist, ...) {
                        defaultvalues = list(NULL, NULL, NULL, NULL),
                        required = c(TRUE, FALSE, FALSE, FALSE))
   ### Process the arguments
-  nb1 <- get.network.attribute(nw, "bipartite")
+  nb1 <- b1.size(nw)
   if (!is.null(a$by)) {  # CASE 1:  a$by GIVEN
     nodecov <- get.node.attr(nw, a$by)[seq_len(nb1)]
     u <- NVL(a$levels, sort(unique(nodecov)))
@@ -236,7 +236,7 @@ InitErgmTerm.b2degreeL <- function(nw, arglist, ...) {
                        defaultvalues = list(NULL, NULL, NULL, NULL),
                        required = c(TRUE, FALSE, FALSE, FALSE))
   ### Process the arguments
-  nb1 <- get.network.attribute(nw, "bipartite")
+  nb1 <- b1.size(nw)
   n <- network.size(nw)
   if (!is.null(a$by)) {  # CASE 1:  a$by GIVEN
     nodecov <- get.node.attr(nw, a$by)[-seq_len(nb1)]
@@ -332,7 +332,7 @@ InitErgmTerm.degreeL<-function(nw, arglist, ...) {
     }
   } else {
     if (any(d==0)) {
-      emptynwstats <- rep(0, length(d))
+      emptynwstats <- dbl_along(d)
       emptynwstats[d==0] <- network.size(nw)
     }
   }
@@ -409,7 +409,7 @@ InitErgmTerm.gwb1degreeL<-function(nw, arglist, gw.cutoff=30, ...) {
                       required = c(FALSE, FALSE, FALSE, FALSE, FALSE, FALSE))
   decay<-a$decay; fixed<-a$fixed; attrname<-a$attrname
   cutoff<-a$cutoff
-  nb1 <- get.network.attribute(nw,"bipartite")
+  nb1 <- b1.size(nw)
 # d <- 1:(network.size(nw) - nb1)
   maxesp <- min(cutoff, network.size(nw)-nb1)
 
@@ -502,7 +502,7 @@ InitErgmTerm.gwb2degreeL<-function(nw, arglist, gw.cutoff=30,  ...) {
                       required = c(FALSE, FALSE, FALSE, FALSE, FALSE, FALSE))
   decay<-a$decay; fixed<-a$fixed; attrname<-a$attrname
   cutoff<-a$cutoff
-  nb1 <- get.network.attribute(nw,"bipartite")
+  nb1 <- b1.size(nw)
 # d <- 1:nb1
   maxesp <- min(cutoff,nb1)
   d <- 1:maxesp
@@ -845,7 +845,7 @@ InitErgmTerm.idegreeL<-function(nw, arglist, ...) {
     }
   } else {
     if (any(d==0)) {
-      emptynwstats <- rep(0, length(d))
+      emptynwstats <- dbl_along(d)
       emptynwstats[d==0] <- network.size(nw)
     }
   }
@@ -1057,7 +1057,7 @@ InitErgmTerm.odegreeL<-function(nw, arglist, ...) {
     }
   } else {
     if (any(d==0)) {
-      emptynwstats <- rep(0, length(d))
+      emptynwstats <- dbl_along(d)
       emptynwstats[d==0] <- network.size(nw)
     }
   }

R/InitErgmTerm.dgw_sp.R

@@ -87,7 +87,7 @@ wrap_ergm_sp_call <- function(ergm_name, nw, a, has_base, d0 = FALSE, cache.sp =
   .emptynwstats <-
     if (d0 && any(a$d == 0)) {
       if (is.bipartite(nw)) {
-        nb1 <- get.network.attribute(nw, "bipartite")
+        nb1 <- b1.size(nw)
         nb2 <- network.size(nw) - nb1
         replace(numeric(length(a$d)), a$d == 0, choose(nb1, 2) + choose(nb2, 2))
       } else {

R/InitErgmTerm.multilayer.R

@@ -217,7 +217,9 @@ direct.network <- function(x, rule=c("both", "upper", "lower")){
                upper = cbind(pmin(el[,1],el[,2]),pmax(el[,1],el[,2])),
                lower = cbind(pmax(el[,1],el[,2]),pmin(el[,1],el[,2])))
 
-  o <- network.initialize(network.size(x), directed=TRUE, bipartite=x%n%"bipartite", loops=has.loops(x), hyper=is.hyper(x), multiple=is.multiplex(x))
+  o <- network.initialize(network.size(x), directed = TRUE,
+                          bipartite = b1.size(x), loops = has.loops(x),
+                          hyper = is.hyper(x), multiple = is.multiplex(x))
   o <- network.edgelist(el, o)
   nvattr.copy.network(o, x)
 }
@@ -482,7 +484,7 @@ Layer <- function(..., .symmetric=NULL, .bipartite=NULL, .active=NULL){
   }
 
   # nwl may now be a list with networks of heterogeneous bipartitedness.
-  bip <- sapply(nwl, `%n%`, "bipartite") %>% sapply(NVL, 0L)
+  bip <- sapply(nwl, b1.size) %>% sapply(NVL, 0L)
   blockout <- if(all_identical(bip)) rep(FALSE, length(nwl)) else bip
 
   nwl <- Map(function(nw, b){

R/combine.networks.R

@@ -234,7 +234,7 @@ combine_networks <- function(nwl, ignore.nattr=c("mnext"), ignore.vattr=c(), ign
   attrset <- if(keep.unshared.attr) union else intersect
 
   ns <- sapply(nwl, network.size)
-  es <- sapply(nwl, "%n%", "bipartite")
+  es <- sapply(nwl, b1.size)
   eblks <- c(0, cumsum(es))
   bip <- eblks[length(eblks)]
   ablks <- cumsum(c(bip, ns-es))
@@ -537,7 +537,7 @@ subnetwork_templates <- function(nw, split.vattr=nw%n%".blockID.vattr", names.va
 .block_vertexmap <- function(nw, by=nw %n% ".blockID.vattr", same_dim=FALSE){
   a <- .peek_vattrv(nw, by)
   n <- length(a)
-  bip <- nw %n% "bipartite"
+  bip <- b1.size(nw)
   if(NVL(bip,0)){
     ea <- a[seq_len(bip)]
     aa <- a[bip+seq_len(n-bip)]

R/util.R

@@ -0,0 +1,11 @@
+## These will eventually be moved to 'statnet.common'.
+
+dbl_along <- function(x) numeric(length(x))
+int_along <- function(x) integer(length(x))
+chr_along <- function(x) character(length(x))
+lgl_along <- function(x) logical(length(x))
+
+## This should be in 'network'.
+
+b1.size <- function(x) if(is.bipartite(x)) x %n% "bipartite" else FALSE
+b2.size <- function(x) if(is.bipartite(x)) network.size(x) - b1.size(x) else FALSE