R/ergm_state.R

In ergm: Fit, Simulate and Diagnose Exponential-Family Models for Networks

#  File R/ergm_state.R in package ergm, part of the
#  Statnet suite of packages for network analysis, https://statnet.org .
#
#  This software is distributed under the GPL-3 license.  It is free,
#  open source, and has the attribution requirements (GPL Section 7) at
#  https://statnet.org/attribution .
#
#  Copyright 2003-2023 Statnet Commons
################################################################################
#' A Representation of ERGM state
#' 
#' `ergm_state` is a family of semi-internal classes for passing
#' around results of MCMC sampling, particularly when the result is
#' used to start another MCMC sampler. It is deliberately loosely
#' specified, and its structure and even name are subject to change.
#'
#' @param nw a [`network`] object.
#' @param nw0 a [`network`] object, whose edges are absent or ignored.
#' @param model an [`ergm_model`] object.
#' @param ext.state a list equal to the number of terms in the model,
#'   providing the encoded extended state. This vector is usually
#'   generated by `ext.encode()` function of an `ergm` term, but it
#'   can be specified directly.
#' @param ... Additional arguments, passed to further methods.
#'
#' @return At this time, an `ergm_state` object is (subject to change)
#'   a list containing some subset of the following elements, with
#'   `el`, `ext.state`, and `ext.flag` mandatory and others depending
#'   on how it is used:
#' \describe{
#' 
#' \item{el}{a [`tibble`] [`edgelist`] representing the edge state of the network}
#' 
#' \item{nw0}{a [`network`] object with all edges removed.}
#'
#' \item{model}{an [`ergm_model`] object.}
#'
#' \item{proposal}{an [`ergm_proposal`] object.}
#'
#' \item{ext.state}{a list of length equalling to the number of terms in the model.}
#'
#' \item{ext.flag}{one of `ERGM_STATE_R_CHANGED`, `ERGM_STATE_C_CHANGED`, and `ERGM_STATE_R_RECONCILED`.}
#'
#' \item{stats}{a numeric vector of network statistics or some other
#' statistics used to resume.}
#'
#' \item{uids}{a named list of globally unique ID strings associated with a `model` and/or `proposal`; for the `ergm_state_send` and `ergm_state_receive`, these strings may be retained even if these values are set to `NULL`}
#' }
#'
#' @details
#'
#' `ergm_state` is actually a hierarchy of classes, defined by what
#' they can be used for. Specifically,
#' \describe{
#'
#' \item{c(`ergm_state_receive`,`ergm_state`)}{ needs to contain only `el`, `ext.state`, and `ext.flag`: it is the information that can change in the process of MCMC sampling; it is the one returned by the `*_slave` functions, to minimize the amount of data being sent between nodes in parallel computing.}
#' \item{c(`ergm_state_send`,`ergm_state_receive`,`ergm_state`)}{ needs the above but also the `model` and the `proposal`: is needed to initiate MCMC sampling; it is the information required by the `*_slave` functions, again, to minimize the amount of data being sent between nodes in parallel computing.}
#' \item{c(`ergm_state_full`, `ergm_state_send`,`ergm_state_receive`,`ergm_state`)}{ needs the above but also the `nw0`: is needed to reconstruct the original network.}
#'
#' }
#'
#' @seealso [ergm_MCMC_sample()] for an example of manually
#'   constructing and manipulating an `ergm_state`.
#'
#' @keywords internal
#' @export
ergm_state <- function(x, ...) UseMethod("ergm_state")

#' @describeIn ergm_state a method for constructing an ergm_state from an [`edgelist`] object and an empty [`network`].
#' @export
ergm_state.edgelist <- function(x, nw0, model=NULL, proposal=NULL, stats=NULL, ext.state=NULL,...){
  response <- if(ncol(x)>=3) colnames(x)[3]
  out <- list()
  if(is.matrix(x)){
    x <- as_tibble(x)
    colnames(x) <- c(".tail",".head",response)
    x <- as.edgelist(x, n=network.size(nw0), directed=is.directed(nw0), bipartite=NVL(nw0%n%"bipartite", FALSE), loops=has.loops(nw0), vnames=nw0 %v% "vertex.names", output="tibble")
  }
  out$el <- x
  if(is.valued(nw0)){
    out$el <- out$el[!is.na(out$el[[response]]) & out$el[[response]]!=0,]
    mode(out$el[[3]]) <- "double" # If network is empty, may default to a list().
  }
  out$nw0 <- nw0
  out$nw0[,] <- FALSE
  out$model <- model
  out$proposal <- proposal
  out$stats <- as.double(stats)
  if(!is.null(ext.state)){
    out$ext.state <- ext.state
    out$ext.flag <- ERGM_STATE_C_CHANGED
  }else{
    out$ext.state <- vector("list", length(out$model$terms))
    out$ext.flag <- ERGM_STATE_R_CHANGED
    out <- .reconcile_ergm_state(out)
  }

  out <- .copy_state_uids(out)
  structure(out, class=c("ergm_state_full", "ergm_state_send", "ergm_state_receive", "ergm_state"))
}

