Skip to content

Commit 1d53f86

Browse files
smjennesssmjenness
authored
Merge pull request #22 from statnet/init-setup
Creates a simulation set up fx for easier testing and EpiModel integration
2 parents 82ce8d3 + 1cb3136 commit 1d53f86

11 files changed

Lines changed: 312 additions & 273 deletions

File tree

‎.travis.yml‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,9 @@ language: r
33
sudo: false
44
cache: packages
55

6-
warnings_are_errors: false
6+
r_github_packages: statnet/EpiModel
7+
8+
warnings_are_errors: true
79

810
notifications:
911
email:

‎DESCRIPTION‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,8 @@ Imports:
1717
ergm (>= 3.9.4),
1818
statnet.common (>= 4.1.4),
1919
Rcpp,
20-
tergm (>= 3.5.2)
20+
tergm (>= 3.5.2),
21+
network
2122
Suggests: testthat, EpiModel
2223
LinkingTo: Rcpp, ergm
2324
LazyData: true

‎NAMESPACE‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,13 +4,15 @@ export(add_vertices)
44
export(delete_vertices)
55
export(ergm_prep)
66
export(get_formula_term_args_in_formula_env)
7+
export(init_tergmLite)
78
export(simulate_ergm)
89
export(simulate_network)
910
export(stergm_prep)
1011
export(updateModelTermInputs)
1112
import(ergm)
1213
import(tergm)
1314
importFrom(Rcpp,sourceCpp)
15+
importFrom(network,as.edgelist)
1416
importFrom(statnet.common,NVL)
1517
importFrom(statnet.common,term.list.formula)
1618
importFrom(stats,formula)

‎R/initialize.R‎

Lines changed: 60 additions & 139 deletions
Original file line numberDiff line numberDiff line change
@@ -85,142 +85,63 @@ ergm_prep <- function(nw,
8585
}
8686

8787

