Last updated on 2020-03-07 11:48:09 CET.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 1.9.4 | 20.42 | 172.07 | 192.49 | ERROR | |
| r-devel-linux-x86_64-debian-gcc | 1.9.4 | 16.41 | 131.43 | 147.84 | ERROR | |
| r-devel-linux-x86_64-fedora-clang | 1.9.4 | 231.87 | ERROR | |||
| r-devel-linux-x86_64-fedora-gcc | 1.9.4 | 235.25 | ERROR | |||
| r-devel-windows-ix86+x86_64 | 1.9.4 | 45.00 | 154.00 | 199.00 | OK | |
| r-devel-windows-ix86+x86_64-gcc8 | 1.9.4 | 35.00 | 171.00 | 206.00 | OK | |
| r-patched-linux-x86_64 | 1.9.4 | 19.32 | 150.72 | 170.04 | OK | |
| r-patched-solaris-x86 | 1.9.4 | 350.00 | OK | |||
| r-release-linux-x86_64 | 1.9.4 | 17.86 | 150.10 | 167.96 | OK | |
| r-release-windows-ix86+x86_64 | 1.9.4 | 31.00 | 158.00 | 189.00 | OK | |
| r-release-osx-x86_64 | 1.9.4 | OK | ||||
| r-oldrel-windows-ix86+x86_64 | 1.9.4 | 17.00 | 149.00 | 166.00 | OK | |
| r-oldrel-osx-x86_64 | 1.9.4 | WARN |
Version: 1.9.4
Check: examples
Result: ERROR
Running examples in 'btergm-Ex.R' failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: btergm
> ### Title: TERGM by bootstrapped pseudolikelihood or MCMC MLE
> ### Aliases: btergm mtergm tergm
>
> ### ** Examples
>
> # A simple toy example:
>
> library("network")
> set.seed(5)
>
> networks <- list()
> for(i in 1:10) { # create 10 random networks with 10 actors
+ mat <- matrix(rbinom(100, 1, .25), nrow = 10, ncol = 10)
+ diag(mat) <- 0 # loops are excluded
+ nw <- network(mat) # create network object
+ networks[[i]] <- nw # add network to the list
+ }
>
> covariates <- list()
> for (i in 1:10) { # create 10 matrices as covariate
+ mat <- matrix(rnorm(100), nrow = 10, ncol = 10)
+ covariates[[i]] <- mat # add matrix to the list
+ }
>
> fit <- btergm(networks ~ edges + istar(2) +
+ edgecov(covariates), R = 100)
Initial dimensions of the network and covariates:
t=1 t=2 t=3 t=4 t=5 t=6 t=7 t=8 t=9 t=10
networks (row) 10 10 10 10 10 10 10 10 10 10
networks (col) 10 10 10 10 10 10 10 10 10 10
covariates (row) 10 10 10 10 10 10 10 10 10 10
covariates (col) 10 10 10 10 10 10 10 10 10 10
All networks are conformable.
Dimensions of the network and covariates after adjustment:
t=1 t=2 t=3 t=4 t=5 t=6 t=7 t=8 t=9 t=10
networks (row) 10 10 10 10 10 10 10 10 10 10
networks (col) 10 10 10 10 10 10 10 10 10 10
covariates (row) 10 10 10 10 10 10 10 10 10 10
covariates (col) 10 10 10 10 10 10 10 10 10 10
Starting pseudolikelihood estimation with 100 bootstrapping replications on a single computing core...
Done.
>
> summary(fit) # show estimation results
==========================
Summary of model fit
==========================
Formula: networks ~ edges + istar(2) + edgecov(covariates)
Time steps: 10
Bootstrapping sample size: 100
Estimates and 95% confidence intervals:
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
.local(object, parm, level, ...)
--- call from argument ---
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
--- R stacktrace ---
where 1: .local(object, parm, level, ...)
where 2: confint(object, level = level, type = type, invlogit = invlogit,
...)
where 3: confint(object, level = level, type = type, invlogit = invlogit,
...)
where 4: .local(object, ...)
where 5: summary(fit)
where 6: summary(fit)
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (object, parm, level = 0.95, type = "perc", invlogit = FALSE,
...)
{
cf <- coef(object, invlogit = invlogit)
pnames <- names(cf)
if (missing(parm)) {
parm <- pnames
}
else if (is.numeric(parm)) {
parm <- pnames[parm]
}
n.orig <- nrow(object@boot$t)
object@boot$t <- object@boot$t[complete.cases(object@boot$t),
]
n.ret <- nrow(object@boot$t)
perc <- 100 * (n.orig - n.ret)/n.orig
if (n.orig != n.ret) {
warning(paste0("Too little variation in the model. ",
n.orig - n.ret, " replications (", perc, "%) are dropped from CI estimation."))
}
if (invlogit == TRUE) {
object@boot$t <- apply(object@boot$t, 1:2, function(x) 1/(1 +
exp(-x)))
object@boot$t0 <- sapply(object@boot$t0, function(x) 1/(1 +
exp(-x)))
}
if (type == "perc") {
type2 <- "percent"
}
else if (type == "norm") {
type2 <- "normal"
}
else if (type == "basic") {
type2 <- "basic"
}
else if (type == "stud") {
type2 <- "student"
}
else if (type == "bca") {
type2 <- "bca"
}
else {
stop(paste("'type' not supported. Use 'perc', 'bca', 'norm', 'basic',",
"or 'stud'."))
}
ci <- sapply(1:length(cf), function(x) {
b <- boot::boot.ci(object@boot, conf = level, type = type,
index = x)
b[[type2]][4:5]
})
ci <- cbind(cf, t(ci))
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
ci <- ci[parm, ]
if (class(ci) != "matrix") {
ci <- matrix(ci, ncol = 3)
rownames(ci) <- parm
}
label1 <- paste0(100 * (1 - level)/2, "%")
label2 <- paste0(100 * (1 - (1 - level)/2), "%")
colnames(ci) <- c("Estimate", label1, label2)
return(ci)
}
<environment: namespace:btergm>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
Error in if (class(ci) == "numeric") { : the condition has length > 1
Calls: summary -> summary -> .local -> confint -> confint -> .local
Execution halted
Flavors: r-devel-linux-x86_64-debian-clang, r-devel-linux-x86_64-debian-gcc
Version: 1.9.4
Check: tests
Result: ERROR
Running 'testthat.R' [43s/48s]
Running the tests in 'tests/testthat.R' failed.
Complete output:
> library(testthat)
> library(btergm)
Loading required package: xergm.common
Loading required package: ergm
Loading required package: network
network: Classes for Relational Data
Version 1.16.0 created on 2019-11-30.
copyright (c) 2005, Carter T. Butts, University of California-Irvine
Mark S. Handcock, University of California -- Los Angeles
David R. Hunter, Penn State University
Martina Morris, University of Washington
Skye Bender-deMoll, University of Washington
For citation information, type citation("network").
Type help("network-package") to get started.
ergm: version 3.10.4, created on 2019-06-10
Copyright (c) 2019, Mark S. Handcock, University of California -- Los Angeles
David R. Hunter, Penn State University
Carter T. Butts, University of California -- Irvine
Steven M. Goodreau, University of Washington
Pavel N. Krivitsky, University of Wollongong
Martina Morris, University of Washington
with contributions from
Li Wang
Kirk Li, University of Washington
Skye Bender-deMoll, University of Washington
Chad Klumb
Based on "statnet" project software (statnet.org).
For license and citation information see statnet.org/attribution
or type citation("ergm").
NOTE: Versions before 3.6.1 had a bug in the implementation of the bd()
constriant which distorted the sampled distribution somewhat. In
addition, Sampson's Monks datasets had mislabeled vertices. See the
NEWS and the documentation for more details.
NOTE: Some common term arguments pertaining to vertex attribute and
level selection have changed in 3.10.0. See terms help for more
details. Use 'options(ergm.term=list(version="3.9.4"))' to use old
behavior.
Attaching package: 'xergm.common'
The following object is masked from 'package:ergm':
gof
Loading required package: ggplot2
Registered S3 methods overwritten by 'btergm':
method from
print.gof ergm
plot.gof ergm
Package: btergm
Version: 1.9.4
Date: 2019-05-12
Authors: Philip Leifeld (University of Essex)
Skyler J. Cranmer (The Ohio State University)
Bruce A. Desmarais (Pennsylvania State University)
>
> test_check("btergm")
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
.local(object, parm, level, ...)
--- call from argument ---
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
--- R stacktrace ---
where 1: .local(object, parm, level, ...)
where 2: confint(fit)
where 3: confint(fit)
where 4: eval_bare(expr, quo_get_env(quo))
where 5: quasi_label(enquo(object), label, arg = "object")
where 6 at testthat/test-btergm.R#48: expect_equal(round(confint(fit)[1, 2], 1), -1.4)
where 7: eval(code, test_env)
where 8: eval(code, test_env)
where 9: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 10: doTryCatch(return(expr), name, parentenv, handler)
where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 13: doTryCatch(return(expr), name, parentenv, handler)
where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 15: tryCatchList(expr, classes, parentenv, handlers)
where 16: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 17: test_code(desc, code, env = parent.frame())
where 18 at testthat/test-btergm.R#21: test_that("btergm estimation works", {
set.seed(12345)
fit <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, verbose = FALSE)
expect_equal(round(unname(coef(fit)), 4), c(-1.1707, 0.0543,
0.0045))
expect_equal(names(coef(fit)), c("edges", "istar2", "edgecov.covariates[[i]]"))
expect_equal(class(fit@boot), "boot")
expect_equal(fit@boot$R, 100)
expect_equal(fit@R, 100)
expect_equal(fit@nobs, 900)
expect_equal(fit@time.steps, 10)
expect_equal(class(fit@formula), "formula")
expect_equal(class(fit@formula2), "character")
expect_equal(fit@formula, as.formula("networks ~ edges + istar(2) + edgecov(covariates)"))
expect_equal(fit@formula2, "networks[[i]] ~ edges + istar(2) + edgecov(covariates[[i]])")
expect_equal(length(fit@response), 900)
expect_equal(is.numeric(fit@response), TRUE)
expect_equal(class(fit@effects), "data.frame")
expect_equal(dim(fit@effects), c(900, 3))
expect_equal(unique(fit@effects$edges), 1)
expect_equal(median(fit@effects$istar2), 2)
expect_equal(round(mean(fit@effects$`edgecov.covariates[[i]]`),
4), -0.0144)
expect_equal(unique(fit@weights), 1)
expect_equal(fit@auto.adjust, FALSE)
expect_equal(fit@offset, FALSE)
expect_equal(fit@directed, TRUE)
expect_equal(fit@bipartite, FALSE)
expect_equal(unname(rowSums(fit@nvertices)), c(100, 100))
expect_equal(round(confint(fit)[1, 2], 1), -1.4)
expect_equal(round(confint(fit)[1, 3], 1), -0.8)
expect_equal(round(confint(fit)[2, 2], 0), 0)
expect_equal(round(confint(fit)[2, 3], 1), 0.1)
expect_equal(round(confint(fit)[3, 2], 1), -0.1)
expect_equal(round(confint(fit)[3, 3], 1), 0.1)
})
where 19: eval(code, test_env)
where 20: eval(code, test_env)
where 21: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 27: tryCatchList(expr, classes, parentenv, handlers)
where 28: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 29: test_code(NULL, exprs, env)
where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 31: force(code)
where 32: doWithOneRestart(return(expr), restart)
where 33: withOneRestart(expr, restarts[[1L]])
where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 36: FUN(X[[i]], ...)
where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 38: force(code)
where 39: doWithOneRestart(return(expr), restart)
where 40: withOneRestart(expr, restarts[[1L]])
where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (object, parm, level = 0.95, type = "perc", invlogit = FALSE,
...)
{
cf <- coef(object, invlogit = invlogit)
pnames <- names(cf)
if (missing(parm)) {
parm <- pnames
}
else if (is.numeric(parm)) {
parm <- pnames[parm]
}
n.orig <- nrow(object@boot$t)
object@boot$t <- object@boot$t[complete.cases(object@boot$t),
]
n.ret <- nrow(object@boot$t)
perc <- 100 * (n.orig - n.ret)/n.orig
if (n.orig != n.ret) {
warning(paste0("Too little variation in the model. ",
n.orig - n.ret, " replications (", perc, "%) are dropped from CI estimation."))
}
if (invlogit == TRUE) {
object@boot$t <- apply(object@boot$t, 1:2, function(x) 1/(1 +
exp(-x)))
object@boot$t0 <- sapply(object@boot$t0, function(x) 1/(1 +
exp(-x)))
}
if (type == "perc") {
type2 <- "percent"
}
else if (type == "norm") {
type2 <- "normal"
}
else if (type == "basic") {
type2 <- "basic"
}
else if (type == "stud") {
type2 <- "student"
}
else if (type == "bca") {
type2 <- "bca"
}
else {
stop(paste("'type' not supported. Use 'perc', 'bca', 'norm', 'basic',",
"or 'stud'."))
}
ci <- sapply(1:length(cf), function(x) {
b <- boot::boot.ci(object@boot, conf = level, type = type,
index = x)
b[[type2]][4:5]
})
ci <- cbind(cf, t(ci))
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
ci <- ci[parm, ]
if (class(ci) != "matrix") {
ci <- matrix(ci, ncol = 3)
rownames(ci) <- parm
}
label1 <- paste0(100 * (1 - level)/2, "%")
label2 <- paste0(100 * (1 - (1 - level)/2), "%")
colnames(ci) <- c("Estimate", label1, label2)
return(ci)
}
<environment: namespace:btergm>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
-- 1. Error: btergm estimation works (@test-btergm.R#48) ----------------------
the condition has length > 1
Backtrace:
1. testthat::expect_equal(round(confint(fit)[1, 2], 1), -1.4)
5. btergm::confint(fit)
6. btergm:::.local(object, parm, level, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
.local(object, parm, level, ...)
--- call from argument ---
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
--- R stacktrace ---
where 1: .local(object, parm, level, ...)
where 2: confint(fit)
where 3: confint(fit)
where 4: eval_bare(expr, quo_get_env(quo))
where 5: quasi_label(enquo(object), label, arg = "object")
where 6 at testthat/test-btergm.R#61: expect_equal(all(round(confint(fit), 4) == round(confint(fit2),
4)), TRUE)
where 7: eval(code, test_env)
where 8: eval(code, test_env)
where 9: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 10: doTryCatch(return(expr), name, parentenv, handler)
where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 13: doTryCatch(return(expr), name, parentenv, handler)
where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 15: tryCatchList(expr, classes, parentenv, handlers)
where 16: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 17: test_code(desc, code, env = parent.frame())
where 18 at testthat/test-btergm.R#56: test_that("fastglm works like speedglm", {
set.seed(12345)
fit <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, verbose = FALSE)
set.seed(12345)
fit2 <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, usefastglm = TRUE, verbose = FALSE)
expect_equal(all(round(confint(fit), 4) == round(confint(fit2),
4)), TRUE)
})
where 19: eval(code, test_env)
where 20: eval(code, test_env)
where 21: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 27: tryCatchList(expr, classes, parentenv, handlers)
where 28: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 29: test_code(NULL, exprs, env)
where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 31: force(code)
where 32: doWithOneRestart(return(expr), restart)
where 33: withOneRestart(expr, restarts[[1L]])
where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 36: FUN(X[[i]], ...)
where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 38: force(code)
where 39: doWithOneRestart(return(expr), restart)
where 40: withOneRestart(expr, restarts[[1L]])
where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (object, parm, level = 0.95, type = "perc", invlogit = FALSE,
...)
{
cf <- coef(object, invlogit = invlogit)
pnames <- names(cf)
if (missing(parm)) {
parm <- pnames
}
else if (is.numeric(parm)) {
parm <- pnames[parm]
}
n.orig <- nrow(object@boot$t)
object@boot$t <- object@boot$t[complete.cases(object@boot$t),
]
n.ret <- nrow(object@boot$t)
perc <- 100 * (n.orig - n.ret)/n.orig
if (n.orig != n.ret) {
warning(paste0("Too little variation in the model. ",
n.orig - n.ret, " replications (", perc, "%) are dropped from CI estimation."))
}
if (invlogit == TRUE) {
object@boot$t <- apply(object@boot$t, 1:2, function(x) 1/(1 +
exp(-x)))
object@boot$t0 <- sapply(object@boot$t0, function(x) 1/(1 +
exp(-x)))
}
if (type == "perc") {
type2 <- "percent"
}
else if (type == "norm") {
type2 <- "normal"
}
else if (type == "basic") {
type2 <- "basic"
}
else if (type == "stud") {
type2 <- "student"
}
else if (type == "bca") {
type2 <- "bca"
}
else {
stop(paste("'type' not supported. Use 'perc', 'bca', 'norm', 'basic',",
"or 'stud'."))
}
ci <- sapply(1:length(cf), function(x) {
b <- boot::boot.ci(object@boot, conf = level, type = type,
index = x)
b[[type2]][4:5]
})
ci <- cbind(cf, t(ci))
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
ci <- ci[parm, ]
if (class(ci) != "matrix") {
ci <- matrix(ci, ncol = 3)
rownames(ci) <- parm
}
label1 <- paste0(100 * (1 - level)/2, "%")
label2 <- paste0(100 * (1 - (1 - level)/2), "%")
colnames(ci) <- c("Estimate", label1, label2)
return(ci)
}
<bytecode: 0x13f51ec0>
<environment: namespace:btergm>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
-- 2. Error: fastglm works like speedglm (@test-btergm.R#61) ------------------
the condition has length > 1
Backtrace:
1. testthat::expect_equal(...)
5. btergm::confint(fit)
6. btergm:::.local(object, parm, level, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
.local(object, parm, level, ...)
--- call from argument ---
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
--- R stacktrace ---
where 1: .local(object, parm, level, ...)
where 2: confint(fit1)
where 3: confint(fit1)
where 4: eval_bare(expr, quo_get_env(quo))
where 5: quasi_label(enquo(object), label, arg = "object")
where 6 at testthat/test-btergm.R#77: expect_equal(confint(fit1), confint(fit2))
where 7: eval(code, test_env)
where 8: eval(code, test_env)
where 9: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 10: doTryCatch(return(expr), name, parentenv, handler)
where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 13: doTryCatch(return(expr), name, parentenv, handler)
where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 15: tryCatchList(expr, classes, parentenv, handlers)
where 16: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 17: test_code(desc, code, env = parent.frame())
where 18 at testthat/test-btergm.R#64: test_that("offset argument in btergm works without composition change",
{
set.seed(12345)
fit1 <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, offset = FALSE, usefastglm = TRUE, verbose = FALSE)
set.seed(12345)
fit2 <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, offset = TRUE, usefastglm = TRUE, verbose = FALSE)
expect_equal(confint(fit1), confint(fit2))
})
where 19: eval(code, test_env)
where 20: eval(code, test_env)
where 21: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 27: tryCatchList(expr, classes, parentenv, handlers)
where 28: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 29: test_code(NULL, exprs, env)
where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 31: force(code)
where 32: doWithOneRestart(return(expr), restart)
where 33: withOneRestart(expr, restarts[[1L]])
where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 36: FUN(X[[i]], ...)
where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 38: force(code)
where 39: doWithOneRestart(return(expr), restart)
where 40: withOneRestart(expr, restarts[[1L]])
where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (object, parm, level = 0.95, type = "perc", invlogit = FALSE,
...)
{
cf <- coef(object, invlogit = invlogit)
pnames <- names(cf)
if (missing(parm)) {
parm <- pnames
}
else if (is.numeric(parm)) {
parm <- pnames[parm]
}
n.orig <- nrow(object@boot$t)
object@boot$t <- object@boot$t[complete.cases(object@boot$t),
]
n.ret <- nrow(object@boot$t)
perc <- 100 * (n.orig - n.ret)/n.orig
if (n.orig != n.ret) {
warning(paste0("Too little variation in the model. ",
n.orig - n.ret, " replications (", perc, "%) are dropped from CI estimation."))
}
if (invlogit == TRUE) {
object@boot$t <- apply(object@boot$t, 1:2, function(x) 1/(1 +
exp(-x)))
object@boot$t0 <- sapply(object@boot$t0, function(x) 1/(1 +
exp(-x)))
}
if (type == "perc") {
type2 <- "percent"
}
else if (type == "norm") {
type2 <- "normal"
}
else if (type == "basic") {
type2 <- "basic"
}
else if (type == "stud") {
type2 <- "student"
}
else if (type == "bca") {
type2 <- "bca"
}
else {
stop(paste("'type' not supported. Use 'perc', 'bca', 'norm', 'basic',",
"or 'stud'."))
}
ci <- sapply(1:length(cf), function(x) {
b <- boot::boot.ci(object@boot, conf = level, type = type,
index = x)
b[[type2]][4:5]
})
ci <- cbind(cf, t(ci))
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
ci <- ci[parm, ]
if (class(ci) != "matrix") {
ci <- matrix(ci, ncol = 3)
rownames(ci) <- parm
}
label1 <- paste0(100 * (1 - level)/2, "%")
label2 <- paste0(100 * (1 - (1 - level)/2), "%")
colnames(ci) <- c("Estimate", label1, label2)
return(ci)
}
<bytecode: 0x13f51ec0>
<environment: namespace:btergm>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
-- 3. Error: offset argument in btergm works without composition change (@test-b
the condition has length > 1
Backtrace:
1. testthat::expect_equal(confint(fit1), confint(fit2))
5. btergm::confint(fit1)
6. btergm:::.local(object, parm, level, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
NULL
--- call from argument ---
if (type %in% c("matrix", "network", "dgCMatrix", "dgTMatrix",
"dsCMatrix", "dsTMatrix", "dgeMatrix")) {
if (!type %in% c("matrix", "network")) {
x.current <- as.matrix(x.current)
}
l[[x2]] <- list()
for (i in 1:l$time.steps) {
l[[x2]][[i]] <- x.current
}
if (blockdiag == TRUE) {
}
else {
x2 <- paste0(x2, "[[i]]")
}
l$rhs.terms[k] <- paste(x1, x2, x3, sep = "")
} else if (type == "list" || type == "network.list") {
if (length(x.current) != l$time.steps) {
stop(paste(x2, "has", length(get(x2)), "elements, but there are",
l$time.steps, "networks to be modeled."))
}
if (blockdiag == TRUE) {
}
else {
x2 <- paste0(x2, "[[i]]")
}
l$rhs.terms[k] <- paste0(x1, x2, x3)
} else {
tryCatch({
l[[x2]] <- list(rep(as.matrix(x.current)), l$time.steps)
}, error = function(cond) {
stop(paste0("Object '", x2, "' could not be converted to a matrix."))
})
}
--- R stacktrace ---
where 1: tergmprepare(formula = formula, offset = offset, verbose = verbose)
where 2 at testthat/test-btergm.R#115: btergm(friendship ~ edges + mutual + ttriple + transitiveties +
ctriple + nodeicov("idegsqrt") + nodeicov("odegsqrt") + nodeocov("odegsqrt") +
nodeofactor("sex") + nodeifactor("sex") + nodematch("sex") +
edgecov(primary) + delrecip + memory(type = "stability"),
R = 100, usefastglm = TRUE, offset = TRUE, verbose = FALSE)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-btergm.R#80: test_that("offset argument in btergm works with composition change",
{
require("sna")
data("knecht")
for (i in 1:length(friendship)) {
rownames(friendship[[i]]) <- 1:nrow(friendship[[i]])
colnames(friendship[[i]]) <- 1:ncol(friendship[[i]])
}
rownames(primary) <- rownames(friendship[[1]])
colnames(primary) <- colnames(friendship[[1]])
sex <- demographics$sex
names(sex) <- 1:length(sex)
suppressMessages(friendship <- handleMissings(friendship,
na = 10, method = "remove"))
suppressMessages(friendship <- handleMissings(friendship,
na = NA, method = "fillmode"))
for (i in 1:length(friendship)) {
s <- adjust(sex, friendship[[i]])
friendship[[i]] <- network(friendship[[i]])
friendship[[i]] <- set.vertex.attribute(friendship[[i]],
"sex", s)
idegsqrt <- sqrt(degree(friendship[[i]], cmode = "indegree"))
friendship[[i]] <- set.vertex.attribute(friendship[[i]],
"idegsqrt", idegsqrt)
odegsqrt <- sqrt(degree(friendship[[i]], cmode = "outdegree"))
friendship[[i]] <- set.vertex.attribute(friendship[[i]],
"odegsqrt", odegsqrt)
}
expect_equal(unname(sapply(friendship, network.size)),
c(26, 26, 25, 25))
set.seed(12345)
m1 <- btergm(friendship ~ edges + mutual + ttriple +
transitiveties + ctriple + nodeicov("idegsqrt") +
nodeicov("odegsqrt") + nodeocov("odegsqrt") + nodeofactor("sex") +
nodeifactor("sex") + nodematch("sex") + edgecov(primary) +
delrecip + memory(type = "stability"), R = 100, usefastglm = TRUE,
offset = TRUE, verbose = FALSE)
m2 <- btergm(friendship ~ edges + mutual + ttriple +
transitiveties + ctriple + nodeicov("idegsqrt") +
nodeicov("odegsqrt") + nodeocov("odegsqrt") + nodeofactor("sex") +
nodeifactor("sex") + nodematch("sex") + edgecov(primary) +
delrecip + memory(type = "stability"), R = 100, usefastglm = TRUE,
offset = FALSE, verbose = FALSE)
expect_equal(dim(confint(m1)), c(14, 3))
expect_equal(dim(confint(m2)), c(14, 3))
expect_equal(all(confint(m1)[, 3] - confint(m1)[, 2] >
0), TRUE)
expect_equal(all(confint(m2)[, 3] - confint(m2)[, 2] >
0), TRUE)
expect_equal(m1@offset, TRUE)
expect_equal(m2@offset, FALSE)
expect_equal(sapply(m1@data$offsmat, sum), c(0, 51, 51))
expect_equal(sapply(m2@data$offsmat, sum), c(0, 0, 0))
expect_equal(unname(nobs(m1)), c(3, 1850, 100))
expect_equal(nobs(m1), nobs(m2))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 41: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 42: test_check("btergm")
--- value of length: 2 type: logical ---
[1] TRUE FALSE
--- function from context ---
--- function search by body ---
----------- END OF FAILURE REPORT --------------
-- 4. Error: offset argument in btergm works with composition change (@test-bter
the condition has length > 1
Backtrace:
1. btergm::btergm(...)
2. btergm:::tergmprepare(formula = formula, offset = offset, verbose = verbose)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x1ec7c10>
<environment: 0x25d785f0>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x1ec7c10>
<environment: 0xe5ec7a8>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x1ec7c10>
<environment: 0x11abaa20>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x1ec7c10>
<environment: 0x320e1178>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x1ec7c10>
<environment: 0x359e0698>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
-- 5. Failure: basic GOF functionality works (@test-gof.R#25) -----------------
length(g) not equal to 7.
1/1 mismatches
[1] 2 - 7 == -5
== testthat results ===========================================================
[ OK: 36 | SKIPPED: 0 | WARNINGS: 52 | FAILED: 5 ]
1. Error: btergm estimation works (@test-btergm.R#48)
2. Error: fastglm works like speedglm (@test-btergm.R#61)
3. Error: offset argument in btergm works without composition change (@test-btergm.R#77)
4. Error: offset argument in btergm works with composition change (@test-btergm.R#115)
5. Failure: basic GOF functionality works (@test-gof.R#25)
Error: testthat unit tests failed
Execution halted
Flavor: r-devel-linux-x86_64-debian-clang
Version: 1.9.4
Check: tests
Result: ERROR
Running ‘testthat.R’ [33s/46s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(btergm)
Loading required package: xergm.common
Loading required package: ergm
Loading required package: network
network: Classes for Relational Data
Version 1.16.0 created on 2019-11-30.
copyright (c) 2005, Carter T. Butts, University of California-Irvine
Mark S. Handcock, University of California -- Los Angeles
David R. Hunter, Penn State University
Martina Morris, University of Washington
Skye Bender-deMoll, University of Washington
For citation information, type citation("network").
Type help("network-package") to get started.
ergm: version 3.10.4, created on 2019-06-10
Copyright (c) 2019, Mark S. Handcock, University of California -- Los Angeles
David R. Hunter, Penn State University
Carter T. Butts, University of California -- Irvine
Steven M. Goodreau, University of Washington
Pavel N. Krivitsky, University of Wollongong
Martina Morris, University of Washington
with contributions from
Li Wang
Kirk Li, University of Washington
Skye Bender-deMoll, University of Washington
Chad Klumb
Based on "statnet" project software (statnet.org).
For license and citation information see statnet.org/attribution
or type citation("ergm").
NOTE: Versions before 3.6.1 had a bug in the implementation of the bd()
constriant which distorted the sampled distribution somewhat. In
addition, Sampson's Monks datasets had mislabeled vertices. See the
NEWS and the documentation for more details.
NOTE: Some common term arguments pertaining to vertex attribute and
level selection have changed in 3.10.0. See terms help for more
details. Use 'options(ergm.term=list(version="3.9.4"))' to use old
behavior.
Attaching package: 'xergm.common'
The following object is masked from 'package:ergm':
gof
Loading required package: ggplot2
Registered S3 methods overwritten by 'btergm':
method from
print.gof ergm
plot.gof ergm
Package: btergm
Version: 1.9.4
Date: 2019-05-12
Authors: Philip Leifeld (University of Essex)
Skyler J. Cranmer (The Ohio State University)
Bruce A. Desmarais (Pennsylvania State University)
>
> test_check("btergm")
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
.local(object, parm, level, ...)
--- call from argument ---
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
--- R stacktrace ---
where 1: .local(object, parm, level, ...)
where 2: confint(fit)
where 3: confint(fit)
where 4: eval_bare(expr, quo_get_env(quo))
where 5: quasi_label(enquo(object), label, arg = "object")
where 6 at testthat/test-btergm.R#48: expect_equal(round(confint(fit)[1, 2], 1), -1.4)
where 7: eval(code, test_env)
where 8: eval(code, test_env)
where 9: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 10: doTryCatch(return(expr), name, parentenv, handler)
where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 13: doTryCatch(return(expr), name, parentenv, handler)
where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 15: tryCatchList(expr, classes, parentenv, handlers)
where 16: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 17: test_code(desc, code, env = parent.frame())
where 18 at testthat/test-btergm.R#21: test_that("btergm estimation works", {
set.seed(12345)
fit <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, verbose = FALSE)
expect_equal(round(unname(coef(fit)), 4), c(-1.1707, 0.0543,
0.0045))
expect_equal(names(coef(fit)), c("edges", "istar2", "edgecov.covariates[[i]]"))
expect_equal(class(fit@boot), "boot")
expect_equal(fit@boot$R, 100)
expect_equal(fit@R, 100)
expect_equal(fit@nobs, 900)
expect_equal(fit@time.steps, 10)
expect_equal(class(fit@formula), "formula")
expect_equal(class(fit@formula2), "character")
expect_equal(fit@formula, as.formula("networks ~ edges + istar(2) + edgecov(covariates)"))
expect_equal(fit@formula2, "networks[[i]] ~ edges + istar(2) + edgecov(covariates[[i]])")
expect_equal(length(fit@response), 900)
expect_equal(is.numeric(fit@response), TRUE)
expect_equal(class(fit@effects), "data.frame")
expect_equal(dim(fit@effects), c(900, 3))
expect_equal(unique(fit@effects$edges), 1)
expect_equal(median(fit@effects$istar2), 2)
expect_equal(round(mean(fit@effects$`edgecov.covariates[[i]]`),
4), -0.0144)
expect_equal(unique(fit@weights), 1)
expect_equal(fit@auto.adjust, FALSE)
expect_equal(fit@offset, FALSE)
expect_equal(fit@directed, TRUE)
expect_equal(fit@bipartite, FALSE)
expect_equal(unname(rowSums(fit@nvertices)), c(100, 100))
expect_equal(round(confint(fit)[1, 2], 1), -1.4)
expect_equal(round(confint(fit)[1, 3], 1), -0.8)
expect_equal(round(confint(fit)[2, 2], 0), 0)
expect_equal(round(confint(fit)[2, 3], 1), 0.1)
expect_equal(round(confint(fit)[3, 2], 1), -0.1)
expect_equal(round(confint(fit)[3, 3], 1), 0.1)
})
where 19: eval(code, test_env)
where 20: eval(code, test_env)
where 21: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 27: tryCatchList(expr, classes, parentenv, handlers)
where 28: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 29: test_code(NULL, exprs, env)
where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 31: force(code)
where 32: doWithOneRestart(return(expr), restart)
where 33: withOneRestart(expr, restarts[[1L]])
where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 36: FUN(X[[i]], ...)
where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 38: force(code)
where 39: doWithOneRestart(return(expr), restart)
where 40: withOneRestart(expr, restarts[[1L]])
where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (object, parm, level = 0.95, type = "perc", invlogit = FALSE,
...)
{
cf <- coef(object, invlogit = invlogit)
pnames <- names(cf)
if (missing(parm)) {
parm <- pnames
}
else if (is.numeric(parm)) {
parm <- pnames[parm]
}
n.orig <- nrow(object@boot$t)
object@boot$t <- object@boot$t[complete.cases(object@boot$t),
]
n.ret <- nrow(object@boot$t)
perc <- 100 * (n.orig - n.ret)/n.orig
if (n.orig != n.ret) {
warning(paste0("Too little variation in the model. ",
n.orig - n.ret, " replications (", perc, "%) are dropped from CI estimation."))
}
if (invlogit == TRUE) {
object@boot$t <- apply(object@boot$t, 1:2, function(x) 1/(1 +
exp(-x)))
object@boot$t0 <- sapply(object@boot$t0, function(x) 1/(1 +
exp(-x)))
}
if (type == "perc") {
type2 <- "percent"
}
else if (type == "norm") {
type2 <- "normal"
}
else if (type == "basic") {
type2 <- "basic"
}
else if (type == "stud") {
type2 <- "student"
}
else if (type == "bca") {
type2 <- "bca"
}
else {
stop(paste("'type' not supported. Use 'perc', 'bca', 'norm', 'basic',",
"or 'stud'."))
}
ci <- sapply(1:length(cf), function(x) {
b <- boot::boot.ci(object@boot, conf = level, type = type,
index = x)
b[[type2]][4:5]
})
ci <- cbind(cf, t(ci))
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
ci <- ci[parm, ]
if (class(ci) != "matrix") {
ci <- matrix(ci, ncol = 3)
rownames(ci) <- parm
}
label1 <- paste0(100 * (1 - level)/2, "%")
label2 <- paste0(100 * (1 - (1 - level)/2), "%")
colnames(ci) <- c("Estimate", label1, label2)
return(ci)
}
<environment: namespace:btergm>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 1. Error: btergm estimation works (@test-btergm.R#48) ──────────────────────
the condition has length > 1
Backtrace:
1. testthat::expect_equal(round(confint(fit)[1, 2], 1), -1.4)
5. btergm::confint(fit)
6. btergm:::.local(object, parm, level, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
.local(object, parm, level, ...)
--- call from argument ---
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
--- R stacktrace ---
where 1: .local(object, parm, level, ...)
where 2: confint(fit)
where 3: confint(fit)
where 4: eval_bare(expr, quo_get_env(quo))
where 5: quasi_label(enquo(object), label, arg = "object")
where 6 at testthat/test-btergm.R#61: expect_equal(all(round(confint(fit), 4) == round(confint(fit2),
4)), TRUE)
where 7: eval(code, test_env)
where 8: eval(code, test_env)
where 9: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 10: doTryCatch(return(expr), name, parentenv, handler)
where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 13: doTryCatch(return(expr), name, parentenv, handler)
where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 15: tryCatchList(expr, classes, parentenv, handlers)
where 16: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 17: test_code(desc, code, env = parent.frame())
where 18 at testthat/test-btergm.R#56: test_that("fastglm works like speedglm", {
set.seed(12345)
fit <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, verbose = FALSE)
set.seed(12345)
fit2 <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, usefastglm = TRUE, verbose = FALSE)
expect_equal(all(round(confint(fit), 4) == round(confint(fit2),
4)), TRUE)
})
where 19: eval(code, test_env)
where 20: eval(code, test_env)
where 21: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 27: tryCatchList(expr, classes, parentenv, handlers)
where 28: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 29: test_code(NULL, exprs, env)
where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 31: force(code)
where 32: doWithOneRestart(return(expr), restart)
where 33: withOneRestart(expr, restarts[[1L]])
where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 36: FUN(X[[i]], ...)
where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 38: force(code)
where 39: doWithOneRestart(return(expr), restart)
where 40: withOneRestart(expr, restarts[[1L]])
where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (object, parm, level = 0.95, type = "perc", invlogit = FALSE,
...)
{
cf <- coef(object, invlogit = invlogit)
pnames <- names(cf)
if (missing(parm)) {
parm <- pnames
}
else if (is.numeric(parm)) {
parm <- pnames[parm]
}
n.orig <- nrow(object@boot$t)
object@boot$t <- object@boot$t[complete.cases(object@boot$t),
]
n.ret <- nrow(object@boot$t)
perc <- 100 * (n.orig - n.ret)/n.orig
if (n.orig != n.ret) {
warning(paste0("Too little variation in the model. ",
n.orig - n.ret, " replications (", perc, "%) are dropped from CI estimation."))
}
if (invlogit == TRUE) {
object@boot$t <- apply(object@boot$t, 1:2, function(x) 1/(1 +
exp(-x)))
object@boot$t0 <- sapply(object@boot$t0, function(x) 1/(1 +
exp(-x)))
}
if (type == "perc") {
type2 <- "percent"
}
else if (type == "norm") {
type2 <- "normal"
}
else if (type == "basic") {
type2 <- "basic"
}
else if (type == "stud") {
type2 <- "student"
}
else if (type == "bca") {
type2 <- "bca"
}
else {
stop(paste("'type' not supported. Use 'perc', 'bca', 'norm', 'basic',",
"or 'stud'."))
}
ci <- sapply(1:length(cf), function(x) {
b <- boot::boot.ci(object@boot, conf = level, type = type,
index = x)
b[[type2]][4:5]
})
ci <- cbind(cf, t(ci))
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
ci <- ci[parm, ]
if (class(ci) != "matrix") {
ci <- matrix(ci, ncol = 3)
rownames(ci) <- parm
}
label1 <- paste0(100 * (1 - level)/2, "%")
label2 <- paste0(100 * (1 - (1 - level)/2), "%")
colnames(ci) <- c("Estimate", label1, label2)
return(ci)
}
<bytecode: 0x55ab8005a2b8>
<environment: namespace:btergm>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 2. Error: fastglm works like speedglm (@test-btergm.R#61) ──────────────────
the condition has length > 1
Backtrace:
1. testthat::expect_equal(...)
5. btergm::confint(fit)
6. btergm:::.local(object, parm, level, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
.local(object, parm, level, ...)
--- call from argument ---
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
--- R stacktrace ---
where 1: .local(object, parm, level, ...)
where 2: confint(fit1)
where 3: confint(fit1)
where 4: eval_bare(expr, quo_get_env(quo))
where 5: quasi_label(enquo(object), label, arg = "object")
where 6 at testthat/test-btergm.R#77: expect_equal(confint(fit1), confint(fit2))
where 7: eval(code, test_env)
where 8: eval(code, test_env)
where 9: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 10: doTryCatch(return(expr), name, parentenv, handler)
where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 13: doTryCatch(return(expr), name, parentenv, handler)
where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 15: tryCatchList(expr, classes, parentenv, handlers)
where 16: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 17: test_code(desc, code, env = parent.frame())
where 18 at testthat/test-btergm.R#64: test_that("offset argument in btergm works without composition change",
{
set.seed(12345)
fit1 <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, offset = FALSE, usefastglm = TRUE, verbose = FALSE)
set.seed(12345)
fit2 <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, offset = TRUE, usefastglm = TRUE, verbose = FALSE)
expect_equal(confint(fit1), confint(fit2))
})
where 19: eval(code, test_env)
where 20: eval(code, test_env)
where 21: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 27: tryCatchList(expr, classes, parentenv, handlers)
where 28: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 29: test_code(NULL, exprs, env)
where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 31: force(code)
where 32: doWithOneRestart(return(expr), restart)
where 33: withOneRestart(expr, restarts[[1L]])
where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 36: FUN(X[[i]], ...)
where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 38: force(code)
where 39: doWithOneRestart(return(expr), restart)
where 40: withOneRestart(expr, restarts[[1L]])
where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (object, parm, level = 0.95, type = "perc", invlogit = FALSE,
...)
{
cf <- coef(object, invlogit = invlogit)
pnames <- names(cf)
if (missing(parm)) {
parm <- pnames
}
else if (is.numeric(parm)) {
parm <- pnames[parm]
}
n.orig <- nrow(object@boot$t)
object@boot$t <- object@boot$t[complete.cases(object@boot$t),
]
n.ret <- nrow(object@boot$t)
perc <- 100 * (n.orig - n.ret)/n.orig
if (n.orig != n.ret) {
warning(paste0("Too little variation in the model. ",
n.orig - n.ret, " replications (", perc, "%) are dropped from CI estimation."))
}
if (invlogit == TRUE) {
object@boot$t <- apply(object@boot$t, 1:2, function(x) 1/(1 +
exp(-x)))
object@boot$t0 <- sapply(object@boot$t0, function(x) 1/(1 +
exp(-x)))
}
if (type == "perc") {
type2 <- "percent"
}
else if (type == "norm") {
type2 <- "normal"
}
else if (type == "basic") {
type2 <- "basic"
}
else if (type == "stud") {
type2 <- "student"
}
else if (type == "bca") {
type2 <- "bca"
}
else {
stop(paste("'type' not supported. Use 'perc', 'bca', 'norm', 'basic',",
"or 'stud'."))
}
ci <- sapply(1:length(cf), function(x) {
b <- boot::boot.ci(object@boot, conf = level, type = type,
index = x)
b[[type2]][4:5]
})
ci <- cbind(cf, t(ci))
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
ci <- ci[parm, ]
if (class(ci) != "matrix") {
ci <- matrix(ci, ncol = 3)
rownames(ci) <- parm
}
label1 <- paste0(100 * (1 - level)/2, "%")
label2 <- paste0(100 * (1 - (1 - level)/2), "%")
colnames(ci) <- c("Estimate", label1, label2)
return(ci)
}
<bytecode: 0x55ab8005a2b8>
<environment: namespace:btergm>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 3. Error: offset argument in btergm works without composition change (@test-b
the condition has length > 1
Backtrace:
1. testthat::expect_equal(confint(fit1), confint(fit2))
5. btergm::confint(fit1)
6. btergm:::.local(object, parm, level, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
NULL
--- call from argument ---
if (type %in% c("matrix", "network", "dgCMatrix", "dgTMatrix",
"dsCMatrix", "dsTMatrix", "dgeMatrix")) {
if (!type %in% c("matrix", "network")) {
x.current <- as.matrix(x.current)
}
l[[x2]] <- list()
for (i in 1:l$time.steps) {
l[[x2]][[i]] <- x.current
}
if (blockdiag == TRUE) {
}
else {
x2 <- paste0(x2, "[[i]]")
}
l$rhs.terms[k] <- paste(x1, x2, x3, sep = "")
} else if (type == "list" || type == "network.list") {
if (length(x.current) != l$time.steps) {
stop(paste(x2, "has", length(get(x2)), "elements, but there are",
l$time.steps, "networks to be modeled."))
}
if (blockdiag == TRUE) {
}
else {
x2 <- paste0(x2, "[[i]]")
}
l$rhs.terms[k] <- paste0(x1, x2, x3)
} else {
tryCatch({
l[[x2]] <- list(rep(as.matrix(x.current)), l$time.steps)
}, error = function(cond) {
stop(paste0("Object '", x2, "' could not be converted to a matrix."))
})
}
--- R stacktrace ---
where 1: tergmprepare(formula = formula, offset = offset, verbose = verbose)
where 2 at testthat/test-btergm.R#115: btergm(friendship ~ edges + mutual + ttriple + transitiveties +
ctriple + nodeicov("idegsqrt") + nodeicov("odegsqrt") + nodeocov("odegsqrt") +
nodeofactor("sex") + nodeifactor("sex") + nodematch("sex") +
edgecov(primary) + delrecip + memory(type = "stability"),
R = 100, usefastglm = TRUE, offset = TRUE, verbose = FALSE)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-btergm.R#80: test_that("offset argument in btergm works with composition change",
{
require("sna")
data("knecht")
for (i in 1:length(friendship)) {
rownames(friendship[[i]]) <- 1:nrow(friendship[[i]])
colnames(friendship[[i]]) <- 1:ncol(friendship[[i]])
}
rownames(primary) <- rownames(friendship[[1]])
colnames(primary) <- colnames(friendship[[1]])
sex <- demographics$sex
names(sex) <- 1:length(sex)
suppressMessages(friendship <- handleMissings(friendship,
na = 10, method = "remove"))
suppressMessages(friendship <- handleMissings(friendship,
na = NA, method = "fillmode"))
for (i in 1:length(friendship)) {
s <- adjust(sex, friendship[[i]])
friendship[[i]] <- network(friendship[[i]])
friendship[[i]] <- set.vertex.attribute(friendship[[i]],
"sex", s)
idegsqrt <- sqrt(degree(friendship[[i]], cmode = "indegree"))
friendship[[i]] <- set.vertex.attribute(friendship[[i]],
"idegsqrt", idegsqrt)
odegsqrt <- sqrt(degree(friendship[[i]], cmode = "outdegree"))
friendship[[i]] <- set.vertex.attribute(friendship[[i]],
"odegsqrt", odegsqrt)
}
expect_equal(unname(sapply(friendship, network.size)),
c(26, 26, 25, 25))
set.seed(12345)
m1 <- btergm(friendship ~ edges + mutual + ttriple +
transitiveties + ctriple + nodeicov("idegsqrt") +
nodeicov("odegsqrt") + nodeocov("odegsqrt") + nodeofactor("sex") +
nodeifactor("sex") + nodematch("sex") + edgecov(primary) +
delrecip + memory(type = "stability"), R = 100, usefastglm = TRUE,
offset = TRUE, verbose = FALSE)
m2 <- btergm(friendship ~ edges + mutual + ttriple +
transitiveties + ctriple + nodeicov("idegsqrt") +
nodeicov("odegsqrt") + nodeocov("odegsqrt") + nodeofactor("sex") +
nodeifactor("sex") + nodematch("sex") + edgecov(primary) +
delrecip + memory(type = "stability"), R = 100, usefastglm = TRUE,
offset = FALSE, verbose = FALSE)
expect_equal(dim(confint(m1)), c(14, 3))
expect_equal(dim(confint(m2)), c(14, 3))
expect_equal(all(confint(m1)[, 3] - confint(m1)[, 2] >
0), TRUE)
expect_equal(all(confint(m2)[, 3] - confint(m2)[, 2] >
0), TRUE)
expect_equal(m1@offset, TRUE)
expect_equal(m2@offset, FALSE)
expect_equal(sapply(m1@data$offsmat, sum), c(0, 51, 51))
expect_equal(sapply(m2@data$offsmat, sum), c(0, 0, 0))
expect_equal(unname(nobs(m1)), c(3, 1850, 100))
expect_equal(nobs(m1), nobs(m2))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 41: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 42: test_check("btergm")
--- value of length: 2 type: logical ---
[1] TRUE FALSE
--- function from context ---
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 4. Error: offset argument in btergm works with composition change (@test-bter
the condition has length > 1
Backtrace:
1. btergm::btergm(...)
2. btergm:::tergmprepare(formula = formula, offset = offset, verbose = verbose)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x55ab6d583c70>
<environment: 0x55ab76a07d90>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x55ab6d583c70>
<environment: 0x55ab82b70600>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x55ab6d583c70>
<environment: 0x55ab829f8928>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x55ab6d583c70>
<environment: 0x55ab92518238>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x55ab6d583c70>
<environment: 0x55ab9edfe100>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 5. Failure: basic GOF functionality works (@test-gof.R#25) ─────────────────
length(g) not equal to 7.
1/1 mismatches
[1] 2 - 7 == -5
══ testthat results ═══════════════════════════════════════════════════════════
[ OK: 36 | SKIPPED: 0 | WARNINGS: 52 | FAILED: 5 ]
1. Error: btergm estimation works (@test-btergm.R#48)
2. Error: fastglm works like speedglm (@test-btergm.R#61)
3. Error: offset argument in btergm works without composition change (@test-btergm.R#77)
4. Error: offset argument in btergm works with composition change (@test-btergm.R#115)
5. Failure: basic GOF functionality works (@test-gof.R#25)
Error: testthat unit tests failed
Execution halted
Flavor: r-devel-linux-x86_64-debian-gcc
Version: 1.9.4
Check: examples
Result: ERROR
Running examples in ‘btergm-Ex.R’ failed
The error most likely occurred in:
> ### Name: btergm
> ### Title: TERGM by bootstrapped pseudolikelihood or MCMC MLE
> ### Aliases: btergm mtergm tergm
>
> ### ** Examples
>
> # A simple toy example:
>
> library("network")
> set.seed(5)
>
> networks <- list()
> for(i in 1:10) { # create 10 random networks with 10 actors
+ mat <- matrix(rbinom(100, 1, .25), nrow = 10, ncol = 10)
+ diag(mat) <- 0 # loops are excluded
+ nw <- network(mat) # create network object
+ networks[[i]] <- nw # add network to the list
+ }
>
> covariates <- list()
> for (i in 1:10) { # create 10 matrices as covariate
+ mat <- matrix(rnorm(100), nrow = 10, ncol = 10)
+ covariates[[i]] <- mat # add matrix to the list
+ }
>
> fit <- btergm(networks ~ edges + istar(2) +
+ edgecov(covariates), R = 100)
Initial dimensions of the network and covariates:
t=1 t=2 t=3 t=4 t=5 t=6 t=7 t=8 t=9 t=10
networks (row) 10 10 10 10 10 10 10 10 10 10
networks (col) 10 10 10 10 10 10 10 10 10 10
covariates (row) 10 10 10 10 10 10 10 10 10 10
covariates (col) 10 10 10 10 10 10 10 10 10 10
All networks are conformable.
Dimensions of the network and covariates after adjustment:
t=1 t=2 t=3 t=4 t=5 t=6 t=7 t=8 t=9 t=10
networks (row) 10 10 10 10 10 10 10 10 10 10
networks (col) 10 10 10 10 10 10 10 10 10 10
covariates (row) 10 10 10 10 10 10 10 10 10 10
covariates (col) 10 10 10 10 10 10 10 10 10 10
Starting pseudolikelihood estimation with 100 bootstrapping replications on a single computing core...
Done.
>
> summary(fit) # show estimation results
==========================
Summary of model fit
==========================
Formula: networks ~ edges + istar(2) + edgecov(covariates)
Time steps: 10
Bootstrapping sample size: 100
Estimates and 95% confidence intervals:
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
.local(object, parm, level, ...)
--- call from argument ---
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
--- R stacktrace ---
where 1: .local(object, parm, level, ...)
where 2: confint(object, level = level, type = type, invlogit = invlogit,
...)
where 3: confint(object, level = level, type = type, invlogit = invlogit,
...)
where 4: .local(object, ...)
where 5: summary(fit)
where 6: summary(fit)
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (object, parm, level = 0.95, type = "perc", invlogit = FALSE,
...)
{
cf <- coef(object, invlogit = invlogit)
pnames <- names(cf)
if (missing(parm)) {
parm <- pnames
}
else if (is.numeric(parm)) {
parm <- pnames[parm]
}
n.orig <- nrow(object@boot$t)
object@boot$t <- object@boot$t[complete.cases(object@boot$t),
]
n.ret <- nrow(object@boot$t)
perc <- 100 * (n.orig - n.ret)/n.orig
if (n.orig != n.ret) {
warning(paste0("Too little variation in the model. ",
n.orig - n.ret, " replications (", perc, "%) are dropped from CI estimation."))
}
if (invlogit == TRUE) {
object@boot$t <- apply(object@boot$t, 1:2, function(x) 1/(1 +
exp(-x)))
object@boot$t0 <- sapply(object@boot$t0, function(x) 1/(1 +
exp(-x)))
}
if (type == "perc") {
type2 <- "percent"
}
else if (type == "norm") {
type2 <- "normal"
}
else if (type == "basic") {
type2 <- "basic"
}
else if (type == "stud") {
type2 <- "student"
}
else if (type == "bca") {
type2 <- "bca"
}
else {
stop(paste("'type' not supported. Use 'perc', 'bca', 'norm', 'basic',",
"or 'stud'."))
}
ci <- sapply(1:length(cf), function(x) {
b <- boot::boot.ci(object@boot, conf = level, type = type,
index = x)
b[[type2]][4:5]
})
ci <- cbind(cf, t(ci))
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
ci <- ci[parm, ]
if (class(ci) != "matrix") {
ci <- matrix(ci, ncol = 3)
rownames(ci) <- parm
}
label1 <- paste0(100 * (1 - level)/2, "%")
label2 <- paste0(100 * (1 - (1 - level)/2), "%")
colnames(ci) <- c("Estimate", label1, label2)
return(ci)
}
<environment: namespace:btergm>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
Error in if (class(ci) == "numeric") { : the condition has length > 1
Calls: summary -> summary -> .local -> confint -> confint -> .local
Execution halted
Flavors: r-devel-linux-x86_64-fedora-clang, r-devel-linux-x86_64-fedora-gcc
Version: 1.9.4
Check: tests
Result: ERROR
Running ‘testthat.R’ [51s/66s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(btergm)
Loading required package: xergm.common
Loading required package: ergm
Loading required package: network
network: Classes for Relational Data
Version 1.16.0 created on 2019-11-30.
copyright (c) 2005, Carter T. Butts, University of California-Irvine
Mark S. Handcock, University of California -- Los Angeles
David R. Hunter, Penn State University
Martina Morris, University of Washington
Skye Bender-deMoll, University of Washington
For citation information, type citation("network").
Type help("network-package") to get started.
ergm: version 3.10.4, created on 2019-06-10
Copyright (c) 2019, Mark S. Handcock, University of California -- Los Angeles
David R. Hunter, Penn State University
Carter T. Butts, University of California -- Irvine
Steven M. Goodreau, University of Washington
Pavel N. Krivitsky, University of Wollongong
Martina Morris, University of Washington
with contributions from
Li Wang
Kirk Li, University of Washington
Skye Bender-deMoll, University of Washington
Chad Klumb
Based on "statnet" project software (statnet.org).
For license and citation information see statnet.org/attribution
or type citation("ergm").
NOTE: Versions before 3.6.1 had a bug in the implementation of the bd()
constriant which distorted the sampled distribution somewhat. In
addition, Sampson's Monks datasets had mislabeled vertices. See the
NEWS and the documentation for more details.
NOTE: Some common term arguments pertaining to vertex attribute and
level selection have changed in 3.10.0. See terms help for more
details. Use 'options(ergm.term=list(version="3.9.4"))' to use old
behavior.
Attaching package: 'xergm.common'
The following object is masked from 'package:ergm':
gof
Loading required package: ggplot2
Registered S3 methods overwritten by 'btergm':
method from
print.gof ergm
plot.gof ergm
Package: btergm
Version: 1.9.4
Date: 2019-05-12
Authors: Philip Leifeld (University of Essex)
Skyler J. Cranmer (The Ohio State University)
Bruce A. Desmarais (Pennsylvania State University)
>
> test_check("btergm")
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
.local(object, parm, level, ...)
--- call from argument ---
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
--- R stacktrace ---
where 1: .local(object, parm, level, ...)
where 2: confint(fit)
where 3: confint(fit)
where 4: eval_bare(expr, quo_get_env(quo))
where 5: quasi_label(enquo(object), label, arg = "object")
where 6 at testthat/test-btergm.R#48: expect_equal(round(confint(fit)[1, 2], 1), -1.4)
where 7: eval(code, test_env)
where 8: eval(code, test_env)
where 9: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 10: doTryCatch(return(expr), name, parentenv, handler)
where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 13: doTryCatch(return(expr), name, parentenv, handler)
where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 15: tryCatchList(expr, classes, parentenv, handlers)
where 16: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 17: test_code(desc, code, env = parent.frame())
where 18 at testthat/test-btergm.R#21: test_that("btergm estimation works", {
set.seed(12345)
fit <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, verbose = FALSE)
expect_equal(round(unname(coef(fit)), 4), c(-1.1707, 0.0543,
0.0045))
expect_equal(names(coef(fit)), c("edges", "istar2", "edgecov.covariates[[i]]"))
expect_equal(class(fit@boot), "boot")
expect_equal(fit@boot$R, 100)
expect_equal(fit@R, 100)
expect_equal(fit@nobs, 900)
expect_equal(fit@time.steps, 10)
expect_equal(class(fit@formula), "formula")
expect_equal(class(fit@formula2), "character")
expect_equal(fit@formula, as.formula("networks ~ edges + istar(2) + edgecov(covariates)"))
expect_equal(fit@formula2, "networks[[i]] ~ edges + istar(2) + edgecov(covariates[[i]])")
expect_equal(length(fit@response), 900)
expect_equal(is.numeric(fit@response), TRUE)
expect_equal(class(fit@effects), "data.frame")
expect_equal(dim(fit@effects), c(900, 3))
expect_equal(unique(fit@effects$edges), 1)
expect_equal(median(fit@effects$istar2), 2)
expect_equal(round(mean(fit@effects$`edgecov.covariates[[i]]`),
4), -0.0144)
expect_equal(unique(fit@weights), 1)
expect_equal(fit@auto.adjust, FALSE)
expect_equal(fit@offset, FALSE)
expect_equal(fit@directed, TRUE)
expect_equal(fit@bipartite, FALSE)
expect_equal(unname(rowSums(fit@nvertices)), c(100, 100))
expect_equal(round(confint(fit)[1, 2], 1), -1.4)
expect_equal(round(confint(fit)[1, 3], 1), -0.8)
expect_equal(round(confint(fit)[2, 2], 0), 0)
expect_equal(round(confint(fit)[2, 3], 1), 0.1)
expect_equal(round(confint(fit)[3, 2], 1), -0.1)
expect_equal(round(confint(fit)[3, 3], 1), 0.1)
})
where 19: eval(code, test_env)
where 20: eval(code, test_env)
where 21: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 27: tryCatchList(expr, classes, parentenv, handlers)
where 28: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 29: test_code(NULL, exprs, env)
where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 31: force(code)
where 32: doWithOneRestart(return(expr), restart)
where 33: withOneRestart(expr, restarts[[1L]])
where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 36: FUN(X[[i]], ...)
where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 38: force(code)
where 39: doWithOneRestart(return(expr), restart)
where 40: withOneRestart(expr, restarts[[1L]])
where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (object, parm, level = 0.95, type = "perc", invlogit = FALSE,
...)
{
cf <- coef(object, invlogit = invlogit)
pnames <- names(cf)
if (missing(parm)) {
parm <- pnames
}
else if (is.numeric(parm)) {
parm <- pnames[parm]
}
n.orig <- nrow(object@boot$t)
object@boot$t <- object@boot$t[complete.cases(object@boot$t),
]
n.ret <- nrow(object@boot$t)
perc <- 100 * (n.orig - n.ret)/n.orig
if (n.orig != n.ret) {
warning(paste0("Too little variation in the model. ",
n.orig - n.ret, " replications (", perc, "%) are dropped from CI estimation."))
}
if (invlogit == TRUE) {
object@boot$t <- apply(object@boot$t, 1:2, function(x) 1/(1 +
exp(-x)))
object@boot$t0 <- sapply(object@boot$t0, function(x) 1/(1 +
exp(-x)))
}
if (type == "perc") {
type2 <- "percent"
}
else if (type == "norm") {
type2 <- "normal"
}
else if (type == "basic") {
type2 <- "basic"
}
else if (type == "stud") {
type2 <- "student"
}
else if (type == "bca") {
type2 <- "bca"
}
else {
stop(paste("'type' not supported. Use 'perc', 'bca', 'norm', 'basic',",
"or 'stud'."))
}
ci <- sapply(1:length(cf), function(x) {
b <- boot::boot.ci(object@boot, conf = level, type = type,
index = x)
b[[type2]][4:5]
})
ci <- cbind(cf, t(ci))
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
ci <- ci[parm, ]
if (class(ci) != "matrix") {
ci <- matrix(ci, ncol = 3)
rownames(ci) <- parm
}
label1 <- paste0(100 * (1 - level)/2, "%")
label2 <- paste0(100 * (1 - (1 - level)/2), "%")
colnames(ci) <- c("Estimate", label1, label2)
return(ci)
}
<environment: namespace:btergm>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 1. Error: btergm estimation works (@test-btergm.R#48) ──────────────────────
the condition has length > 1
Backtrace:
1. testthat::expect_equal(round(confint(fit)[1, 2], 1), -1.4)
5. btergm::confint(fit)
6. btergm:::.local(object, parm, level, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
.local(object, parm, level, ...)
--- call from argument ---
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
--- R stacktrace ---
where 1: .local(object, parm, level, ...)
where 2: confint(fit)
where 3: confint(fit)
where 4: eval_bare(expr, quo_get_env(quo))
where 5: quasi_label(enquo(object), label, arg = "object")
where 6 at testthat/test-btergm.R#61: expect_equal(all(round(confint(fit), 4) == round(confint(fit2),
4)), TRUE)
where 7: eval(code, test_env)
where 8: eval(code, test_env)
where 9: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 10: doTryCatch(return(expr), name, parentenv, handler)
where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 13: doTryCatch(return(expr), name, parentenv, handler)
where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 15: tryCatchList(expr, classes, parentenv, handlers)
where 16: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 17: test_code(desc, code, env = parent.frame())
where 18 at testthat/test-btergm.R#56: test_that("fastglm works like speedglm", {
set.seed(12345)
fit <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, verbose = FALSE)
set.seed(12345)
fit2 <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, usefastglm = TRUE, verbose = FALSE)
expect_equal(all(round(confint(fit), 4) == round(confint(fit2),
4)), TRUE)
})
where 19: eval(code, test_env)
where 20: eval(code, test_env)
where 21: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 27: tryCatchList(expr, classes, parentenv, handlers)
where 28: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 29: test_code(NULL, exprs, env)
where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 31: force(code)
where 32: doWithOneRestart(return(expr), restart)
where 33: withOneRestart(expr, restarts[[1L]])
where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 36: FUN(X[[i]], ...)
where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 38: force(code)
where 39: doWithOneRestart(return(expr), restart)
where 40: withOneRestart(expr, restarts[[1L]])
where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (object, parm, level = 0.95, type = "perc", invlogit = FALSE,
...)
{
cf <- coef(object, invlogit = invlogit)
pnames <- names(cf)
if (missing(parm)) {
parm <- pnames
}
else if (is.numeric(parm)) {
parm <- pnames[parm]
}
n.orig <- nrow(object@boot$t)
object@boot$t <- object@boot$t[complete.cases(object@boot$t),
]
n.ret <- nrow(object@boot$t)
perc <- 100 * (n.orig - n.ret)/n.orig
if (n.orig != n.ret) {
warning(paste0("Too little variation in the model. ",
n.orig - n.ret, " replications (", perc, "%) are dropped from CI estimation."))
}
if (invlogit == TRUE) {
object@boot$t <- apply(object@boot$t, 1:2, function(x) 1/(1 +
exp(-x)))
object@boot$t0 <- sapply(object@boot$t0, function(x) 1/(1 +
exp(-x)))
}
if (type == "perc") {
type2 <- "percent"
}
else if (type == "norm") {
type2 <- "normal"
}
else if (type == "basic") {
type2 <- "basic"
}
else if (type == "stud") {
type2 <- "student"
}
else if (type == "bca") {
type2 <- "bca"
}
else {
stop(paste("'type' not supported. Use 'perc', 'bca', 'norm', 'basic',",
"or 'stud'."))
}
ci <- sapply(1:length(cf), function(x) {
b <- boot::boot.ci(object@boot, conf = level, type = type,
index = x)
b[[type2]][4:5]
})
ci <- cbind(cf, t(ci))
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
ci <- ci[parm, ]
if (class(ci) != "matrix") {
ci <- matrix(ci, ncol = 3)
rownames(ci) <- parm
}
label1 <- paste0(100 * (1 - level)/2, "%")
label2 <- paste0(100 * (1 - (1 - level)/2), "%")
colnames(ci) <- c("Estimate", label1, label2)
return(ci)
}
<bytecode: 0x1344aae0>
<environment: namespace:btergm>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 2. Error: fastglm works like speedglm (@test-btergm.R#61) ──────────────────
the condition has length > 1
Backtrace:
1. testthat::expect_equal(...)
5. btergm::confint(fit)
6. btergm:::.local(object, parm, level, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
.local(object, parm, level, ...)
--- call from argument ---
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
--- R stacktrace ---
where 1: .local(object, parm, level, ...)
where 2: confint(fit1)
where 3: confint(fit1)
where 4: eval_bare(expr, quo_get_env(quo))
where 5: quasi_label(enquo(object), label, arg = "object")
where 6 at testthat/test-btergm.R#77: expect_equal(confint(fit1), confint(fit2))
where 7: eval(code, test_env)
where 8: eval(code, test_env)
where 9: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 10: doTryCatch(return(expr), name, parentenv, handler)
where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 13: doTryCatch(return(expr), name, parentenv, handler)
where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 15: tryCatchList(expr, classes, parentenv, handlers)
where 16: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 17: test_code(desc, code, env = parent.frame())
where 18 at testthat/test-btergm.R#64: test_that("offset argument in btergm works without composition change",
{
set.seed(12345)
fit1 <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, offset = FALSE, usefastglm = TRUE, verbose = FALSE)
set.seed(12345)
fit2 <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, offset = TRUE, usefastglm = TRUE, verbose = FALSE)
expect_equal(confint(fit1), confint(fit2))
})
where 19: eval(code, test_env)
where 20: eval(code, test_env)
where 21: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 27: tryCatchList(expr, classes, parentenv, handlers)
where 28: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 29: test_code(NULL, exprs, env)
where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 31: force(code)
where 32: doWithOneRestart(return(expr), restart)
where 33: withOneRestart(expr, restarts[[1L]])
where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 36: FUN(X[[i]], ...)
where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 38: force(code)
where 39: doWithOneRestart(return(expr), restart)
where 40: withOneRestart(expr, restarts[[1L]])
where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (object, parm, level = 0.95, type = "perc", invlogit = FALSE,
...)
{
cf <- coef(object, invlogit = invlogit)
pnames <- names(cf)
if (missing(parm)) {
parm <- pnames
}
else if (is.numeric(parm)) {
parm <- pnames[parm]
}
n.orig <- nrow(object@boot$t)
object@boot$t <- object@boot$t[complete.cases(object@boot$t),
]
n.ret <- nrow(object@boot$t)
perc <- 100 * (n.orig - n.ret)/n.orig
if (n.orig != n.ret) {
warning(paste0("Too little variation in the model. ",
n.orig - n.ret, " replications (", perc, "%) are dropped from CI estimation."))
}
if (invlogit == TRUE) {
object@boot$t <- apply(object@boot$t, 1:2, function(x) 1/(1 +
exp(-x)))
object@boot$t0 <- sapply(object@boot$t0, function(x) 1/(1 +
exp(-x)))
}
if (type == "perc") {
type2 <- "percent"
}
else if (type == "norm") {
type2 <- "normal"
}
else if (type == "basic") {
type2 <- "basic"
}
else if (type == "stud") {
type2 <- "student"
}
else if (type == "bca") {
type2 <- "bca"
}
else {
stop(paste("'type' not supported. Use 'perc', 'bca', 'norm', 'basic',",
"or 'stud'."))
}
ci <- sapply(1:length(cf), function(x) {
b <- boot::boot.ci(object@boot, conf = level, type = type,
index = x)
b[[type2]][4:5]
})
ci <- cbind(cf, t(ci))
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
ci <- ci[parm, ]
if (class(ci) != "matrix") {
ci <- matrix(ci, ncol = 3)
rownames(ci) <- parm
}
label1 <- paste0(100 * (1 - level)/2, "%")
label2 <- paste0(100 * (1 - (1 - level)/2), "%")
colnames(ci) <- c("Estimate", label1, label2)
return(ci)
}
<bytecode: 0x1344aae0>
<environment: namespace:btergm>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 3. Error: offset argument in btergm works without composition change (@test-b
the condition has length > 1
Backtrace:
1. testthat::expect_equal(confint(fit1), confint(fit2))
5. btergm::confint(fit1)
6. btergm:::.local(object, parm, level, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
NULL
--- call from argument ---
if (type %in% c("matrix", "network", "dgCMatrix", "dgTMatrix",
"dsCMatrix", "dsTMatrix", "dgeMatrix")) {
if (!type %in% c("matrix", "network")) {
x.current <- as.matrix(x.current)
}
l[[x2]] <- list()
for (i in 1:l$time.steps) {
l[[x2]][[i]] <- x.current
}
if (blockdiag == TRUE) {
}
else {
x2 <- paste0(x2, "[[i]]")
}
l$rhs.terms[k] <- paste(x1, x2, x3, sep = "")
} else if (type == "list" || type == "network.list") {
if (length(x.current) != l$time.steps) {
stop(paste(x2, "has", length(get(x2)), "elements, but there are",
l$time.steps, "networks to be modeled."))
}
if (blockdiag == TRUE) {
}
else {
x2 <- paste0(x2, "[[i]]")
}
l$rhs.terms[k] <- paste0(x1, x2, x3)
} else {
tryCatch({
l[[x2]] <- list(rep(as.matrix(x.current)), l$time.steps)
}, error = function(cond) {
stop(paste0("Object '", x2, "' could not be converted to a matrix."))
})
}
--- R stacktrace ---
where 1: tergmprepare(formula = formula, offset = offset, verbose = verbose)
where 2 at testthat/test-btergm.R#115: btergm(friendship ~ edges + mutual + ttriple + transitiveties +
ctriple + nodeicov("idegsqrt") + nodeicov("odegsqrt") + nodeocov("odegsqrt") +
nodeofactor("sex") + nodeifactor("sex") + nodematch("sex") +
edgecov(primary) + delrecip + memory(type = "stability"),
R = 100, usefastglm = TRUE, offset = TRUE, verbose = FALSE)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-btergm.R#80: test_that("offset argument in btergm works with composition change",
{
require("sna")
data("knecht")
for (i in 1:length(friendship)) {
rownames(friendship[[i]]) <- 1:nrow(friendship[[i]])
colnames(friendship[[i]]) <- 1:ncol(friendship[[i]])
}
rownames(primary) <- rownames(friendship[[1]])
colnames(primary) <- colnames(friendship[[1]])
sex <- demographics$sex
names(sex) <- 1:length(sex)
suppressMessages(friendship <- handleMissings(friendship,
na = 10, method = "remove"))
suppressMessages(friendship <- handleMissings(friendship,
na = NA, method = "fillmode"))
for (i in 1:length(friendship)) {
s <- adjust(sex, friendship[[i]])
friendship[[i]] <- network(friendship[[i]])
friendship[[i]] <- set.vertex.attribute(friendship[[i]],
"sex", s)
idegsqrt <- sqrt(degree(friendship[[i]], cmode = "indegree"))
friendship[[i]] <- set.vertex.attribute(friendship[[i]],
"idegsqrt", idegsqrt)
odegsqrt <- sqrt(degree(friendship[[i]], cmode = "outdegree"))
friendship[[i]] <- set.vertex.attribute(friendship[[i]],
"odegsqrt", odegsqrt)
}
expect_equal(unname(sapply(friendship, network.size)),
c(26, 26, 25, 25))
set.seed(12345)
m1 <- btergm(friendship ~ edges + mutual + ttriple +
transitiveties + ctriple + nodeicov("idegsqrt") +
nodeicov("odegsqrt") + nodeocov("odegsqrt") + nodeofactor("sex") +
nodeifactor("sex") + nodematch("sex") + edgecov(primary) +
delrecip + memory(type = "stability"), R = 100, usefastglm = TRUE,
offset = TRUE, verbose = FALSE)
m2 <- btergm(friendship ~ edges + mutual + ttriple +
transitiveties + ctriple + nodeicov("idegsqrt") +
nodeicov("odegsqrt") + nodeocov("odegsqrt") + nodeofactor("sex") +
nodeifactor("sex") + nodematch("sex") + edgecov(primary) +
delrecip + memory(type = "stability"), R = 100, usefastglm = TRUE,
offset = FALSE, verbose = FALSE)
expect_equal(dim(confint(m1)), c(14, 3))
expect_equal(dim(confint(m2)), c(14, 3))
expect_equal(all(confint(m1)[, 3] - confint(m1)[, 2] >
0), TRUE)
expect_equal(all(confint(m2)[, 3] - confint(m2)[, 2] >
0), TRUE)
expect_equal(m1@offset, TRUE)
expect_equal(m2@offset, FALSE)
expect_equal(sapply(m1@data$offsmat, sum), c(0, 51, 51))
expect_equal(sapply(m2@data$offsmat, sum), c(0, 0, 0))
expect_equal(unname(nobs(m1)), c(3, 1850, 100))
expect_equal(nobs(m1), nobs(m2))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 41: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 42: test_check("btergm")
--- value of length: 2 type: logical ---
[1] TRUE FALSE
--- function from context ---
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 4. Error: offset argument in btergm works with composition change (@test-bter
the condition has length > 1
Backtrace:
1. btergm::btergm(...)
2. btergm:::tergmprepare(formula = formula, offset = offset, verbose = verbose)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0xf85980>
<environment: 0x2d4c70e8>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0xf85980>
<environment: 0x2c53bc40>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0xf85980>
<environment: 0x2497f0d0>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0xf85980>
<environment: 0x30f17350>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0xf85980>
<environment: 0x347f6020>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 5. Failure: basic GOF functionality works (@test-gof.R#25) ─────────────────
length(g) not equal to 7.
1/1 mismatches
[1] 2 - 7 == -5
══ testthat results ═══════════════════════════════════════════════════════════
[ OK: 36 | SKIPPED: 0 | WARNINGS: 52 | FAILED: 5 ]
1. Error: btergm estimation works (@test-btergm.R#48)
2. Error: fastglm works like speedglm (@test-btergm.R#61)
3. Error: offset argument in btergm works without composition change (@test-btergm.R#77)
4. Error: offset argument in btergm works with composition change (@test-btergm.R#115)
5. Failure: basic GOF functionality works (@test-gof.R#25)
Error: testthat unit tests failed
Execution halted
Flavor: r-devel-linux-x86_64-fedora-clang
Version: 1.9.4
Check: tests
Result: ERROR
Running ‘testthat.R’ [55s/136s]
Running the tests in ‘tests/testthat.R’ failed.
Complete output:
> library(testthat)
> library(btergm)
Loading required package: xergm.common
Loading required package: ergm
Loading required package: network
network: Classes for Relational Data
Version 1.16.0 created on 2019-11-30.
copyright (c) 2005, Carter T. Butts, University of California-Irvine
Mark S. Handcock, University of California -- Los Angeles
David R. Hunter, Penn State University
Martina Morris, University of Washington
Skye Bender-deMoll, University of Washington
For citation information, type citation("network").
Type help("network-package") to get started.
ergm: version 3.10.4, created on 2019-06-10
Copyright (c) 2019, Mark S. Handcock, University of California -- Los Angeles
David R. Hunter, Penn State University
Carter T. Butts, University of California -- Irvine
Steven M. Goodreau, University of Washington
Pavel N. Krivitsky, University of Wollongong
Martina Morris, University of Washington
with contributions from
Li Wang
Kirk Li, University of Washington
Skye Bender-deMoll, University of Washington
Chad Klumb
Based on "statnet" project software (statnet.org).
For license and citation information see statnet.org/attribution
or type citation("ergm").
NOTE: Versions before 3.6.1 had a bug in the implementation of the bd()
constriant which distorted the sampled distribution somewhat. In
addition, Sampson's Monks datasets had mislabeled vertices. See the
NEWS and the documentation for more details.
NOTE: Some common term arguments pertaining to vertex attribute and
level selection have changed in 3.10.0. See terms help for more
details. Use 'options(ergm.term=list(version="3.9.4"))' to use old
behavior.
Attaching package: 'xergm.common'
The following object is masked from 'package:ergm':
gof
Loading required package: ggplot2
Registered S3 methods overwritten by 'btergm':
method from
print.gof ergm
plot.gof ergm
Package: btergm
Version: 1.9.4
Date: 2019-05-12
Authors: Philip Leifeld (University of Essex)
Skyler J. Cranmer (The Ohio State University)
Bruce A. Desmarais (Pennsylvania State University)
>
> test_check("btergm")
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
.local(object, parm, level, ...)
--- call from argument ---
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
--- R stacktrace ---
where 1: .local(object, parm, level, ...)
where 2: confint(fit)
where 3: confint(fit)
where 4: eval_bare(expr, quo_get_env(quo))
where 5: quasi_label(enquo(object), label, arg = "object")
where 6 at testthat/test-btergm.R#48: expect_equal(round(confint(fit)[1, 2], 1), -1.4)
where 7: eval(code, test_env)
where 8: eval(code, test_env)
where 9: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 10: doTryCatch(return(expr), name, parentenv, handler)
where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 13: doTryCatch(return(expr), name, parentenv, handler)
where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 15: tryCatchList(expr, classes, parentenv, handlers)
where 16: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 17: test_code(desc, code, env = parent.frame())
where 18 at testthat/test-btergm.R#21: test_that("btergm estimation works", {
set.seed(12345)
fit <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, verbose = FALSE)
expect_equal(round(unname(coef(fit)), 4), c(-1.1707, 0.0543,
0.0045))
expect_equal(names(coef(fit)), c("edges", "istar2", "edgecov.covariates[[i]]"))
expect_equal(class(fit@boot), "boot")
expect_equal(fit@boot$R, 100)
expect_equal(fit@R, 100)
expect_equal(fit@nobs, 900)
expect_equal(fit@time.steps, 10)
expect_equal(class(fit@formula), "formula")
expect_equal(class(fit@formula2), "character")
expect_equal(fit@formula, as.formula("networks ~ edges + istar(2) + edgecov(covariates)"))
expect_equal(fit@formula2, "networks[[i]] ~ edges + istar(2) + edgecov(covariates[[i]])")
expect_equal(length(fit@response), 900)
expect_equal(is.numeric(fit@response), TRUE)
expect_equal(class(fit@effects), "data.frame")
expect_equal(dim(fit@effects), c(900, 3))
expect_equal(unique(fit@effects$edges), 1)
expect_equal(median(fit@effects$istar2), 2)
expect_equal(round(mean(fit@effects$`edgecov.covariates[[i]]`),
4), -0.0144)
expect_equal(unique(fit@weights), 1)
expect_equal(fit@auto.adjust, FALSE)
expect_equal(fit@offset, FALSE)
expect_equal(fit@directed, TRUE)
expect_equal(fit@bipartite, FALSE)
expect_equal(unname(rowSums(fit@nvertices)), c(100, 100))
expect_equal(round(confint(fit)[1, 2], 1), -1.4)
expect_equal(round(confint(fit)[1, 3], 1), -0.8)
expect_equal(round(confint(fit)[2, 2], 0), 0)
expect_equal(round(confint(fit)[2, 3], 1), 0.1)
expect_equal(round(confint(fit)[3, 2], 1), -0.1)
expect_equal(round(confint(fit)[3, 3], 1), 0.1)
})
where 19: eval(code, test_env)
where 20: eval(code, test_env)
where 21: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 27: tryCatchList(expr, classes, parentenv, handlers)
where 28: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 29: test_code(NULL, exprs, env)
where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 31: force(code)
where 32: doWithOneRestart(return(expr), restart)
where 33: withOneRestart(expr, restarts[[1L]])
where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 36: FUN(X[[i]], ...)
where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 38: force(code)
where 39: doWithOneRestart(return(expr), restart)
where 40: withOneRestart(expr, restarts[[1L]])
where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (object, parm, level = 0.95, type = "perc", invlogit = FALSE,
...)
{
cf <- coef(object, invlogit = invlogit)
pnames <- names(cf)
if (missing(parm)) {
parm <- pnames
}
else if (is.numeric(parm)) {
parm <- pnames[parm]
}
n.orig <- nrow(object@boot$t)
object@boot$t <- object@boot$t[complete.cases(object@boot$t),
]
n.ret <- nrow(object@boot$t)
perc <- 100 * (n.orig - n.ret)/n.orig
if (n.orig != n.ret) {
warning(paste0("Too little variation in the model. ",
n.orig - n.ret, " replications (", perc, "%) are dropped from CI estimation."))
}
if (invlogit == TRUE) {
object@boot$t <- apply(object@boot$t, 1:2, function(x) 1/(1 +
exp(-x)))
object@boot$t0 <- sapply(object@boot$t0, function(x) 1/(1 +
exp(-x)))
}
if (type == "perc") {
type2 <- "percent"
}
else if (type == "norm") {
type2 <- "normal"
}
else if (type == "basic") {
type2 <- "basic"
}
else if (type == "stud") {
type2 <- "student"
}
else if (type == "bca") {
type2 <- "bca"
}
else {
stop(paste("'type' not supported. Use 'perc', 'bca', 'norm', 'basic',",
"or 'stud'."))
}
ci <- sapply(1:length(cf), function(x) {
b <- boot::boot.ci(object@boot, conf = level, type = type,
index = x)
b[[type2]][4:5]
})
ci <- cbind(cf, t(ci))
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
ci <- ci[parm, ]
if (class(ci) != "matrix") {
ci <- matrix(ci, ncol = 3)
rownames(ci) <- parm
}
label1 <- paste0(100 * (1 - level)/2, "%")
label2 <- paste0(100 * (1 - (1 - level)/2), "%")
colnames(ci) <- c("Estimate", label1, label2)
return(ci)
}
<environment: namespace:btergm>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 1. Error: btergm estimation works (@test-btergm.R#48) ──────────────────────
the condition has length > 1
Backtrace:
1. testthat::expect_equal(round(confint(fit)[1, 2], 1), -1.4)
5. btergm::confint(fit)
6. btergm:::.local(object, parm, level, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
.local(object, parm, level, ...)
--- call from argument ---
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
--- R stacktrace ---
where 1: .local(object, parm, level, ...)
where 2: confint(fit)
where 3: confint(fit)
where 4: eval_bare(expr, quo_get_env(quo))
where 5: quasi_label(enquo(object), label, arg = "object")
where 6 at testthat/test-btergm.R#61: expect_equal(all(round(confint(fit), 4) == round(confint(fit2),
4)), TRUE)
where 7: eval(code, test_env)
where 8: eval(code, test_env)
where 9: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 10: doTryCatch(return(expr), name, parentenv, handler)
where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 13: doTryCatch(return(expr), name, parentenv, handler)
where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 15: tryCatchList(expr, classes, parentenv, handlers)
where 16: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 17: test_code(desc, code, env = parent.frame())
where 18 at testthat/test-btergm.R#56: test_that("fastglm works like speedglm", {
set.seed(12345)
fit <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, verbose = FALSE)
set.seed(12345)
fit2 <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, usefastglm = TRUE, verbose = FALSE)
expect_equal(all(round(confint(fit), 4) == round(confint(fit2),
4)), TRUE)
})
where 19: eval(code, test_env)
where 20: eval(code, test_env)
where 21: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 27: tryCatchList(expr, classes, parentenv, handlers)
where 28: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 29: test_code(NULL, exprs, env)
where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 31: force(code)
where 32: doWithOneRestart(return(expr), restart)
where 33: withOneRestart(expr, restarts[[1L]])
where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 36: FUN(X[[i]], ...)
where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 38: force(code)
where 39: doWithOneRestart(return(expr), restart)
where 40: withOneRestart(expr, restarts[[1L]])
where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (object, parm, level = 0.95, type = "perc", invlogit = FALSE,
...)
{
cf <- coef(object, invlogit = invlogit)
pnames <- names(cf)
if (missing(parm)) {
parm <- pnames
}
else if (is.numeric(parm)) {
parm <- pnames[parm]
}
n.orig <- nrow(object@boot$t)
object@boot$t <- object@boot$t[complete.cases(object@boot$t),
]
n.ret <- nrow(object@boot$t)
perc <- 100 * (n.orig - n.ret)/n.orig
if (n.orig != n.ret) {
warning(paste0("Too little variation in the model. ",
n.orig - n.ret, " replications (", perc, "%) are dropped from CI estimation."))
}
if (invlogit == TRUE) {
object@boot$t <- apply(object@boot$t, 1:2, function(x) 1/(1 +
exp(-x)))
object@boot$t0 <- sapply(object@boot$t0, function(x) 1/(1 +
exp(-x)))
}
if (type == "perc") {
type2 <- "percent"
}
else if (type == "norm") {
type2 <- "normal"
}
else if (type == "basic") {
type2 <- "basic"
}
else if (type == "stud") {
type2 <- "student"
}
else if (type == "bca") {
type2 <- "bca"
}
else {
stop(paste("'type' not supported. Use 'perc', 'bca', 'norm', 'basic',",
"or 'stud'."))
}
ci <- sapply(1:length(cf), function(x) {
b <- boot::boot.ci(object@boot, conf = level, type = type,
index = x)
b[[type2]][4:5]
})
ci <- cbind(cf, t(ci))
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
ci <- ci[parm, ]
if (class(ci) != "matrix") {
ci <- matrix(ci, ncol = 3)
rownames(ci) <- parm
}
label1 <- paste0(100 * (1 - level)/2, "%")
label2 <- paste0(100 * (1 - (1 - level)/2), "%")
colnames(ci) <- c("Estimate", label1, label2)
return(ci)
}
<bytecode: 0x15333bb8>
<environment: namespace:btergm>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 2. Error: fastglm works like speedglm (@test-btergm.R#61) ──────────────────
the condition has length > 1
Backtrace:
1. testthat::expect_equal(...)
5. btergm::confint(fit)
6. btergm:::.local(object, parm, level, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
.local(object, parm, level, ...)
--- call from argument ---
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
--- R stacktrace ---
where 1: .local(object, parm, level, ...)
where 2: confint(fit1)
where 3: confint(fit1)
where 4: eval_bare(expr, quo_get_env(quo))
where 5: quasi_label(enquo(object), label, arg = "object")
where 6 at testthat/test-btergm.R#77: expect_equal(confint(fit1), confint(fit2))
where 7: eval(code, test_env)
where 8: eval(code, test_env)
where 9: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 10: doTryCatch(return(expr), name, parentenv, handler)
where 11: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 12: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 13: doTryCatch(return(expr), name, parentenv, handler)
where 14: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 15: tryCatchList(expr, classes, parentenv, handlers)
where 16: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 17: test_code(desc, code, env = parent.frame())
where 18 at testthat/test-btergm.R#64: test_that("offset argument in btergm works without composition change",
{
set.seed(12345)
fit1 <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, offset = FALSE, usefastglm = TRUE, verbose = FALSE)
set.seed(12345)
fit2 <- btergm(networks ~ edges + istar(2) + edgecov(covariates),
R = 100, offset = TRUE, usefastglm = TRUE, verbose = FALSE)
expect_equal(confint(fit1), confint(fit2))
})
where 19: eval(code, test_env)
where 20: eval(code, test_env)
where 21: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 22: doTryCatch(return(expr), name, parentenv, handler)
where 23: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 24: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 27: tryCatchList(expr, classes, parentenv, handlers)
where 28: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 29: test_code(NULL, exprs, env)
where 30: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 31: force(code)
where 32: doWithOneRestart(return(expr), restart)
where 33: withOneRestart(expr, restarts[[1L]])
where 34: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 35: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 36: FUN(X[[i]], ...)
where 37: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 38: force(code)
where 39: doWithOneRestart(return(expr), restart)
where 40: withOneRestart(expr, restarts[[1L]])
where 41: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 42: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 43: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 44: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 45: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (object, parm, level = 0.95, type = "perc", invlogit = FALSE,
...)
{
cf <- coef(object, invlogit = invlogit)
pnames <- names(cf)
if (missing(parm)) {
parm <- pnames
}
else if (is.numeric(parm)) {
parm <- pnames[parm]
}
n.orig <- nrow(object@boot$t)
object@boot$t <- object@boot$t[complete.cases(object@boot$t),
]
n.ret <- nrow(object@boot$t)
perc <- 100 * (n.orig - n.ret)/n.orig
if (n.orig != n.ret) {
warning(paste0("Too little variation in the model. ",
n.orig - n.ret, " replications (", perc, "%) are dropped from CI estimation."))
}
if (invlogit == TRUE) {
object@boot$t <- apply(object@boot$t, 1:2, function(x) 1/(1 +
exp(-x)))
object@boot$t0 <- sapply(object@boot$t0, function(x) 1/(1 +
exp(-x)))
}
if (type == "perc") {
type2 <- "percent"
}
else if (type == "norm") {
type2 <- "normal"
}
else if (type == "basic") {
type2 <- "basic"
}
else if (type == "stud") {
type2 <- "student"
}
else if (type == "bca") {
type2 <- "bca"
}
else {
stop(paste("'type' not supported. Use 'perc', 'bca', 'norm', 'basic',",
"or 'stud'."))
}
ci <- sapply(1:length(cf), function(x) {
b <- boot::boot.ci(object@boot, conf = level, type = type,
index = x)
b[[type2]][4:5]
})
ci <- cbind(cf, t(ci))
if (class(ci) == "numeric") {
ci.nam <- names(ci)
ci <- matrix(ci, nrow = 1)
colnames(ci) <- ci.nam
rownames(ci) <- names(cf)
}
ci <- ci[parm, ]
if (class(ci) != "matrix") {
ci <- matrix(ci, ncol = 3)
rownames(ci) <- parm
}
label1 <- paste0(100 * (1 - level)/2, "%")
label2 <- paste0(100 * (1 - (1 - level)/2), "%")
colnames(ci) <- c("Estimate", label1, label2)
return(ci)
}
<bytecode: 0x15333bb8>
<environment: namespace:btergm>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 3. Error: offset argument in btergm works without composition change (@test-b
the condition has length > 1
Backtrace:
1. testthat::expect_equal(confint(fit1), confint(fit2))
5. btergm::confint(fit1)
6. btergm:::.local(object, parm, level, ...)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
NULL
--- call from argument ---
if (type %in% c("matrix", "network", "dgCMatrix", "dgTMatrix",
"dsCMatrix", "dsTMatrix", "dgeMatrix")) {
if (!type %in% c("matrix", "network")) {
x.current <- as.matrix(x.current)
}
l[[x2]] <- list()
for (i in 1:l$time.steps) {
l[[x2]][[i]] <- x.current
}
if (blockdiag == TRUE) {
}
else {
x2 <- paste0(x2, "[[i]]")
}
l$rhs.terms[k] <- paste(x1, x2, x3, sep = "")
} else if (type == "list" || type == "network.list") {
if (length(x.current) != l$time.steps) {
stop(paste(x2, "has", length(get(x2)), "elements, but there are",
l$time.steps, "networks to be modeled."))
}
if (blockdiag == TRUE) {
}
else {
x2 <- paste0(x2, "[[i]]")
}
l$rhs.terms[k] <- paste0(x1, x2, x3)
} else {
tryCatch({
l[[x2]] <- list(rep(as.matrix(x.current)), l$time.steps)
}, error = function(cond) {
stop(paste0("Object '", x2, "' could not be converted to a matrix."))
})
}
--- R stacktrace ---
where 1: tergmprepare(formula = formula, offset = offset, verbose = verbose)
where 2 at testthat/test-btergm.R#115: btergm(friendship ~ edges + mutual + ttriple + transitiveties +
ctriple + nodeicov("idegsqrt") + nodeicov("odegsqrt") + nodeocov("odegsqrt") +
nodeofactor("sex") + nodeifactor("sex") + nodematch("sex") +
edgecov(primary) + delrecip + memory(type = "stability"),
R = 100, usefastglm = TRUE, offset = TRUE, verbose = FALSE)
where 3: eval(code, test_env)
where 4: eval(code, test_env)
where 5: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 6: doTryCatch(return(expr), name, parentenv, handler)
where 7: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 8: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 9: doTryCatch(return(expr), name, parentenv, handler)
where 10: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 11: tryCatchList(expr, classes, parentenv, handlers)
where 12: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 13: test_code(desc, code, env = parent.frame())
where 14 at testthat/test-btergm.R#80: test_that("offset argument in btergm works with composition change",
{
require("sna")
data("knecht")
for (i in 1:length(friendship)) {
rownames(friendship[[i]]) <- 1:nrow(friendship[[i]])
colnames(friendship[[i]]) <- 1:ncol(friendship[[i]])
}
rownames(primary) <- rownames(friendship[[1]])
colnames(primary) <- colnames(friendship[[1]])
sex <- demographics$sex
names(sex) <- 1:length(sex)
suppressMessages(friendship <- handleMissings(friendship,
na = 10, method = "remove"))
suppressMessages(friendship <- handleMissings(friendship,
na = NA, method = "fillmode"))
for (i in 1:length(friendship)) {
s <- adjust(sex, friendship[[i]])
friendship[[i]] <- network(friendship[[i]])
friendship[[i]] <- set.vertex.attribute(friendship[[i]],
"sex", s)
idegsqrt <- sqrt(degree(friendship[[i]], cmode = "indegree"))
friendship[[i]] <- set.vertex.attribute(friendship[[i]],
"idegsqrt", idegsqrt)
odegsqrt <- sqrt(degree(friendship[[i]], cmode = "outdegree"))
friendship[[i]] <- set.vertex.attribute(friendship[[i]],
"odegsqrt", odegsqrt)
}
expect_equal(unname(sapply(friendship, network.size)),
c(26, 26, 25, 25))
set.seed(12345)
m1 <- btergm(friendship ~ edges + mutual + ttriple +
transitiveties + ctriple + nodeicov("idegsqrt") +
nodeicov("odegsqrt") + nodeocov("odegsqrt") + nodeofactor("sex") +
nodeifactor("sex") + nodematch("sex") + edgecov(primary) +
delrecip + memory(type = "stability"), R = 100, usefastglm = TRUE,
offset = TRUE, verbose = FALSE)
m2 <- btergm(friendship ~ edges + mutual + ttriple +
transitiveties + ctriple + nodeicov("idegsqrt") +
nodeicov("odegsqrt") + nodeocov("odegsqrt") + nodeofactor("sex") +
nodeifactor("sex") + nodematch("sex") + edgecov(primary) +
delrecip + memory(type = "stability"), R = 100, usefastglm = TRUE,
offset = FALSE, verbose = FALSE)
expect_equal(dim(confint(m1)), c(14, 3))
expect_equal(dim(confint(m2)), c(14, 3))
expect_equal(all(confint(m1)[, 3] - confint(m1)[, 2] >
0), TRUE)
expect_equal(all(confint(m2)[, 3] - confint(m2)[, 2] >
0), TRUE)
expect_equal(m1@offset, TRUE)
expect_equal(m2@offset, FALSE)
expect_equal(sapply(m1@data$offsmat, sum), c(0, 51, 51))
expect_equal(sapply(m2@data$offsmat, sum), c(0, 0, 0))
expect_equal(unname(nobs(m1)), c(3, 1850, 100))
expect_equal(nobs(m1), nobs(m2))
})
where 15: eval(code, test_env)
where 16: eval(code, test_env)
where 17: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 18: doTryCatch(return(expr), name, parentenv, handler)
where 19: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 20: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 21: doTryCatch(return(expr), name, parentenv, handler)
where 22: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 23: tryCatchList(expr, classes, parentenv, handlers)
where 24: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 25: test_code(NULL, exprs, env)
where 26: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 27: force(code)
where 28: doWithOneRestart(return(expr), restart)
where 29: withOneRestart(expr, restarts[[1L]])
where 30: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 31: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 32: FUN(X[[i]], ...)
where 33: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 34: force(code)
where 35: doWithOneRestart(return(expr), restart)
where 36: withOneRestart(expr, restarts[[1L]])
where 37: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 38: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 39: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 40: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 41: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 42: test_check("btergm")
--- value of length: 2 type: logical ---
[1] TRUE FALSE
--- function from context ---
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 4. Error: offset argument in btergm works with composition change (@test-bter
the condition has length > 1
Backtrace:
1. btergm::btergm(...)
2. btergm:::tergmprepare(formula = formula, offset = offset, verbose = verbose)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x286cca8>
<environment: 0x81d4338>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x286cca8>
<environment: 0x176e7578>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x286cca8>
<environment: 0x1acb8d78>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x286cca8>
<environment: 0x32127b68>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
btergm
--- call from context ---
doTryCatch(return(expr), name, parentenv, handler)
--- call from argument ---
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
--- R stacktrace ---
where 1: doTryCatch(return(expr), name, parentenv, handler)
where 2: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 3: tryCatchList(expr, classes, parentenv, handlers)
where 4: tryCatch(expr = {
label <- suppressMessages(attributes(statistics[[z]](simulations[[1]])))$label
if (verbose == TRUE) {
message(paste("Processing statistic:", label))
}
if (parallel[1] == "no") {
simulated <- suppressMessages(sapply(simulations, statistics[[z]],
...))
observed <- suppressMessages(sapply(target, statistics[[z]],
...))
}
else if (parallel[1] == "multicore") {
test <- suppressMessages(statistics[[z]](simulations[[1]]))
if (class(test) == "numeric" && length(test) == 1) {
simulated <- suppressMessages(unlist(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus)))
observed <- suppressMessages(unlist(mclapply(target,
statistics[[z]], ..., mc.cores = ncpus)))
}
else {
simulated <- suppressMessages(mclapply(simulations,
statistics[[z]], ..., mc.cores = ncpus))
observed <- suppressMessages(mclapply(target, statistics[[z]],
..., mc.cores = ncpus))
max.length.sim <- max(sapply(simulated, length),
na.rm = TRUE)
max.length.obs <- max(sapply(observed, length), na.rm = TRUE)
max.length <- max(max.length.sim, max.length.obs,
na.rm = TRUE)
simulated <- sapply(simulated, function(x) {
c(x, rep(0, max.length - length(x)))
})
observed <- sapply(observed, function(x) {
c(x, rep(0, max.length - length(x)))
})
}
}
else {
clusterEvalQ(cl, library("ergm"))
clusterEvalQ(cl, library("xergm.common"))
simulated <- suppressMessages(parSapply(cl = cl, simulations,
statistics[[z]], ...))
observed <- suppressMessages(parSapply(cl = cl, target,
statistics[[z]], ...))
}
if (class(simulated) == "list") {
lengths <- sapply(simulated, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(simulated[[index]])
simulated <- sapply(simulated, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(simulated) <- rn
}
if (class(observed) == "list") {
lengths <- sapply(observed, length)
l <- max(lengths)
index <- which(lengths == l)[1]
rn <- names(observed[[index]])
observed <- sapply(observed, function(x) {
c(x, rep(0, l - length(x)))
})
rownames(observed) <- rn
}
gofobject <- list()
gofobject$label <- label
if (class(simulated) == "matrix") {
reduced <- reduce.matrix(simulated, observed)
gofobject$type <- "boxplot"
gofobject$stats <- reduced$comparison
gofobject$raw <- Matrix::Matrix(as.matrix(reduced$sim))
class(gofobject) <- "boxplot"
}
else if (class(simulated) == "numeric") {
gofobject$type <- "univariate"
gofobject$obs <- observed
gofobject$sim <- simulated
class(gofobject) <- "univariate"
}
goflist[[length(goflist) + 1]] <- gofobject
names(goflist)[length(goflist)] <- label
}, error = function(e) {
if (verbose == TRUE) {
cat(paste(" Skipping statistic for the following reason:",
e))
}
}, finally = {
})
where 5: createGOF(simulations = simulations, target = target, statistics = statistics,
parallel = parallel, ncpus = ncpus, cl = cl, verbose = verbose,
... = ...)
where 6: .local(object, ...)
where 7: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 8 at testthat/test-gof.R#24: gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500, verbose = FALSE)
where 9: eval(code, test_env)
where 10: eval(code, test_env)
where 11: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 12: doTryCatch(return(expr), name, parentenv, handler)
where 13: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 14: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 15: doTryCatch(return(expr), name, parentenv, handler)
where 16: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 17: tryCatchList(expr, classes, parentenv, handlers)
where 18: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 19: test_code(desc, code, env = parent.frame())
where 20 at testthat/test-gof.R#23: test_that("basic GOF functionality works", {
g <- gof(fit, nsim = 2, MCMC.burnin = 1000, MCMC.interval = 500,
verbose = FALSE)
expect_equal(length(g), 7)
expect_equal(class(g), "gof")
})
where 21: eval(code, test_env)
where 22: eval(code, test_env)
where 23: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 24: doTryCatch(return(expr), name, parentenv, handler)
where 25: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 26: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 27: doTryCatch(return(expr), name, parentenv, handler)
where 28: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 29: tryCatchList(expr, classes, parentenv, handlers)
where 30: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 31: test_code(NULL, exprs, env)
where 32: source_file(path, new.env(parent = env), chdir = TRUE, wrap = wrap)
where 33: force(code)
where 34: doWithOneRestart(return(expr), restart)
where 35: withOneRestart(expr, restarts[[1L]])
where 36: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 37: with_reporter(reporter = reporter, start_end_reporter = start_end_reporter,
{
reporter$start_file(basename(path))
lister$start_file(basename(path))
source_file(path, new.env(parent = env), chdir = TRUE,
wrap = wrap)
reporter$.end_context()
reporter$end_file()
})
where 38: FUN(X[[i]], ...)
where 39: lapply(paths, test_file, env = env, reporter = current_reporter,
start_end_reporter = FALSE, load_helpers = FALSE, wrap = wrap)
where 40: force(code)
where 41: doWithOneRestart(return(expr), restart)
where 42: withOneRestart(expr, restarts[[1L]])
where 43: withRestarts(testthat_abort_reporter = function() NULL, force(code))
where 44: with_reporter(reporter = current_reporter, results <- lapply(paths,
test_file, env = env, reporter = current_reporter, start_end_reporter = FALSE,
load_helpers = FALSE, wrap = wrap))
where 45: test_files(paths, reporter = reporter, env = env, stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 46: test_dir(path = test_path, reporter = reporter, env = env, filter = filter,
..., stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap)
where 47: test_package_dir(package = package, test_path = test_path, filter = filter,
reporter = reporter, ..., stop_on_failure = stop_on_failure,
stop_on_warning = stop_on_warning, wrap = wrap)
where 48: test_check("btergm")
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (expr, name, parentenv, handler)
{
.Internal(.addCondHands(name, list(handler), parentenv, environment(),
FALSE))
expr
}
<bytecode: 0x286cca8>
<environment: 0x35a11818>
--- function search by body ---
----------- END OF FAILURE REPORT --------------
── 5. Failure: basic GOF functionality works (@test-gof.R#25) ─────────────────
length(g) not equal to 7.
1/1 mismatches
[1] 2 - 7 == -5
══ testthat results ═══════════════════════════════════════════════════════════
[ OK: 36 | SKIPPED: 0 | WARNINGS: 52 | FAILED: 5 ]
1. Error: btergm estimation works (@test-btergm.R#48)
2. Error: fastglm works like speedglm (@test-btergm.R#61)
3. Error: offset argument in btergm works without composition change (@test-btergm.R#77)
4. Error: offset argument in btergm works with composition change (@test-btergm.R#115)
5. Failure: basic GOF functionality works (@test-gof.R#25)
Error: testthat unit tests failed
Execution halted
Flavor: r-devel-linux-x86_64-fedora-gcc
Version: 1.9.4
Check: dependencies in R code
Result: NOTE
No protocol specified
No protocol specified
Flavor: r-oldrel-osx-x86_64
Version: 1.9.4
Check: S3 generic/method consistency
Result: WARN
No protocol specified
No protocol specified
See section ‘Generic functions and methods’ in the ‘Writing R
Extensions’ manual.
Flavor: r-oldrel-osx-x86_64
Version: 1.9.4
Check: replacement functions
Result: WARN
No protocol specified
No protocol specified
The argument of a replacement function which corresponds to the right
hand side must be named ‘value’.
Flavor: r-oldrel-osx-x86_64
Version: 1.9.4
Check: foreign function calls
Result: NOTE
No protocol specified
No protocol specified
See chapter ‘System and foreign language interfaces’ in the ‘Writing R
Extensions’ manual.
Flavor: r-oldrel-osx-x86_64
Version: 1.9.4
Check: R code for possible problems
Result: NOTE
No protocol specified
No protocol specified
Flavor: r-oldrel-osx-x86_64
Version: 1.9.4
Check: for missing documentation entries
Result: WARN
No protocol specified
No protocol specified
All user-level objects in a package should have documentation entries.
See chapter ‘Writing R documentation files’ in the ‘Writing R
Extensions’ manual.
Flavor: r-oldrel-osx-x86_64
Version: 1.9.4
Check: for code/documentation mismatches
Result: WARN
No protocol specified
No protocol specified
No protocol specified
No protocol specified
No protocol specified
No protocol specified
Flavor: r-oldrel-osx-x86_64
Version: 1.9.4
Check: Rd \usage sections
Result: NOTE
No protocol specified
No protocol specified
The \usage entries for S3 methods should use the \method markup and not
their full name.
See chapter ‘Writing R documentation files’ in the ‘Writing R
Extensions’ manual.
Flavor: r-oldrel-osx-x86_64