#' @describeIn ergm_state a method for constructing an ergm_state from a matrix object and an empty [`network`].
#' @export
ergm_state.matrix <- ergm_state.edgelist

#' @describeIn ergm_state a method for constructing an ergm_state from
#'   a [`network`] object. Note that `...` arguments will be passed
#'   directly to the [`edgelist`] method.
#' @export
ergm_state.network <- function(x, ...){
  el <- as.edgelist(x, attrname=x %ergmlhs% "response", output="tibble")
  nw0 <- x
  ergm_state(el, nw0, ...)
}

#' @rdname ergm_state
#' @export
is.ergm_state <- function(x){
  is(x, "ergm_state")
}

#' @rdname ergm_state
#' @export
as.edgelist.ergm_state <- function(x,...){
  x$el
}

#' @rdname ergm_state
#' @export
as.matrix.ergm_state <- function(x,matrix.type=NULL,...){
  matrix.type<-match.arg(matrix.type,c("adjacency","incidence","edgelist"))
  if(matrix.type!="edgelist") stop("ergm_state can only be converted to an edgelist at this time")

  as.matrix(x$el)
}

#' @rdname ergm_state
#' @export
as.network.ergm_state_full <- function(x, ..., populate=TRUE){
  if(!populate) x$nw0
  else update(x$nw0,x$el)
}

#' @describeIn ergm_state Note that this method fails when
#'   `na.omit=FALSE`, since missing edges are not stored.
#' @param na.omit Whether missing edges should be counted. Note that
#'   missing edge information is not stored.
#' @export
network.edgecount.ergm_state <- function(x, na.omit=TRUE,...){
  if(!na.omit) stop("ergm_state cannot store missing edges.")
  nrow(x$el)
}

#' @describeIn ergm_state Note that this method fails with
#'   its default argument, since missing edges are not stored.
#' @export
network.dyadcount.ergm_state_full <- function(x, na.omit=TRUE,...){
  if(na.omit) stop("ergm_state cannot store missing edges.")
  network.dyadcount(x$nw0, na.omit=na.omit)
}

#' @rdname ergm_state
#' @export
network.size.ergm_state_full <- function(x,...){
  network.size(x$nw0)
}

#' @describeIn ergm_state A stub that returns 0.
#' @export
network.naedgecount.ergm_state <- function(x,...){
  0
}

#' @rdname ergm_state
#' @export
`%ergmlhs%.ergm_state_full` <- function(lhs, setting){
  lhs$nw0 %ergmlhs% setting
}

#' @rdname ergm_state
#' @export
`%ergmlhs%<-.ergm_state_full` <- function(lhs, setting, value){
  lhs$nw0 %ergmlhs% setting <- value
  lhs
}

#' @rdname ergm_state
#' @export
as.rlebdm.ergm_state <- function(x, ...){
  as.rlebdm(x$el, ...)
}

#' @rdname ergm_state
#' @export
as.ergm_model.ergm_state_send <- function(x, ...) x$model

#' @rdname ergm_state
#' @export
is.curved.ergm_state_send <- function(object, ...) is.curved(object$model, ...)

#' @rdname ergm_state
#' @export
param_names.ergm_state_send <- function(object, ...) param_names(object$model, ...)

#' @rdname ergm_state
#' @export
nparam.ergm_state_send <- function(object, ...) nparam(object$model, ...)

#' @describeIn ergm_state a method for updating an `ergm_state` and reconciling extended state.
#' @param state An `ergm_state` to replace the state with.
#' @export
update.ergm_state_full <- function(object, el=NULL, nw0=NULL, model=NULL, proposal=NULL, stats=NULL, ext.state=NULL, state=NULL, ...){
  if(!is.null(state)){
    for(name in names(state)) object[[name]] <- state[[name]]
  }

  object <- .reconcile_ergm_state(object)
  
  if(!is.null(nw0)){
    if(!is.network(nw0)) stop("New nw0 is not a network object.")
    object$nw0 <- nw0
    object$ext.flag <- ERGM_STATE_R_CHANGED
  }

  if(!is.null(el)){
    if(!is(el, "tibble_edgelist")) stop("New el is not a tibble-style edgelist.")
    object$el <- el
    object$ext.flag <- ERGM_STATE_R_CHANGED
  }

  if(!is.null(model)){
    if(!is(model, "ergm_model")) stop("New model is not an ergm_model.")
    object$model <- model
    object$ext.flag <- ERGM_STATE_R_CHANGED
    object$uids$model <- NULL
  }

  if(!is.null(proposal)){
    if(!is(proposal, "ergm_proposal")) stop("New proposal is not an ergm_proposal.")
    object$proposal <- proposal
    object$uids$proposal <- NULL
  }

  if(!is.null(stats)) object$stats <- as.double(stats)

  if(!is.null(ext.state)){
    if(!is.list(ext.state) || length(ext.state)!=length(object$ext.state)) stop("New ext.state is not a list of the correct length.")
    object$ext.state <- ext.state
    object$ext.flag <- ERGM_STATE_C_CHANGED
  }

  object <- .copy_state_uids(object)
  .reconcile_ergm_state(object)
}