88-
# used for testing, not needed for simulation
89-
90-
# ergm_getmodel <- function(formula,
91-
# nw,
92-
# response = NULL,
93-
# silent = FALSE,
94-
# role = "static",
95-
# ...) {
96-
#
97-
# if ((dc <- data.class(formula)) != "formula") {
98-
# stop(paste("Invalid formula of class ", dc), call. = FALSE)
99-
# }
100-
#
101-
# if (formula[[1]] != "~") {
102-
# stop("Formula must be of the form 'network ~ model'.", call. = FALSE)
103-
# }
104-
#
105-
# if (length(formula) < 3) {
106-
# stop(paste("No model specified for network ", formula[[2]]), call. = FALSE)
107-
# }
108-
#
109-
# v <- term.list.formula(formula[[3]])
110-
# formula.env <- environment(formula)
111-
# model <- structure(list(formula = formula,
112-
# coef.names = NULL,
113-
# offset = NULL,
114-
# terms = NULL,
115-
# networkstats.0 = NULL,
116-
# etamap = NULL),
117-
# class = "model.ergm")
118-
#
119-
# termroot <- if (is.null(response)) {
120-
# "InitErgm"
121-
# } else {
122-
# "InitWtErgm"
123-
# }
124-
#
125-
# for (i in 1:length(v)) {
126-
# if (is.call(v[[i]])) {
127-
# if (v[[i]][[1]] == "offset") {
128-
# if (length(v[[i]][[2]]) <= 1) {
129-
# v[[i]] <- as.call(v[[i]][2])
130-
# } else {
131-
# v[[i]] <- as.call(v[[i]][[2]])
132-
# }
133-
# model$offset <- c(model$offset, TRUE)
134-
# } else {
135-
# model$offset <- c(model$offset, FALSE)
136-
# }
137-
# args = v[[i]]
138-
# args[[1]] = as.name("list")
139-
# fname <- paste(termroot, "Term.", v[[i]][[1]], sep = "")
140-
# newInitErgm <- exists(fname, envir = formula.env,
141-
# mode = "function")
142-
# v[[i]] <- call(ifelse(newInitErgm, fname, paste(termroot,
143-
# ".", v[[i]][[1]], sep = "")))
144-
# } else {
145-
# fname <- paste(termroot, "Term.", v[[i]], sep = "")
146-
# newInitErgm <- exists(fname, envir = formula.env,
147-
# mode = "function")
148-
# v[[i]] <- call(ifelse(newInitErgm, fname, paste(termroot,
149-
# ".", v[[i]], sep = "")))
150-
# model$offset <- c(model$offset, FALSE)
151-
# args = list()
152-
# }
153-
#
154-
# if (!newInitErgm) {
155-
# v[[i]][[2]] <- nw
156-
# names(v[[i]])[2] <- ""
157-
# v[[i]][[3]] <- model
158-
# names(v[[i]])[3] <- ""
159-
# v[[i]][[4]] <- args
160-
# dotdotdot <- c(if (!is.null(response)) list(response = response),
161-
# list(role = role), list(...))
162-
# for (j in seq_along(dotdotdot)) {
163-
# if (is.null(dotdotdot[[j]]))
164-
# next
165-
# v[[i]][[4 + j]] <- dotdotdot[[j]]
166-
# names(v[[i]])[4 + j] <- names(dotdotdot)[j]
167-
# }
168-
# if (!exists(as.character(v[[i]][[1]]), envir = formula.env, mode = "function")) {
169-
# stop("The term ", substring(as.character(v[[i]][[1]]),
170-
# first = nchar(termroot) + 2),
171-
# " does not exist for this type of ERGM. Are you sure you have the right name?\n",
172-
# call. = FALSE)
173-
# }
174-
# if (silent) {
175-
# silentwarnings <- capture.output(model <- eval(v[[i]], formula.env))
176-
# } else {
177-
# model <- eval(v[[i]], formula.env)
178-
# }
179-
# if (is.null(model$terms[[length(model$terms)]]$pkgname)) {
180-
# model$terms[[length(model$terms)]]$pkgname <-
181-
# ergm:::which.package.InitFunction(v[[i]][[1]], formula.env)
182-
# }
183-
# } else {
184-
# v[[i]][[2]] <- nw
185-
# names(v[[i]])[2] <- ""
186-
# v[[i]][[3]] <- args
187-
# names(v[[i]])[3] <- ""
188-
# dotdotdot <- c(if (!is.null(response)) list(response = response), list(role = role), list(...))
189-
# for (j in seq_along(dotdotdot)) {
190-
# if (is.null(dotdotdot[[j]]))
191-
# next
192-
# v[[i]][[3 + j]] <- dotdotdot[[j]]
193-
# names(v[[i]])[3 + j] <- names(dotdotdot)[j]
194-
# }
195-
# outlist <- eval(v[[i]], formula.env)
196-
# if (is.null(outlist$pkgname)) {
197-
# outlist$pkgname <- ergm:::which.package.InitFunction(v[[i]][[1]], formula.env)
198-
# }
199-
# model <- updatemodel_ErgmTerm(model, outlist)
200-
# }
201-
# }
202-
#
203-
# model$etamap <- ergm.etamap(model)
204-
# ergm:::ergm.MCMC.packagenames(unlist(sapply(model$terms, "[[", "pkgname")))
205-
#
206-
# class(model) <- "ergm.model"
207-
# return(model)
208-
# }
209-
210-
# updatemodel_ErgmTerm <- function(model, outlist) {
211-
# if (!is.null(outlist)) {
212-
# model$coef.names <- c(model$coef.names, outlist$coef.names)
213-
# termnumber <- 1 + length(model$terms)
214-
# tmp <- attr(outlist$inputs, "ParamsBeforeCov")
215-
# outlist$inputs <- c(ifelse(is.null(tmp), 0, tmp), length(outlist$coef.names),
216-
# length(outlist$inputs), outlist$inputs)
217-
# model$minval <- c(model$minval, rep(if (!is.null(outlist$minval)) outlist$minval else -Inf,
218-
# length.out = length(outlist$coef.names)))
219-
# model$maxval <- c(model$maxval, rep(if (!is.null(outlist$maxval)) outlist$maxval else +Inf,
220-
# length.out = length(outlist$coef.names)))
221-
# model$duration <- c(model$duration, if (!is.null(outlist$duration)) outlist$duration else FALSE)
222-
# model$terms[[termnumber]] <- outlist
223-
# }
224-
#
225-
# return(model)
226-
# }
88+
#' @title Initializes EpiModel netsim Object for tergmLite Simulation
89+
#'
90+
#' @param dat A list object containing a \code{networkDynamic} object and other
91+
#' initialization information passed from \code{netsim}.
92+
#'
93+
#' @export
94+
#'
95+
#' @examples
96+
#' library("EpiModel")
97+
#' nw <- network.initialize(n = 100, directed = FALSE)
98+
#' formation <- ~edges
99+
#' target.stats <- 50
100+
#' coef.diss <- dissolution_coefs(dissolution = ~offset(edges), duration = 20)
101+
#' x <- netest(nw, formation, target.stats, coef.diss, verbose = FALSE)
102+
#'
103+
#' param <- param.net(inf.prob = 0.3)
104+
#' init <- init.net(i.num = 10)
105+
#' control <- control.net(type = "SI", nsteps = 100, nsims = 5, depend = TRUE)
106+
#'
107+
#' dat <- initialize.net(x, param, init, control)
108+
#'
109+
#' dat <- init_tergmLite(dat)
110+
#'
111+
init_tergmLite <- function(dat) {
112+
113+
num_nw <- ifelse(any(class(dat$nw) == "network"), 1, length(dat$nw))
114+
115+
dat$el <- list()
116+
dat$p <- list()
117+
118+
for (i in 1:num_nw) {
119+
120+
nwp <- dat$nwparam[[i]]
121+
is_tergm <- nwp$coef.diss$duration > 1
122+
if (num_nw == 1) {
123+
nw <- dat$nw
124+
} else {
125+
nw <- dat$nw[[i]]
126+
}
127+
128+
dat$el[[i]] <- as.edgelist(nw)
129+
attributes(dat$el[[i]])$vnames <- NULL
130+
131+
if (is_tergm) {
132+
p <- stergm_prep(nw, nwp$formation, nwp$coef.diss$dissolution,
133+
nwp$coef.form, nwp$coef.diss$coef.adj, nwp$constraints)
134+
p$model.form$formula <- NULL
135+
p$model.diss$formula <- NULL
136+
} else {
137+
p <- tergmLite::ergm_prep(nw, nwp$formation, nwp$coef.form, nwp$constraints)
138+
p$model.form$formula <- NULL
139+
}
140+
dat$p[[i]] <- p
141+
142+
}
143+
144+
dat$nw <- NULL
145+
146+
return(dat)
147+
}

