Nothing
#' @export
print.dcm <- function(x, ...) {
# New model
new.mod <- ifelse(!is.null(x$control$new.mod), TRUE, FALSE)
cat("EpiModel Simulation")
cat("\n=======================")
cat("\nModel class:", class(x))
cat("\n\nSimulation Summary")
cat("\n-----------------------")
if (new.mod == FALSE) {
cat("\nModel type:", x$control$type)
}
cat("\nNo. runs:", x$control$nruns)
cat("\nNo. time steps:", x$control$nsteps)
if (new.mod == FALSE) {
cat("\nNo. groups:", x$param$groups)
}
cat("\n\nModel Parameters")
cat("\n-----------------------\n")
pToPrint <- which(!(names(x$param) %in% c("groups", "vital")))
for (i in pToPrint) {
cat(names(x$param)[i], "=", x$param[[i]], fill = 60)
}
cat("\nModel Output")
cat("\n-----------------------")
cat("\nVariables:", names(x$epi), fill = 60)
invisible()
}
#' @export
print.icm <- function(x, ...) {
cat("EpiModel Simulation")
cat("\n=======================")
cat("\nModel class:", class(x))
cat("\n\nSimulation Summary")
cat("\n-----------------------")
cat("\nModel type:", x$control$type)
cat("\nNo. simulations:", x$control$nsims)
cat("\nNo. time steps:", x$control$nsteps)
cat("\nNo. groups:", x$param$groups)
cat("\n\nModel Parameters")
cat("\n-----------------------\n")
pToPrint <- which(!(names(x$param) %in% c("groups", "vital")))
for (i in pToPrint) {
cat(names(x$param)[i], "=", x$param[[i]], fill = 60)
}
cat("\nModel Output")
cat("\n-----------------------")
cat("\nVariables:", names(x$epi), fill = 60)
invisible()
}
#' @export
print.netest <- function(x, digits = 3, ...) {
cat("EpiModel Network Estimation")
cat("\n=======================")
cat("\nModel class:", class(x))
estmeth <- ifelse(x$edapprox == TRUE, "ERGM with Edges Approximation",
"Full STERGM Fit")
cat(paste("\nEstimation Method:", estmeth))
cat("\n\nModel Form")
cat("\n-----------------------")
cat("\nFormation: ")
print(x$formation)
cat("Target Statistics:", x$target.stats)
cat("\nConstraints: ")
cat(paste0(as.character(x$constraints)[1],
as.character(x$constraints)[2]))
cat("\n\nDissolution: ")
cat(as.character(x$coef.diss$dissolution), sep = "")
cat("\nTarget Statistics:", x$coef.diss$duration)
invisible()
}
#' @rdname print.netdx
#' @title Utility Function for Printing netdx Object
#' @description Prints basic information and statistics from a \code{netdx}
#' object.
#' @param x an object of class \code{netdx}
#' @param digits number of digits to print in statistics tables
#' @param ... additional arguments (currently ignored)
#' @details
#' Given a \code{netdx} object, \code{print.netdx} prints the diagnostic method
#' (static/dynamic), number of simulations, and (if dynamic) the number of time
#' steps per simulation used in generating the \code{netdx} object, as well as
#' printing the formation statistics table and (if present) the duration and
#' dissolution statistics tables. The statistics tables are interpreted as
#' follows.
#'
#' Each row has the name of a particular network statistic. In the formation
#' table, these correspond to actual network statistics in the obvious way.
#' In the duration and dissolution tables, these correspond to dissolution
#' model dyad types: in a homogeneous dissolution model, all dyads are of the
#' \code{edges} type; in a heterogeneous dissolution model, a dyad with a
#' nonzero \code{nodematch} or \code{nodemix} change statistic in the
#' dissolution model has type equal to that statistic, and has type equal to
#' \code{edges} otherwise. The statistics of interest for the duration and
#' dissolution tables are, respectively, the mean age of extant edges and the
#' edge dissolution rate, broken down by dissolution model dyad type. (The
#' current convention is to treat the mean age and dissolution rate for a
#' particular dissolution dyad type as 0 on time steps with no edges of that
#' type; this behavior may be changed in the future.)
#'
#' The columns are named \code{Target}, \code{Sim Mean}, \code{Pct Diff},
#' \code{Sim SE}, \code{Z Score}, \code{SD(Sim Means)}, and
#' \code{SD(Statistic)}. The \code{Sim Mean} column refers to the mean
#' statistic value, across all time steps in all simulations in the dynamic
#' case, and across all sampled networks in all simulations in the static case.
#' The \code{Sim SE} column refers to the standard error in the mean, estimated
#' using \code{\link[=effectiveSize]{coda::effectiveSize}}. The \code{Target}
#' column indicates the target value (if present) for the statistic, and the
#' \code{Pct Diff} column gives \code{(Sim Mean - Target)/Target} when
#' \code{Target} is present. The \code{Z Score} column gives
#' \code{(Sim Mean - Target)/(Sim SE)}. The \code{SD(Sim Means)} column gives
#' the empirical standard deviation across simulations of the mean statistic
#' value within simulation, and \code{SD(Statistic)} gives the empirical
#' standard deviation of the statistic value across all the simulated data.
#' @export
print.netdx <- function(x, digits = 3, ...) {
cat("EpiModel Network Diagnostics")
cat("\n=======================")
dxmethod <- ifelse(x$dynamic == TRUE, "Dynamic", "Static")
cat("\nDiagnostic Method:", dxmethod)
cat("\nSimulations:", x$nsims)
if (x$dynamic == TRUE) {
cat("\nTime Steps per Sim:", x$nsteps)
}
cat("\n\nFormation Diagnostics")
cat("\n----------------------- \n")
print_nwstats_table(x$stats.table.formation, digits)
if (x$dynamic == TRUE && !is.null(x$stats.table.duration)) {
cat("\nDuration Diagnostics")
cat("\n----------------------- \n")
print_nwstats_table(x$stats.table.duration, digits)
}
if (x$dynamic == TRUE && !is.null(x$stats.table.dissolution)) {
cat("\nDissolution Diagnostics")
cat("\n----------------------- \n")
print_nwstats_table(x$stats.table.dissolution, digits)
}
if (x$anyNA == TRUE) {
cat("\nNOTE: Duration and dissolution data contains undefined values due to",
"having zero edges of some dissolution dyad type(s) on some time",
"steps; these undefined values will be set to 0 when",
"processing the data; this behavior, which introduces a bias",
"towards 0, may be changed in the future.")
}
invisible()
}
#' @export
print.netsim <- function(x, nwstats = TRUE, digits = 3, network = 1, ...) {
nsims <- x$control$nsims
if (nsims == 1) {
simnames <- "sim1"
}
if (nsims == 2) {
simnames <- "sim1 sim2"
}
if (nsims > 2) {
simnames <- paste0("sim1 ... sim", nsims)
}
cat("EpiModel Simulation")
cat("\n=======================")
cat("\nModel class:", class(x))
cat("\n\nSimulation Summary")
cat("\n-----------------------")
cat("\nModel type:", x$control$type)
cat("\nNo. simulations:", nsims)
cat("\nNo. time steps:", x$control$nsteps)
cat("\nNo. NW groups:", x$param$groups)
# Parameters
cat("\n\n")
print(x$param)
if (is.null(x$control$type)) {
cat("\nModel Functions")
cat("\n-----------------------\n")
for (i in seq_along(x$control$f.names)) {
cat(x$control$f.names[i], "\n")
}
}
cat("\nModel Output")
cat("\n-----------------------")
cat("\nVariables:", names(x$epi), fill = 60)
if (!(is.null(x$network))) {
cat("Networks:", simnames)
}
if (!(is.null(x$stats$transmat))) {
if (!is.null(x$network)) {
cat("\nTransmissions:", simnames)
} else {
cat("Transmissions:", simnames)
}
}
if (!is.null(x$control$save.other)) {
names_present <- intersect(x$control$save.other, names(x))
if (length(names_present) > 0) {
cat("\nOther Elements:", names_present)
}
}
cat("")
if (nwstats && !is.null(x$stats$nwstats)) {
stats <- get_nwstats(x, network = network, mode = "list")
nsims <- x$control$nsims
target.stats <- x$nwparam[[network]]$target.stats
ts.attr.names <- x$nwparam[[network]]$target.stats.names
names(target.stats) <- ts.attr.names
stats.table.formation <- make_stats_table(stats, target.stats)
cat("\n\nFormation Statistics")
cat("\n----------------------- \n")
print_nwstats_table(stats.table.formation, digits = digits)
cat("\n")
if (x$control$save.diss.stats &&
x$control$save.network &&
! x$control$tergmLite &&
! is.null(x$diss.stats) &&
x$nwparam[[network]]$coef.diss$dissolution == ~ offset(edges)) {
if (any(unlist(lapply(x$diss.stats, `[[`, "anyNA")))) {
cat("\nNOTE: Duration & dissolution data contains undefined values due to zero edges of some dissolution
dyad type(s) on some time step; these undefined values will be set to 0 when processing the data.")
}
dur_stats <- lapply(x$diss.stats, function(ds) ds[[network]][["meanageimputed"]])
diss_stats <- lapply(x$diss.stats, function(ds) ds[[network]][["propdiss"]])
dur_table <- make_stats_table(dur_stats, x$nwparam[[network]]$coef.diss$duration)
diss_table <- make_stats_table(diss_stats, 1 / x$nwparam[[network]]$coef.diss$duration)
cat("\nDuration Statistics")
cat("\n----------------------- \n")
print_nwstats_table(dur_table, digits)
cat("\nDissolution Statistics")
cat("\n----------------------- \n")
print_nwstats_table(diss_table, digits)
} else {
cat("\nDuration and Dissolution Statistics")
cat("\n----------------------- \n")
cat("Not available when:")
cat("\n- `control$tergmLite == TRUE`")
cat("\n- `control$save.network == FALSE`")
cat("\n- `control$save.diss.stats == FALSE`")
cat("\n- dissolution formula is not `~ offset(edges)`")
cat("\n- `keep.diss.stats == FALSE` (if merging)")
cat("\n")
}
}
cat("\n")
invisible()
}
#' @export
print.disscoef <- function(x, ...) {
cat("Dissolution Coefficients")
cat("\n=======================")
cat("\nDissolution Model: ")
cat(as.character(x$dissolution), sep = "")
cat("\nTarget Statistics:", x$duration)
cat("\nCrude Coefficient:", x$coef.crude)
cat("\nMortality/Exit Rate:", x$d.rate)
cat("\nAdjusted Coefficient:", x$coef.adj)
cat("\n")
invisible()
}
#' @title Format One Parameter for Printing with the \code{print.param.xxx}
#' Functions
#'
#' @param param_name The name of the parameter to print.
#' @param param_value The value of the parameter to print.
#'
#' @keywords internal
format_param <- function(param_name, param_value) {
if (is.numeric(param_value) && length(param_value) > 10) {
cat(param_name, "=", param_value[1:10], "...", fill = 80)
} else if (is.data.frame(param_value)) {
cat(param_name, "= <data.frame>\n")
} else if (is.list(param_value)) {
cat(param_name, "= <list>\n")
} else if (inherits(param_value, "lm")) {
cat(param_name, "= <lm/glm>\n")
} else {
cat(param_name, "=", param_value, fill = 80)
}
}
#' @export
print.param.dcm <- function(x, ...) {
pToPrint <- seq_along(x)
cat("DCM Parameters")
cat("\n===========================\n")
for (i in pToPrint) {
format_param(names(x)[i], x[[i]])
}
invisible()
}
#' @export
print.param.icm <- function(x, ...) {
pToPrint <- which(!(names(x) %in% c("vital")))
cat("ICM Parameters")
cat("\n===========================\n")
for (i in pToPrint) {
format_param(names(x)[i], x[[i]])
}
invisible()
}
#' @export
print.param.net <- function(x, ...) {
randoms <- c("random.params", "random.params.values")
pToPrint <- which(!(names(x) %in% c("vital", randoms)))
rng_values <- list()
rng_defs <- NULL
if (all(randoms %in% names(x))) {
rng_values <- x$random.params.values
pToPrint <- pToPrint[! names(x)[pToPrint] %in% names(rng_values)]
} else if (randoms[1] %in% names(x)) {
rng_defs <- names(x[[randoms[1]]])
pToPrint <- pToPrint[! names(x)[pToPrint] %in% rng_defs]
}
cat("Fixed Parameters")
cat("\n---------------------------\n")
for (i in pToPrint) {
format_param(names(x)[i], x[[i]])
}
if (!is.null(rng_defs)) {
cat("\nRandom Parameters")
cat("\n(Not drawn yet)")
cat("\n---------------------------\n")
for (prm in rng_defs) {
if (prm == "param.random.set") {
cat(prm, "= <data.frame> ( dimensions:",
dim(x$random.param$param.random.set), ")\n")
} else {
cat(prm, "= <function>\n")
}
}
}
if (length(rng_values) > 0) {
cat("\nRandom Parameters")
cat("\n---------------------------\n")
for (i in seq_along(rng_values)) {
format_param(names(rng_values)[i], rng_values[[i]])
}
}
invisible()
}
#' @export
print.init.dcm <- function(x, ...) {
pToPrint <- seq_along(x)
cat("DCM Initial Conditions")
cat("\n===========================\n")
for (i in pToPrint) {
if (inherits(x[[i]], c("integer", "numeric")) && length(x[[i]]) > 10) {
cat(names(x)[i], "=", x[[i]][1:5], "...", fill = 80)
} else if (inherits(x[[i]], "data.frame")) {
cat(names(x)[i], "= <data.frame>\n")
} else if (inherits(x[[i]], "list")) {
cat(names(x)[i], "= <list>\n")
} else {
cat(names(x)[i], "=", x[[i]], fill = 80)
}
}
invisible()
}
#' @export
print.init.icm <- function(x, ...) {
pToPrint <- seq_along(x)
cat("ICM Initial Conditions")
cat("\n===========================\n")
for (i in pToPrint) {
if (inherits(x[[i]], c("integer", "numeric")) && length(x[[i]]) > 10) {
cat(names(x)[i], "=", x[[i]][1:5], "...", fill = 80)
} else if (inherits(x[[i]], "data.frame")) {
cat(names(x)[i], "= <data.frame>\n")
} else if (inherits(x[[i]], "list")) {
cat(names(x)[i], "= <list>\n")
} else {
cat(names(x)[i], "=", x[[i]], fill = 80)
}
}
invisible()
}
#' @export
print.init.net <- function(x, ...) {
pToPrint <- seq_along(x)
cat("Network Model Initial Conditions")
cat("\n=================================\n")
for (i in pToPrint) {
if (inherits(x[[i]], c("integer", "numeric")) && length(x[[i]]) > 10) {
cat(names(x)[i], "=", x[[i]][1:5], "...", fill = 80)
} else if (inherits(x[[i]], "data.frame")) {
cat(names(x)[i], "= <data.frame>\n")
} else if (inherits(x[[i]], "list")) {
cat(names(x)[i], "= <list>\n")
} else {
cat(names(x)[i], "=", x[[i]], fill = 80)
}
}
invisible()
}
#' @export
print.control.dcm <- function(x, ...) {
pToPrint <- seq_along(names(x))
pToPrint <- pToPrint[-which(names(x) == "new.mod")]
if (!is.null(x$new.mod)) {
names(x)[which(names(x) == "new.mod.name")] <- "new.mod"
}
cat("DCM Control Settings")
cat("\n===========================\n")
for (i in pToPrint) {
cat(names(x)[i], "=", x[[i]], fill = 80)
}
invisible()
}
#' @export
print.control.icm <- function(x, ...) {
pToPrint <- which(!grepl(".FUN", names(x)) &
!(names(x) %in% c("bi.mods", "user.mods")))
cat("ICM Control Settings")
cat("\n===========================\n")
for (i in pToPrint) {
cat(names(x)[i], "=", x[[i]], fill = 80)
}
cat("Base Modules:", x$bi.mods, fill = 80)
if (length(x$user.mods) > 0) {
cat("Extension Modules:", x$user.mods, fill = 80)
}
invisible()
}
#' @export
print.control.net <- function(x, ...) {
pToPrint <- which(
!grepl(".FUN", names(x)) &
names(x) != "f.args" &
names(x) != "f.names" &
names(x) != "set.control.tergm" &
names(x) != "set.control.ergm" &
names(x) != "dat.updates" &
!(names(x) %in% c("bi.mods", "user.mods"))
)
cat("Network Model Control Settings")
cat("\n===============================\n")
for (i in pToPrint) {
if (inherits(x[[i]], "formula")) {
cat(names(x)[i], "= ")
cat(paste0(as.character(x[[i]])[1],
as.character(x[[i]])[2]), "\n")
} else if (inherits(x[[i]], "data.frame")) {
cat(names(x)[i], "= <data.frame>\n")
} else if (inherits(x[[i]], "list")) {
cat(names(x)[i], "= <list>\n")
} else {
cat(names(x)[i], "=", x[[i]], fill = 80)
}
}
if (!is.null(x$module.order)) {
funToPrint <- x$module.order
} else {
funToPrint <- names(x)[grep(".FUN", names(x))]
funToPrint <- funToPrint[!funToPrint %in% c("initialize.FUN",
"verbose.FUN")]
}
cat("Dynamic Modules:", funToPrint)
cat("\n")
invisible()
}
#' @title Print Helper For Network Stats Tables
#'
#' @param nwtable A formation or dissolution statistics \code{data.frame}.
#' @param digits Argument to be passed to \code{round}.
#'
#' @keywords internal
print_nwstats_table <- function(nwtable, digits) {
print(as.data.frame(round(as.matrix(nwtable), digits = digits)))
}
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.