Nothing
# 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 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")
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.