‎R/tergmLite-package.r‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,7 @@
4949
#' @importFrom Rcpp sourceCpp
5050
#' @importFrom stats formula
5151
#' @importFrom statnet.common term.list.formula NVL
52+
#' @importFrom network as.edgelist
5253
#'
5354
#' @docType package
5455
#' @keywords package

‎inst/ergm_getmodel.R‎

Lines changed: 140 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,140 @@
1+
2+
# used for testing
3+
4+
ergm_getmodel <- function(formula,
5+
nw,
6+
response = NULL,
7+
silent = FALSE,
8+
role = "static",
9+
...) {
10+
11+
if ((dc <- data.class(formula)) != "formula") {
12+
stop(paste("Invalid formula of class ", dc), call. = FALSE)
13+
}
14+
15+
if (formula[[1]] != "~") {
16+
stop("Formula must be of the form 'network ~ model'.", call. = FALSE)
17+
}
18+
19+
if (length(formula) < 3) {
20+
stop(paste("No model specified for network ", formula[[2]]), call. = FALSE)
21+
}
22+
23+
v <- term.list.formula(formula[[3]])
24+
formula.env <- environment(formula)
25+
model <- structure(list(formula = formula,
26+
coef.names = NULL,
27+
offset = NULL,
28+
terms = NULL,
29+
networkstats.0 = NULL,
30+
etamap = NULL),
31+
class = "model.ergm")
32+
33+
termroot <- if (is.null(response)) {
34+
"InitErgm"
35+
} else {
36+
"InitWtErgm"
37+
}
38+
39+
for (i in 1:length(v)) {
40+
if (is.call(v[[i]])) {
41+
if (v[[i]][[1]] == "offset") {
42+
if (length(v[[i]][[2]]) <= 1) {
43+
v[[i]] <- as.call(v[[i]][2])
44+
} else {
45+
v[[i]] <- as.call(v[[i]][[2]])
46+
}
47+
model$offset <- c(model$offset, TRUE)
48+
} else {
49+
model$offset <- c(model$offset, FALSE)
50+
}
51+
args = v[[i]]
52+
args[[1]] = as.name("list")
53+
fname <- paste(termroot, "Term.", v[[i]][[1]], sep = "")
54+
newInitErgm <- exists(fname, envir = formula.env,
55+
mode = "function")
56+
v[[i]] <- call(ifelse(newInitErgm, fname, paste(termroot,
57+
".", v[[i]][[1]], sep = "")))
58+
} else {
59+
fname <- paste(termroot, "Term.", v[[i]], sep = "")
60+
newInitErgm <- exists(fname, envir = formula.env,
61+
mode = "function")
62+
v[[i]] <- call(ifelse(newInitErgm, fname, paste(termroot,
63+
".", v[[i]], sep = "")))
64+
model$offset <- c(model$offset, FALSE)
65+
args = list()
66+
}
67+
68+
if (!newInitErgm) {
69+
v[[i]][[2]] <- nw
70+
names(v[[i]])[2] <- ""
71+
v[[i]][[3]] <- model
72+
names(v[[i]])[3] <- ""
73+
v[[i]][[4]] <- args
74+
dotdotdot <- c(if (!is.null(response)) list(response = response),
75+
list(role = role), list(...))
76+
for (j in seq_along(dotdotdot)) {
77+
if (is.null(dotdotdot[[j]]))
78+
next
79+
v[[i]][[4 + j]] <- dotdotdot[[j]]
80+
names(v[[i]])[4 + j] <- names(dotdotdot)[j]
81+
}
82+
if (!exists(as.character(v[[i]][[1]]), envir = formula.env, mode = "function")) {
83+
stop("The term ", substring(as.character(v[[i]][[1]]),
84+
first = nchar(termroot) + 2),
85+
" does not exist for this type of ERGM. Are you sure you have the right name?\n",
86+
call. = FALSE)
87+
}
88+
if (silent) {
89+
silentwarnings <- capture.output(model <- eval(v[[i]], formula.env))
90+
} else {
91+
model <- eval(v[[i]], formula.env)
92+
}
93+
if (is.null(model$terms[[length(model$terms)]]$pkgname)) {
94+
model$terms[[length(model$terms)]]$pkgname <-
95+
ergm:::which.package.InitFunction(v[[i]][[1]], formula.env)
96+
}
97+
} else {
98+
v[[i]][[2]] <- nw
99+
names(v[[i]])[2] <- ""
100+
v[[i]][[3]] <- args
101+
names(v[[i]])[3] <- ""
102+
dotdotdot <- c(if (!is.null(response)) list(response = response), list(role = role), list(...))
103+
for (j in seq_along(dotdotdot)) {
104+
if (is.null(dotdotdot[[j]]))
105+
next
106+
v[[i]][[3 + j]] <- dotdotdot[[j]]
107+
names(v[[i]])[3 + j] <- names(dotdotdot)[j]
108+
}
109+
outlist <- eval(v[[i]], formula.env)
110+
if (is.null(outlist$pkgname)) {
111+
outlist$pkgname <- ergm:::which.package.InitFunction(v[[i]][[1]], formula.env)
112+
}
113+
model <- updatemodel_ErgmTerm(model, outlist)
114+
}
115+
}
116+
117+
model$etamap <- ergm.etamap(model)
118+
ergm:::ergm.MCMC.packagenames(unlist(sapply(model$terms, "[[", "pkgname")))
119+
120+
class(model) <- "ergm.model"
121+
return(model)
122+
}
123+
124+
updatemodel_ErgmTerm <- function(model, outlist) {
125+
if (!is.null(outlist)) {
126+
model$coef.names <- c(model$coef.names, outlist$coef.names)
127+
termnumber <- 1 + length(model$terms)
128+
tmp <- attr(outlist$inputs, "ParamsBeforeCov")
129+
outlist$inputs <- c(ifelse(is.null(tmp), 0, tmp), length(outlist$coef.names),
130+
length(outlist$inputs), outlist$inputs)
131+
model$minval <- c(model$minval, rep(if (!is.null(outlist$minval)) outlist$minval else -Inf,
132+
length.out = length(outlist$coef.names)))
133+
model$maxval <- c(model$maxval, rep(if (!is.null(outlist$maxval)) outlist$maxval else +Inf,
134+
length.out = length(outlist$coef.names)))
135+
model$duration <- c(model$duration, if (!is.null(outlist$duration)) outlist$duration else FALSE)
136+
model$terms[[termnumber]] <- outlist
137+
}
138+
139+
return(model)
140+
}

‎man/ergm_prep.Rd‎

Lines changed: 1 addition & 1 deletion
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

0 commit comments

Comments
 (0)