Simplified combined_networks(): rather than it being possible to un-combine on arbitrary vertex attribute, it is now only possible to uncombine on the combining attribute.

Author: krivit

NAMESPACE

@@ -29,16 +29,14 @@ export(ERGM_LAYERS_SPEC)
 export(ERGM_LAYER_SPEC)
 export(Layer)
 export(Networks)
-export(assert_LHS_Layer)
+export(assert_combined_network)
 export(combine_ergmlhs)
 export(combine_networks)
 export(control.gofN)
 export(control.gofN.ergm)
 export(ergm.multi_combiner)
 export(ergm_LayerLogic)
 export(ergm_LayerLogics)
-export(ergmlhs_remove_blockdiag)
-export(get_combining_attr)
 export(gofN)
 export(lm.gofN)
 export(marg_cond_sim)
@@ -81,5 +79,6 @@ importFrom(statnet.common,ERRVL)
 importFrom(statnet.common,eval_lhs.formula)
 importFrom(statnet.common,statnetStartupMessage)
 importFrom(tibble,lst)
+importFrom(utils,head)
 importFrom(utils,modifyList)
 useDynLib(ergm.multi)

R/InitErgmTerm.dgw_sp.R

@@ -14,7 +14,7 @@
 }
 
 .sp.handle_layers <- function(nw, a, type, has_base, cache.sp=FALSE){
-  assert_LHS_Layer(nw)
+  assert_combined_network(nw, "Layer")
 
   out <- list()
 
@@ -67,7 +67,7 @@ no_layer_err <- function(instead){
 
 wrap_ergm_sp_call <- function(ergm_name, nw, a, has_base, d0 = FALSE, cache.sp = TRUE, ...) {
   # A "representative" layer network.
-  nw1 <- subnetwork_templates(nw, ".LayerID", ".LayerName")[[1]]
+  nw1 <- subnetwork_templates(nw)[[1]]
 
   # Construct and call the ergm term with only the arguments it
   # supports.

R/InitErgmTerm.multilayer.R

@@ -25,9 +25,9 @@ InitErgmTerm..layer.net <- function(nw, arglist, ...){
                       defaultvalues = list(NULL),
                       required = c(TRUE))
 
-  assert_LHS_Layer(nw)
+  assert_combined_network(nw, "Layer")
 
-  nwl <- subnetwork_templates(nw, ".LayerID", ".LayerName", copy.ergmlhs = c())
+  nwl <- subnetwork_templates(nw, copy.ergmlhs = c())
 
   L <- ergm_LayerLogic(a$L, nw)
   # Terms on this logical layer will induce dyadic independence if its
@@ -40,7 +40,7 @@ InitErgmTerm..layer.net <- function(nw, arglist, ...){
                    " This is not supported at this time.", call. = FALSE)
 
   list(name = "_layer_net", coef.names = c(), dependence = dependence,
-       iinputs = c(unlist(.block_vertexmap(nw, ".LayerID", TRUE)),
+       iinputs = c(unlist(.block_vertexmap(nw)),
                    if (is.directed(nw)) sapply(nwl, function(nw) (nw%v%".undirected")[1]),
                    L%@%"C"))
 }
@@ -77,9 +77,9 @@ InitErgmTerm.L <- function(nw, arglist, ...){
                       defaultvalues = list(NULL, empty_env(~.)),
                       required = c(TRUE, FALSE))
 
-  assert_LHS_Layer(nw)
+  assert_combined_network(nw, "Layer")
 
-  nwl <- subnetwork_templates(nw, ".LayerID", ".LayerName", copy.ergmlhs = c())
+  nwl <- subnetwork_templates(nw, copy.ergmlhs = c())
 
   Ls <- ergm_LayerLogics(a$Ls, nw)
 
@@ -133,7 +133,7 @@ InitErgmTerm.CMBL <- function(nw, arglist, ...){
                       defaultvalues = list(empty_env(~.)),
                       required = c(FALSE))
 
-  assert_LHS_Layer(nw)
+  assert_combined_network(nw, "Layer")
 
   Ls <- ergm_LayerLogics(a$Ls, nw)
 
@@ -192,7 +192,7 @@ InitErgmTerm.twostarL<-function(nw, arglist,  ...) {
                       defaultvalues = list(NULL, NULL, TRUE),
                       required = c(TRUE, FALSE, FALSE))
 
-  assert_LHS_Layer(nw)
+  assert_combined_network(nw, "Layer")
 
   TYPES <- c("any", "out", "in", "path")
   TYPEREP <- setNames(c("--", "<>", "><", ">>"), TYPES)
@@ -259,7 +259,7 @@ InitErgmTerm.mutualL<-function (nw, arglist, ...) {
                       defaultvalues = list(NULL, NULL, FALSE, NULL, NULL),
                       required = c(FALSE, FALSE, FALSE, FALSE, FALSE))
 
-  assert_LHS_Layer(nw)
+  assert_combined_network(nw, "Layer")
 
   ## Process the arguments
   if (!is.null(a$same) || !is.null(a$by)) {
@@ -361,7 +361,7 @@ InitErgmTerm.hammingL <- function(nw, arglist, ...){
                       defaultvalues = list(empty_env(~.)),
                       required = c(FALSE))
 
-  assert_LHS_Layer(nw)
+  assert_combined_network(nw, "Layer")
 
   Ls <- ergm_LayerLogics(a$Ls, nw)
   if (length(Ls) < 2L) ergm_Init_stop("multiple layers are required")

R/InitErgmTerm.multinet.R

@@ -9,13 +9,9 @@
 ################################################################################
 
 InitErgmTerm..subnets <- function(nw, arglist, ...){
-  a <- check.ErgmTerm(nw, arglist,
-                      varnames = c("attrname"),
-                      vartypes = c("character"),
-                      defaultvalues = list(NULL),
-                      required = c(TRUE))
+  a <- check.ErgmTerm(nw, arglist)
 
-  list(name="_subnets", coef.names=c(), iinputs=c(unlist(.block_vertexmap(nw, a$attrname))), dependence=FALSE)
+  list(name="_subnets", coef.names=c(), iinputs=c(unlist(.block_vertexmap(nw))), dependence=FALSE)
 }
 
 
@@ -55,13 +51,6 @@ get_lminfo <- function(nattrs, lm=~1, subset=TRUE, contrasts=NULL, offset=NULL,
   list(xf=xf, xm=xm, subset=subset, offset=offset)  
 }
 
-assert_LHS_Networks <- function(nw, nid, term_trace = TRUE, call = if(term_trace) NULL else rlang::caller_env()){
-  if(anyNA(get_combining_attr(nw, nid))){
-    msg <- paste0("The LHS of the model is not a multi-network ", sQuote("Networks()"), " construct.")
-    if (term_trace) ergm_Init_abort(msg, call=call)
-    else abort(msg, call=call)
-  }
-}
 
 #' @import purrr
 #' @import tibble
@@ -80,9 +69,10 @@ assert_LHS_Networks <- function(nw, nid, term_trace = TRUE, call = if(term_trace
 #' error. This can be avoided by pre-filtering with `subset`, which
 #' controls which networks are affected by the term.
 #'
-#' The formula may also reference `.NetworkID` and `.NetworkName`. In
-#' particular, `~0+factor(.NetworkID)` will evaluate `formula` on each
-#' network individually.
+#' The formula may also reference `.NetworkID` and `.NetworkName` (or
+#' the corresponding IDs set by `.combiner`). In particular,
+#' `~0+factor(.NetworkID)` will evaluate `formula` on each network
+#' individually.
 #'
 #' @note Care should be taken to avoid multicollinearity when using
 #'   this operator. As with the [lm()] function, `lm` formulas have an
@@ -100,7 +90,7 @@ assert_LHS_Networks <- function(nw, nid, term_trace = TRUE, call = if(term_trace
 #'
 #' @usage
 #' # binary: N(formula, lm=~1, subset=TRUE, weights=1, contrasts=NULL, offset=0, label=NULL,
-#' #           .NetworkID=".NetworkID", .NetworkName=".NetworkName")
+#' #           .combiner = "Networks")
 #' @template ergmTerm-formula
 #' @param lm a one-sided [lm()]-style formula whose RHS specifies the network-level predictors for the terms in the [ergm()] formula `formula`.
 #' @param subset,contrasts see [lm()].
@@ -112,7 +102,10 @@ assert_LHS_Networks <- function(nw, nid, term_trace = TRUE, call = if(term_trace
 #'   parameters to help identify the term (which may have similar
 #'   predictors but, say, a different network subset) in the output
 #'   *or* a function that wraps the names.
-#' @template ergmTerm-NetworkIDName
+#'
+#' @param .combiner A character vector specifying which combiner, such
+#'   as [`Layer`] or [`Networks`] is expected to have created the LHS
+#'   network.
 #'
 #' @section Offsets and fixing parameters:
 #'
@@ -158,21 +151,21 @@ assert_LHS_Networks <- function(nw, nid, term_trace = TRUE, call = if(term_trace
 #' @concept operator
 #' @concept directed
 #' @concept undirected
-InitErgmTerm.N <- function(nw, arglist, ..., N.compact_stats=TRUE, .NetworkID=".NetworkID", .NetworkName=".NetworkName"){
+InitErgmTerm.N <- function(nw, arglist, ..., N.compact_stats=TRUE, .combiner = "Networks"){
   a <- check.ErgmTerm(nw, arglist,
-                      varnames = c("formula", "lm", "subset", "weights", "contrasts", "offset", "label", ".NetworkID", ".NetworkName"),
-                      vartypes = c("formula", "formula", "formula,logical,numeric,expression,call", "formula,logical,numeric,expression,call", "list", "formula,logical,numeric,expression,call", "character,function", "character", "character"),
-                      defaultvalues = list(NULL, ~1, TRUE, 1, NULL, NULL, NULL, .NetworkID, .NetworkName),
-                      required = c(TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE))
+                      varnames = c("formula", "lm", "subset", "weights", "contrasts", "offset", "label", ".combiner"),
+                      vartypes = c("formula", "formula", "formula,logical,numeric,expression,call", "formula,logical,numeric,expression,call", "list", "formula,logical,numeric,expression,call", "character,function", "character"),
+                      defaultvalues = list(NULL, ~1, TRUE, 1, NULL, NULL, NULL, .combiner),
+                      required = c(TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE))
 
-  assert_LHS_Networks(nw, a$.NetworkID)
+  assert_combined_network(nw, a$.combiner)
 
-  auxiliaries <- eval(substitute(~.subnets(.NetworkID), list(.NetworkID=a$.NetworkID)), baseenv())
+  auxiliaries <- base_env(~.subnets)
 
-  nwl <- subnetwork_templates(nw, a$.NetworkID, a$.NetworkName)
+  nwl <- subnetwork_templates(nw)
   nwnames <- names(nwl)
   nn <- length(nwl)
-  nattrs <- as_tibble(nw, unit="networks", .NetworkID=a$.NetworkID, .NetworkName=a$.NetworkName, store.nid=TRUE)
+  nattrs <- as_tibble(nw, unit="networks")
 
   lmi <- get_lminfo(nattrs, lm=a$lm, subset=a$subset, contrasts=a$contrasts, offset=a$offset, weights=a$weights)
 
@@ -356,16 +349,16 @@ InitErgmTerm.N <- function(nw, arglist, ..., N.compact_stats=TRUE, .NetworkID=".
 #' @concept directed
 #' @concept undirected
 #' @noRd
-InitErgmTerm.ByNetDStats <- function(nw, arglist, ..., .NetworkID=".NetworkID"){
+InitErgmTerm.ByNetDStats <- function(nw, arglist, ...){
   a <- check.ErgmTerm(nw, arglist,
-                      varnames = c("formula",  "subset", ".NetworkID"),
+                      varnames = c("formula",  "subset", ".combiner"),
                       vartypes = c("formula", "formula,logical,numeric,expression,call", "character"),
-                      defaultvalues = list(NULL, TRUE, .NetworkID),
+                      defaultvalues = list(NULL, TRUE, "Networks"),
                       required = c(TRUE, FALSE, FALSE))
 
-  assert_LHS_Networks(nw, a$.NetworkID)
+  assert_combined_network(nw, a$.combiner)
 
-  auxiliaries <- eval(substitute(~.subnets(.NetworkID), list(.NetworkID=a$.NetworkID)), baseenv())
+  auxiliaries <- base_env(~.subnets)
   nattrs <- as_tibble(nw, unit="networks")
 
   lmi <- get_lminfo(nattrs, subset=a$subset)

R/InitErgmTerm.spcache.multilayer.R

@@ -15,7 +15,7 @@ InitErgmTerm..spcache.netL<-function(nw, arglist, ...){
                       defaultvalues = list(NULL,NULL,NULL),
                       required = c(TRUE, TRUE, TRUE))
 
-  assert_LHS_Layer(nw)
+  assert_combined_network(nw, "Layer")
 
   type <- match.arg(tolower(a$type), c("otp","osp","isp","utp")) # ITP not included, because it's just OTP with direction reversed.
 

R/InitWtErgmTerm.multinet.R

@@ -23,7 +23,7 @@ InitWtErgmTerm..subnets <- function(...){
 #' @template ergmTerm-rdname
 #' @usage
 #' # valued: N(formula, lm=~1, subset=TRUE, weights=1, contrasts=NULL, offset=0, label=NULL,
-#' #           .NetworkID=".NetworkID", .NetworkName=".NetworkName")
+#' #           .combiner = "Networks")
 InitWtErgmTerm.N <- function(...){
   # Rename the function to avoid the extra nesting level in the
   # diagnostic messages.

R/block_blacklist.R

@@ -116,14 +116,14 @@ flatten_guid_pairs <- function(guidll){
 
 get_all_bl_subnetattr <- function(l){
   lapply(l, function(subl)
-    c(subl$.block_blacklist, lapply(subl$.subnetattr, get_all_bl_subnetattr), recursive=FALSE)
+    c(subl$.block_blacklist, lapply(subl$.snattr, get_all_bl_subnetattr), recursive=FALSE)
     ) %>% flatten_guid_pairs
 }
 
 #' Obtain and concatenate unique block blacklists from the specified
 #' networks, which may be combined networks.
 #' @noRd
 get_all_bl <- function(nw, blacklist_nattr=".block_blacklist"){
-  c(nw%n%blacklist_nattr, get_all_bl_subnetattr(nw%n%".subnetattr")) %>% unique
+  c(nw%n%blacklist_nattr, get_all_bl_subnetattr(list(nw%n%".snattr"))) %>% unique
 }