#' @describeIn ergm_state a method for constructing an `ergm_state`.
#' @export
ergm_state.ergm_state <- function(x, model=NULL, proposal=NULL, stats=NULL, ...){
  update(x, model=model, proposal=proposal, stats=stats, ...)
}

#' @rdname ergm_state
#' @export
ERGM_STATE_R_CHANGED <- -1L
#' @rdname ergm_state
#' @export
ERGM_STATE_C_CHANGED <- +1L
#' @rdname ergm_state
#' @export
ERGM_STATE_RECONCILED <- 0L
.reconcile_ergm_state <- function(object){
  if(is.null(object$model) || object$ext.flag==ERGM_STATE_RECONCILED) return(object)

  reencode <- logical(length(object$model$terms))
  if(object$ext.flag==ERGM_STATE_C_CHANGED){ # Extended state changed in C; decode.
    for(i in seq_along(object$model$terms)){
      trm <- object$model$terms[[i]]

      # Dual purpose here: if a term doesn't have a decoder (i.e.,
      # doesn't update ext.state) skip it---but if it has an encoder,
      # flag it to run later, because whatever changes to nw0 had been
      # made, they could have invalidated the other term's ext.state.
      if(is.null(trm$ext.decode)){
        reencode[i] <- !is.null(trm$ext.encode)
        next
      }

      o <- trm$ext.decode(object$ext.state[[i]], object$el, object$nw0)
      object$el <- o$el
      object$nw0 <- o$nw0
    }
  }else if(object$ext.flag==ERGM_STATE_R_CHANGED) reencode[] <- TRUE


  # Extended state changed in R; encode all.

  object$ext.state[reencode] <- lapply(object$model$terms[reencode], function(trm){
    if(!is.null(trm$ext.encode)) trm$ext.encode(el=object$el, nw0=object$nw0)
  })

  object$ext.flag <- ERGM_STATE_RECONCILED
  object
}

.copy_state_uids <- function(object){
  if(is.null(object$uids$model)) object$uids$model <- object$model$uid
  if(is.null(object$uids$proposal)) object$uids$proposal <- object$proposal$uid
  object
}

#' @rdname ergm_state
#' @export
ergm_state_send <- function(x, ...){
  UseMethod("ergm_state_send")
}

#' @rdname ergm_state
#' @export
ergm_state_send.ergm_state_send <- function(x, ...){
  x$nw0 <- NULL
  structure(x, class=c("ergm_state_send","ergm_state_receive","ergm_state"))
}

#' @rdname ergm_state
#' @export
ergm_state_send.ergm_state_full <- function(x, ...){
  if(x$ext.flag == ERGM_STATE_R_CHANGED)
    x <- .reconcile_ergm_state(x)
  NextMethod("ergm_state_send")
}

#' @rdname ergm_state
#' @export
ergm_state_send.ergm_state_receive <- function(x, ...){
  if(!is.null(x$uids$model)) x$model <- ergm_state_cache("get", x$uids$model)
  if(!is.null(x$uids$proposal)) x$proposal <- ergm_state_cache("get", x$uids$proposal)
  structure(x, class=c("ergm_state_send","ergm_state_receive","ergm_state"))
}


#' @rdname ergm_state
#' @export
update.ergm_state_send <- function(object, state, ...){
  for(name in names(state)) object[[name]] <- state[[name]]
  object
}

#' @rdname ergm_state
#' @export
ergm_state_receive <- function(x, ...){
  UseMethod("ergm_state_receive")
}

#' @rdname ergm_state
#' @export
ergm_state_receive.ergm_state <- function(x, ...){
  x$nw0 <- NULL
  x$model <- NULL
  x$proposal <- NULL
  structure(x, class=c("ergm_state_receive","ergm_state"))
}

#' @rdname ergm_state
#' @export
ergm_state_receive.ergm_state_full <- function(x, ...){
  if(x$ext.flag == ERGM_STATE_R_CHANGED)
    x <- .reconcile_ergm_state(x)
  NextMethod("ergm_state_receive")
}

#' Deallocate the C data structures corresponding to an [`ergm_state`] left over from a [.Call()] run.
#'
#' This function is exported for use by other packages that use the `ErgmState` C API. It should be used as a part of an [on.exit()] call in the function that calls the C routine if the C routine contains `R_CheckUserInterrupt()` calls, in order to ensure that memory is freed if the routine is interrupted.
#'
#' @examples
#' \dontrun{
#' long_run <- function(...){
#'   on.exit(ergm_Cstate_clear())
#'   .Call("long_run",...)
#' }
#' }
#'
#' @keywords internal
#' @seealso [`ergm_state`]
#' @export
ergm_Cstate_clear <- function(){
  .Call("ErgmStateArrayClear", PACKAGE="ergm")
  .Call("ErgmWtStateArrayClear", PACKAGE="ergm")
}