Last updated on 2025-01-09 01:49:42 CET.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 0.15.3 | OK | --no-tests | |||
| r-devel-linux-x86_64-debian-gcc | 0.15.3 | 133.52 | 67.98 | 201.50 | OK | --no-tests |
| r-devel-linux-x86_64-fedora-clang | 0.15.3 | 858.06 | ERROR | |||
| r-devel-linux-x86_64-fedora-gcc | 0.15.3 | 1142.41 | ERROR | |||
| r-devel-windows-x86_64 | 0.15.3 | 140.00 | 489.00 | 629.00 | ERROR | |
| r-patched-linux-x86_64 | 0.15.3 | 188.64 | 94.56 | 283.20 | OK | --no-tests |
| r-release-linux-x86_64 | 0.15.3 | 179.26 | 93.90 | 273.16 | OK | --no-tests |
| r-release-macos-arm64 | 0.15.3 | 208.00 | NOTE | |||
| r-release-macos-x86_64 | 0.15.3 | 685.00 | NOTE | |||
| r-release-windows-x86_64 | 0.15.3 | 149.00 | 461.00 | 610.00 | NOTE | |
| r-oldrel-macos-arm64 | 0.15.3 | 253.00 | NOTE | |||
| r-oldrel-macos-x86_64 | 0.15.3 | 533.00 | NOTE | |||
| r-oldrel-windows-x86_64 | 0.15.3 | 188.00 | 577.00 | 765.00 | NOTE |
Version: 0.15.3
Check: tests
Result: ERROR
Running ‘coef.R’ [8s/18s]
Running ‘confint.R’ [50s/129s]
Running ‘datetime.R’
Running ‘egf.R’ [7s/24s]
Running ‘egf_enum.R’
Running ‘egf_eval.R’
Running ‘egf_examples_day_of_week.R’
Running ‘egf_examples_excess.R’
Running ‘egf_examples_fixed.R’ [4s/12s]
Running ‘egf_examples_random.R’ [115s/178s]
Running ‘egf_link.R’
Running ‘egf_misc.R’ [8s/21s]
Running ‘egf_options.R’
Running ‘egf_utils.R’ [8s/20s]
Running ‘epidemic.R’
Running ‘extract.R’ [8s/20s]
Running ‘fitted.R’ [7s/21s]
Running ‘gi.R’ [4s/12s]
Running ‘include.R’ [159s/421s]
Running ‘language.R’
Running ‘prior.R’
Running ‘profile.R’ [30s/117s]
Running ‘summary.R’ [8s/21s]
Running ‘utils.R’
Running ‘validity.R’
Running ‘zzz.R’
Running the tests in ‘tests/egf_utils.R’ failed.
Complete output:
> attach(asNamespace("epigrowthfit"))
> library(methods)
> library(tools)
> options(warn = 2L, error = if (interactive()) recover)
> example("egf", package = "epigrowthfit"); o.1 <- m1; o.2 <- m2
egf> ## Simulate 'N' incidence time series exhibiting exponential growth
egf> set.seed(180149L)
egf> N <- 10L
egf> f <- function(time, r, c0) {
egf+ lambda <- diff(exp(log(c0) + r * time))
egf+ c(NA, rpois(lambda, lambda))
egf+ }
egf> time <- seq.int(0, 40, 1)
egf> r <- rlnorm(N, -3.2, 0.2)
egf> c0 <- rlnorm(N, 6, 0.2)
egf> data_ts <-
egf+ data.frame(country = gl(N, length(time), labels = LETTERS[1:N]),
egf+ time = rep.int(time, N),
egf+ x = unlist(Map(f, time = list(time), r = r, c0 = c0)))
egf> rm(f, time)
egf> ## Define fitting windows (here, two per time series)
egf> data_windows <-
egf+ data.frame(country = gl(N, 1L, 2L * N, labels = LETTERS[1:N]),
egf+ wave = gl(2L, 10L),
egf+ start = c(sample(seq.int(0, 5, 1), N, TRUE),
egf+ sample(seq.int(20, 25, 1), N, TRUE)),
egf+ end = c(sample(seq.int(15, 20, 1), N, TRUE),
egf+ sample(seq.int(35, 40, 1), N, TRUE)))
egf> ## Estimate the generative model
egf> m1 <-
egf+ egf(model = egf_model(curve = "exponential", family = "pois"),
egf+ formula_ts = cbind(time, x) ~ country,
egf+ formula_windows = cbind(start, end) ~ country,
egf+ formula_parameters = ~(1 | country:wave),
egf+ data_ts = data_ts,
egf+ data_windows = data_windows,
egf+ se = TRUE)
computing a Hessian matrix ...
egf> ## Re-estimate the generative model with:
egf> ## * Gaussian prior on beta[1L]
egf> ## * LKJ prior on all random effect covariance matrices
egf> ## (here there happens to be just one)
egf> ## * initial value of 'theta' set explicitly
egf> ## * theta[3L] fixed at initial value
egf> m2 <-
egf+ update(m1,
egf+ formula_priors = list(beta[1L] ~ Normal(mu = -3, sigma = 1),
egf+ Sigma ~ LKJ(eta = 2)),
egf+ init = list(theta = c(log(0.5), log(0.5), 0)),
egf+ map = list(theta = 3L))
computing a Hessian matrix ...
>
>
> ## egf_sanitize_formula_ts ########################################
> ## egf_sanitize_formula_windows ########################################
>
> l1 <- list(cbind(x, y) ~ 1,
+ cbind(x, y) ~ g,
+ cbind(x, y) ~ 1 + g,
+ cbind(x, y) ~ (g),
+ cbind(x, y) ~ g:h,
+ cbind(x, y) ~ I(g + h),
+ cbind(x, y) ~ I(g * h),
+ cbind(x - 1, cumsum(y)) ~ g)
> l2 <- list(~g,
+ cbind(x, y) ~ g + h,
+ cbind(x, y) ~ g * h,
+ cbind(x, y) ~ 0 + g,
+ cbind(x, y) ~ g - 1,
+ cbind(x, y) ~ offset(h) + g,
+ (cbind(x, y)) ~ g,
+ cbind(x) ~ g,
+ cbind(x, y, z) ~ g,
+ rbind(x, y) ~ g) # i.e., anything other than 'cbind'
>
> stopifnot(identical(lapply(l1, egf_sanitize_formula_ts),
+ l1[c(1L, 2L, 2L, 2L, 5:8)]))
> for (formula in l2)
+ assertError(egf_sanitize_formula_ts(formula))
>
>
> ## egf_sanitize_formula_parameters #####################################
>
> model <- egf_model(curve = "exponential", family = "pois")
> top <- egf_top(model)
>
> s <-
+ function(formula)
+ egf_sanitize_formula_parameters(formula, top, check = TRUE)
>
> fp1 <- ~x * y + (z | g) + (zz | g/h)
> l1 <- rep.int(expr(simplify_terms(fp1)), 2L)
> names(l1) <- c("log(r)", "log(c0)")
>
> fp2 <- expr(replace(fp1, 2:3, expr(quote(log(r)), fp1[[2L]])))
> l2 <- replace(l1, "log(c0)", expr(~1))
>
> fp3 <- c(fp2, expr(log(c0) ~ x))
> l3 <- replace(l2, "log(c0)", expr(~x))
>
> stopifnot(exprs = {
+ identical(s(fp1), l1)
+ identical(s(fp2), l2)
+ identical(s(fp3), l3)
+ })
> assertWarning(s(~0 + x))
>
>
> ## egf_sanitize_formula_priors #########################################
>
> p1 <- Normal(mu = 0, sigma = 1)
> p2 <- Normal(mu = 1, sigma = c(0.5, 1))
> p3 <- Normal(mu = -1, sigma = 2)
> p4 <- LKJ(eta = 1)
>
> fp. <- list(foo(bar) ~ p1,
+ baz ~ p1,
+ beta ~ p1,
+ theta[[1L]] ~ p1,
+ theta[2:3] ~ p2,
+ theta[-(1:5)] ~ p3,
+ theta[replace(logical(6L), 4L, TRUE)] ~ p1,
+ Sigma ~ p4)
>
> ip. <- list(
+ top = list(names = c("foo(bar)", "baz"), family = "norm"),
+ bottom = list(
+ beta = list(length = 4L, family = "norm"),
+ theta = list(length = 6L, family = "norm"),
+ Sigma = list(length = 1L, family = c("lkj", "wishart", "invwishart"),
+ rows = 4L)))
>
> priors <- egf_sanitize_formula_priors(formula = fp., info = ip.)
>
> p2.elt <-
+ function(i) {
+ p2[["parameters"]][["sigma"]] <- p2[["parameters"]][["sigma"]][[i]]
+ p2
+ }
>
> stopifnot(exprs = {
+ is.list(priors)
+ length(priors) == 2L
+ identical(names(priors), c("top", "bottom"))
+
+ identical(priors[["top"]],
+ `names<-`(list(p1, p1), ip.[["top"]][["names"]]))
+ identical(priors[["bottom"]],
+ list(beta = list(p1, p1, p1, p1),
+ theta = list(p1, p2.elt(1L), p2.elt(2L), p1, NULL, p3),
+ Sigma = list(p4)))
+ })
>
>
> ## egf_make_frame ######################################################
>
> model <- egf_model(curve = "exponential", family = "pois")
>
> formula_ts <- cbind(day, count) ~ country
> formula_windows <- cbind(left, right) ~ country
> formula_parameters <- list(`log(r)` = ~x1 + (1 | g1) + (1 | g1:g2),
+ `log(c0)` = ~(1 | g3))
>
> data_ts <- data.frame(country = gl(6L, 11L),
+ day = seq.int(0, 10, by = 1),
+ count = rpois(11L, 100 * exp(0.04 * 0:10)))
> data_windows <- data.frame(country = gl(3L, 2L),
+ left = rep.int(c(0, 5), 3L),
+ right = rep.int(c(5, 10), 3L),
+ x1 = c(5.00, 8.34, -0.57, -7.19, -9.71, 1.25),
+ x2 = rnorm(6L),
+ x3 = rnorm(6L),
+ g1 = c("a", "b", "b", "b", "b", "a"),
+ g2 = c("c", "d", "d", "d", "c", "c"),
+ g3 = c("f", "f", "e", "e", "e", "f"))
>
> subset_ts <- quote(day > 0)
> subset_windows <- quote(x1 < 0)
> select_windows <- quote(.)
>
> na_action_ts <- "pass"
> na_action_windows <- "omit"
>
> frame <- egf_make_frame(model = model,
+ formula_ts = formula_ts,
+ formula_windows = formula_windows,
+ formula_parameters = formula_parameters,
+ data_ts = data_ts,
+ data_windows = data_windows,
+ subset_ts = subset_ts,
+ subset_windows = subset_windows,
+ select_windows = select_windows,
+ na_action_ts = na_action_ts,
+ na_action_windows = na_action_windows)
>
> stopifnot(exprs = {
+ is.list(frame)
+ length(frame) == 4L
+ identical(names(frame), c("ts", "windows", "parameters", "extra"))
+ })
>
> l1 <- frame[["ts"]]
> l1.e <- data.frame(ts = gl(2L, 10L, labels = 2:3),
+ window = factor(rep.int(c(NA, 1, 2, NA, 3, NA),
+ c(1L, 4L, 5L, 1L, 4L, 5L)),
+ labels = sprintf("window_%d", 1:3)),
+ time = rep.int(seq.int(1, 10, by = 1), 2L),
+ x = data_ts[["count"]][c(NA, 14:22, NA, 25:33)])
> attr(l1.e, "first") <- c(1L, 5L, 11L)
> attr(l1.e, "last") <- c(5L, 10L, 15L)
> stopifnot(identical(l1, l1.e))
>
> l2 <- frame[["windows"]]
> l2.e <- data.frame(ts = factor(c(2, 2, 3)),
+ window = gl(3L, 1L, labels = sprintf("window_%d", 1:3)),
+ start = c(1, 5, 1),
+ end = c(5, 10, 5))
> stopifnot(identical(l2, l2.e))
Error: identical(l2, l2.e) is not TRUE
Execution halted
Flavor: r-devel-linux-x86_64-fedora-clang
Version: 0.15.3
Check: tests
Result: ERROR
Running ‘coef.R’ [8s/20s]
Running ‘confint.R’ [58s/190s]
Running ‘datetime.R’
Running ‘egf.R’ [7s/18s]
Running ‘egf_enum.R’
Running ‘egf_eval.R’
Running ‘egf_examples_day_of_week.R’
Running ‘egf_examples_excess.R’
Running ‘egf_examples_fixed.R’ [4s/10s]
Running ‘egf_examples_random.R’ [102s/162s]
Running ‘egf_link.R’
Running ‘egf_misc.R’ [9s/22s]
Running ‘egf_options.R’
Running ‘egf_utils.R’ [8s/20s]
Running ‘epidemic.R’
Running ‘extract.R’ [8s/19s]
Running ‘fitted.R’ [8s/20s]
Running ‘gi.R’
Running ‘include.R’ [5m/12m]
Running ‘language.R’
Running ‘prior.R’
Running ‘profile.R’ [33s/126s]
Running ‘summary.R’ [8s/27s]
Running ‘utils.R’ [3s/10s]
Running ‘validity.R’
Running ‘zzz.R’
Running the tests in ‘tests/egf_examples_random.R’ failed.
Complete output:
> library(epigrowthfit)
> options(warn = 2L, error = if (interactive()) recover, egf.cores = 2L)
>
>
> ## exponential #########################################################
>
> r <- log(2) / 20
> c0 <- 100
> s <- 0.2
>
> mu <- log(c(r, c0))
> Sigma <- diag(rep.int(s^2, length(mu)))
>
> zz <- simulate(egf_model(curve = "exponential", family = "pois"),
+ nsim = 20L,
+ seed = 775494L,
+ mu = mu,
+ Sigma = Sigma,
+ cstart = 10)
> mm <- egf(zz,
+ formula_priors = list(Sigma ~ LKJ(eta = 2)))
>
> p1 <- as.list(coef(zz))
> p2 <- as.list(coef(mm))
>
> stopifnot(exprs = {
+ max(abs(mm[["gradient"]])) < 5e-05
+ all.equal(p1[["beta"]], p2[["beta"]], tolerance = 5e-02)
+ all.equal(theta2cov(p1[["theta"]]), theta2cov(p2[["theta"]]), tolerance = 5e-02)
+ })
>
>
> ## subexponential ######################################################
>
> alpha <- log(2) / 20
> c0 <- 100
> p <- 0.95
> s <- 0.2
>
> mu <- c(log(alpha), log(c0), qlogis(p))
> Sigma <- diag(rep.int(s^2, length(mu)))
>
> zz <- simulate(egf_model(curve = "subexponential", family = "pois"),
+ nsim = 20L,
+ seed = 653927L,
+ mu = mu,
+ Sigma = Sigma,
+ cstart = 10)
> mm <- egf(zz,
+ formula_priors = list(beta[3L] ~ Normal(mu = qlogis(p), sigma = 0.05),
+ theta[3L] ~ Normal(mu = log(s), sigma = 0.25),
+ Sigma ~ LKJ(eta = 2)))
>
> p1 <- as.list(coef(zz))
> p2 <- as.list(coef(mm))
>
> stopifnot(exprs = {
+ max(abs(mm[["gradient"]])) < 5e-04
+ all.equal(p1[["beta"]], p2[["beta"]], tolerance = 5e-02)
+ all.equal(theta2cov(p1[["theta"]]), theta2cov(p2[["theta"]]), tolerance = 2e-02)
+ })
>
>
> ## gompertz ############################################################
>
> alpha <- log(2) / 20
> tinfl <- 100
> K <- 25000
> s <- 0.2
>
> mu <- log(c(alpha, tinfl, K))
> Sigma <- diag(rep.int(s^2, length(mu)))
>
> zz <- simulate(egf_model(curve = "gompertz", family = "pois"),
+ nsim = 20L,
+ seed = 685399L,
+ mu = mu,
+ Sigma = Sigma,
+ cstart = 10)
> oo <- options(warn = 1L) # FIXME: diagnose NA/NaN function evaluation
> mm <- egf(zz,
+ formula_priors = list(Sigma ~ LKJ(eta = 2)))
Warning in nlminb(start = par, objective = fn, gradient = gr, control = control, :
NA/NaN function evaluation
> options(oo)
>
> p1 <- as.list(coef(zz))
> p2 <- as.list(coef(mm))
>
> stopifnot(exprs = {
+ max(abs(mm[["gradient"]])) < 5e-04
+ all.equal(p1[["beta"]], p2[["beta"]], tolerance = 5e-02)
+ all.equal(theta2cov(p1[["theta"]]), theta2cov(p2[["theta"]]), tolerance = 2e-02)
+ })
>
>
> ## logistic ############################################################
>
> r <- log(2) / 20
> tinfl <- 100
> K <- 25000
> s <- 0.2
>
> mu <- log(c(r, tinfl, K))
> Sigma <- diag(rep.int(s^2, length(mu)))
>
> zz <- simulate(egf_model(curve = "logistic", family = "pois"),
+ nsim = 20L,
+ seed = 397981L,
+ mu = mu,
+ Sigma = Sigma,
+ cstart = 10)
> mm <- egf(zz,
+ formula_priors = list(Sigma ~ LKJ(eta = 2)))
>
> p1 <- as.list(coef(zz))
> p2 <- as.list(coef(mm))
>
> stopifnot(exprs = {
+ max(abs(mm[["gradient"]])) < 1e-02
+ all.equal(p1[["beta"]], p2[["beta"]], tolerance = 1e-02)
+ all.equal(theta2cov(p1[["theta"]]), theta2cov(p2[["theta"]]), tolerance = 2e-02)
+ })
>
>
> ## richards ############################################################
>
> r <- log(2) / 20
> tinfl <- 100
> K <- 25000
> a <- 1.005
> s <- 0.2
>
> mu <- log(c(r, tinfl, K, a))
> Sigma <- diag(rep.int(s^2, length(mu)))
>
> zz <- simulate(egf_model(curve = "richards", family = "pois"),
+ nsim = 20L,
+ seed = 949642L,
+ mu = mu,
+ Sigma = Sigma,
+ cstart = 10)
> mm <- egf(zz,
+ formula_priors = list(beta[4L] ~ Normal(mu = log(a), sigma = 0.005),
+ theta[4L] ~ Normal(mu = log(s), sigma = 0.25),
+ Sigma ~ LKJ(eta = 2)))
*** caught segfault ***
address 0x1, cause 'memory not mapped'
Error in c$call : use of NULL environment is defunct
Calls: egf ... <Anonymous> -> conditionCall -> conditionCall.condition -> $
Error: no more error handlers available (recursive errors?); invoking 'abort' restart
Execution halted
Error in config(nthreads = n, DLL = DLL) : bad value
Calls: egf ... do.call -> <Anonymous> -> egf.egf_model -> openmp -> config
Fatal error: error during cleanup
Error: no more error handlers available (recursive errors?); invoking 'abort' restart
Running the tests in ‘tests/egf_utils.R’ failed.
Complete output:
> attach(asNamespace("epigrowthfit"))
> library(methods)
> library(tools)
> options(warn = 2L, error = if (interactive()) recover)
> example("egf", package = "epigrowthfit"); o.1 <- m1; o.2 <- m2
egf> ## Simulate 'N' incidence time series exhibiting exponential growth
egf> set.seed(180149L)
egf> N <- 10L
egf> f <- function(time, r, c0) {
egf+ lambda <- diff(exp(log(c0) + r * time))
egf+ c(NA, rpois(lambda, lambda))
egf+ }
egf> time <- seq.int(0, 40, 1)
egf> r <- rlnorm(N, -3.2, 0.2)
egf> c0 <- rlnorm(N, 6, 0.2)
egf> data_ts <-
egf+ data.frame(country = gl(N, length(time), labels = LETTERS[1:N]),
egf+ time = rep.int(time, N),
egf+ x = unlist(Map(f, time = list(time), r = r, c0 = c0)))
egf> rm(f, time)
egf> ## Define fitting windows (here, two per time series)
egf> data_windows <-
egf+ data.frame(country = gl(N, 1L, 2L * N, labels = LETTERS[1:N]),
egf+ wave = gl(2L, 10L),
egf+ start = c(sample(seq.int(0, 5, 1), N, TRUE),
egf+ sample(seq.int(20, 25, 1), N, TRUE)),
egf+ end = c(sample(seq.int(15, 20, 1), N, TRUE),
egf+ sample(seq.int(35, 40, 1), N, TRUE)))
egf> ## Estimate the generative model
egf> m1 <-
egf+ egf(model = egf_model(curve = "exponential", family = "pois"),
egf+ formula_ts = cbind(time, x) ~ country,
egf+ formula_windows = cbind(start, end) ~ country,
egf+ formula_parameters = ~(1 | country:wave),
egf+ data_ts = data_ts,
egf+ data_windows = data_windows,
egf+ se = TRUE)
computing a Hessian matrix ...
egf> ## Re-estimate the generative model with:
egf> ## * Gaussian prior on beta[1L]
egf> ## * LKJ prior on all random effect covariance matrices
egf> ## (here there happens to be just one)
egf> ## * initial value of 'theta' set explicitly
egf> ## * theta[3L] fixed at initial value
egf> m2 <-
egf+ update(m1,
egf+ formula_priors = list(beta[1L] ~ Normal(mu = -3, sigma = 1),
egf+ Sigma ~ LKJ(eta = 2)),
egf+ init = list(theta = c(log(0.5), log(0.5), 0)),
egf+ map = list(theta = 3L))
computing a Hessian matrix ...
>
>
> ## egf_sanitize_formula_ts ########################################
> ## egf_sanitize_formula_windows ########################################
>
> l1 <- list(cbind(x, y) ~ 1,
+ cbind(x, y) ~ g,
+ cbind(x, y) ~ 1 + g,
+ cbind(x, y) ~ (g),
+ cbind(x, y) ~ g:h,
+ cbind(x, y) ~ I(g + h),
+ cbind(x, y) ~ I(g * h),
+ cbind(x - 1, cumsum(y)) ~ g)
> l2 <- list(~g,
+ cbind(x, y) ~ g + h,
+ cbind(x, y) ~ g * h,
+ cbind(x, y) ~ 0 + g,
+ cbind(x, y) ~ g - 1,
+ cbind(x, y) ~ offset(h) + g,
+ (cbind(x, y)) ~ g,
+ cbind(x) ~ g,
+ cbind(x, y, z) ~ g,
+ rbind(x, y) ~ g) # i.e., anything other than 'cbind'
>
> stopifnot(identical(lapply(l1, egf_sanitize_formula_ts),
+ l1[c(1L, 2L, 2L, 2L, 5:8)]))
> for (formula in l2)
+ assertError(egf_sanitize_formula_ts(formula))
>
>
> ## egf_sanitize_formula_parameters #####################################
>
> model <- egf_model(curve = "exponential", family = "pois")
> top <- egf_top(model)
>
> s <-
+ function(formula)
+ egf_sanitize_formula_parameters(formula, top, check = TRUE)
>
> fp1 <- ~x * y + (z | g) + (zz | g/h)
> l1 <- rep.int(expr(simplify_terms(fp1)), 2L)
> names(l1) <- c("log(r)", "log(c0)")
>
> fp2 <- expr(replace(fp1, 2:3, expr(quote(log(r)), fp1[[2L]])))
> l2 <- replace(l1, "log(c0)", expr(~1))
>
> fp3 <- c(fp2, expr(log(c0) ~ x))
> l3 <- replace(l2, "log(c0)", expr(~x))
>
> stopifnot(exprs = {
+ identical(s(fp1), l1)
+ identical(s(fp2), l2)
+ identical(s(fp3), l3)
+ })
> assertWarning(s(~0 + x))
>
>
> ## egf_sanitize_formula_priors #########################################
>
> p1 <- Normal(mu = 0, sigma = 1)
> p2 <- Normal(mu = 1, sigma = c(0.5, 1))
> p3 <- Normal(mu = -1, sigma = 2)
> p4 <- LKJ(eta = 1)
>
> fp. <- list(foo(bar) ~ p1,
+ baz ~ p1,
+ beta ~ p1,
+ theta[[1L]] ~ p1,
+ theta[2:3] ~ p2,
+ theta[-(1:5)] ~ p3,
+ theta[replace(logical(6L), 4L, TRUE)] ~ p1,
+ Sigma ~ p4)
>
> ip. <- list(
+ top = list(names = c("foo(bar)", "baz"), family = "norm"),
+ bottom = list(
+ beta = list(length = 4L, family = "norm"),
+ theta = list(length = 6L, family = "norm"),
+ Sigma = list(length = 1L, family = c("lkj", "wishart", "invwishart"),
+ rows = 4L)))
>
> priors <- egf_sanitize_formula_priors(formula = fp., info = ip.)
>
> p2.elt <-
+ function(i) {
+ p2[["parameters"]][["sigma"]] <- p2[["parameters"]][["sigma"]][[i]]
+ p2
+ }
>
> stopifnot(exprs = {
+ is.list(priors)
+ length(priors) == 2L
+ identical(names(priors), c("top", "bottom"))
+
+ identical(priors[["top"]],
+ `names<-`(list(p1, p1), ip.[["top"]][["names"]]))
+ identical(priors[["bottom"]],
+ list(beta = list(p1, p1, p1, p1),
+ theta = list(p1, p2.elt(1L), p2.elt(2L), p1, NULL, p3),
+ Sigma = list(p4)))
+ })
>
>
> ## egf_make_frame ######################################################
>
> model <- egf_model(curve = "exponential", family = "pois")
>
> formula_ts <- cbind(day, count) ~ country
> formula_windows <- cbind(left, right) ~ country
> formula_parameters <- list(`log(r)` = ~x1 + (1 | g1) + (1 | g1:g2),
+ `log(c0)` = ~(1 | g3))
>
> data_ts <- data.frame(country = gl(6L, 11L),
+ day = seq.int(0, 10, by = 1),
+ count = rpois(11L, 100 * exp(0.04 * 0:10)))
> data_windows <- data.frame(country = gl(3L, 2L),
+ left = rep.int(c(0, 5), 3L),
+ right = rep.int(c(5, 10), 3L),
+ x1 = c(5.00, 8.34, -0.57, -7.19, -9.71, 1.25),
+ x2 = rnorm(6L),
+ x3 = rnorm(6L),
+ g1 = c("a", "b", "b", "b", "b", "a"),
+ g2 = c("c", "d", "d", "d", "c", "c"),
+ g3 = c("f", "f", "e", "e", "e", "f"))
>
> subset_ts <- quote(day > 0)
> subset_windows <- quote(x1 < 0)
> select_windows <- quote(.)
>
> na_action_ts <- "pass"
> na_action_windows <- "omit"
>
> frame <- egf_make_frame(model = model,
+ formula_ts = formula_ts,
+ formula_windows = formula_windows,
+ formula_parameters = formula_parameters,
+ data_ts = data_ts,
+ data_windows = data_windows,
+ subset_ts = subset_ts,
+ subset_windows = subset_windows,
+ select_windows = select_windows,
+ na_action_ts = na_action_ts,
+ na_action_windows = na_action_windows)
>
> stopifnot(exprs = {
+ is.list(frame)
+ length(frame) == 4L
+ identical(names(frame), c("ts", "windows", "parameters", "extra"))
+ })
>
> l1 <- frame[["ts"]]
> l1.e <- data.frame(ts = gl(2L, 10L, labels = 2:3),
+ window = factor(rep.int(c(NA, 1, 2, NA, 3, NA),
+ c(1L, 4L, 5L, 1L, 4L, 5L)),
+ labels = sprintf("window_%d", 1:3)),
+ time = rep.int(seq.int(1, 10, by = 1), 2L),
+ x = data_ts[["count"]][c(NA, 14:22, NA, 25:33)])
> attr(l1.e, "first") <- c(1L, 5L, 11L)
> attr(l1.e, "last") <- c(5L, 10L, 15L)
> stopifnot(identical(l1, l1.e))
>
> l2 <- frame[["windows"]]
> l2.e <- data.frame(ts = factor(c(2, 2, 3)),
+ window = gl(3L, 1L, labels = sprintf("window_%d", 1:3)),
+ start = c(1, 5, 1),
+ end = c(5, 10, 5))
> stopifnot(identical(l2, l2.e))
Error: identical(l2, l2.e) is not TRUE
Execution halted
Flavor: r-devel-linux-x86_64-fedora-gcc
Version: 0.15.3
Check: tests
Result: ERROR
Running 'coef.R' [5s]
Running 'confint.R' [54s]
Running 'datetime.R' [2s]
Running 'egf.R' [5s]
Running 'egf_enum.R' [2s]
Running 'egf_eval.R' [2s]
Running 'egf_examples_day_of_week.R' [2s]
Running 'egf_examples_excess.R' [2s]
Running 'egf_examples_fixed.R' [2s]
Running 'egf_examples_random.R' [61s]
Running 'egf_link.R' [2s]
Running 'egf_misc.R' [6s]
Running 'egf_options.R' [2s]
Running 'egf_utils.R' [6s]
Running 'epidemic.R' [2s]
Running 'extract.R' [6s]
Running 'fitted.R' [5s]
Running 'gi.R' [2s]
Running 'include.R' [93s]
Running 'language.R' [2s]
Running 'prior.R' [2s]
Running 'profile.R' [37s]
Running 'summary.R' [6s]
Running 'utils.R' [2s]
Running 'validity.R' [2s]
Running 'zzz.R' [2s]
Running the tests in 'tests/egf_utils.R' failed.
Complete output:
> attach(asNamespace("epigrowthfit"))
> library(methods)
> library(tools)
> options(warn = 2L, error = if (interactive()) recover)
> example("egf", package = "epigrowthfit"); o.1 <- m1; o.2 <- m2
egf> ## Simulate 'N' incidence time series exhibiting exponential growth
egf> set.seed(180149L)
egf> N <- 10L
egf> f <- function(time, r, c0) {
egf+ lambda <- diff(exp(log(c0) + r * time))
egf+ c(NA, rpois(lambda, lambda))
egf+ }
egf> time <- seq.int(0, 40, 1)
egf> r <- rlnorm(N, -3.2, 0.2)
egf> c0 <- rlnorm(N, 6, 0.2)
egf> data_ts <-
egf+ data.frame(country = gl(N, length(time), labels = LETTERS[1:N]),
egf+ time = rep.int(time, N),
egf+ x = unlist(Map(f, time = list(time), r = r, c0 = c0)))
egf> rm(f, time)
egf> ## Define fitting windows (here, two per time series)
egf> data_windows <-
egf+ data.frame(country = gl(N, 1L, 2L * N, labels = LETTERS[1:N]),
egf+ wave = gl(2L, 10L),
egf+ start = c(sample(seq.int(0, 5, 1), N, TRUE),
egf+ sample(seq.int(20, 25, 1), N, TRUE)),
egf+ end = c(sample(seq.int(15, 20, 1), N, TRUE),
egf+ sample(seq.int(35, 40, 1), N, TRUE)))
egf> ## Estimate the generative model
egf> m1 <-
egf+ egf(model = egf_model(curve = "exponential", family = "pois"),
egf+ formula_ts = cbind(time, x) ~ country,
egf+ formula_windows = cbind(start, end) ~ country,
egf+ formula_parameters = ~(1 | country:wave),
egf+ data_ts = data_ts,
egf+ data_windows = data_windows,
egf+ se = TRUE)
computing a Hessian matrix ...
egf> ## Re-estimate the generative model with:
egf> ## * Gaussian prior on beta[1L]
egf> ## * LKJ prior on all random effect covariance matrices
egf> ## (here there happens to be just one)
egf> ## * initial value of 'theta' set explicitly
egf> ## * theta[3L] fixed at initial value
egf> m2 <-
egf+ update(m1,
egf+ formula_priors = list(beta[1L] ~ Normal(mu = -3, sigma = 1),
egf+ Sigma ~ LKJ(eta = 2)),
egf+ init = list(theta = c(log(0.5), log(0.5), 0)),
egf+ map = list(theta = 3L))
computing a Hessian matrix ...
>
>
> ## egf_sanitize_formula_ts ########################################
> ## egf_sanitize_formula_windows ########################################
>
> l1 <- list(cbind(x, y) ~ 1,
+ cbind(x, y) ~ g,
+ cbind(x, y) ~ 1 + g,
+ cbind(x, y) ~ (g),
+ cbind(x, y) ~ g:h,
+ cbind(x, y) ~ I(g + h),
+ cbind(x, y) ~ I(g * h),
+ cbind(x - 1, cumsum(y)) ~ g)
> l2 <- list(~g,
+ cbind(x, y) ~ g + h,
+ cbind(x, y) ~ g * h,
+ cbind(x, y) ~ 0 + g,
+ cbind(x, y) ~ g - 1,
+ cbind(x, y) ~ offset(h) + g,
+ (cbind(x, y)) ~ g,
+ cbind(x) ~ g,
+ cbind(x, y, z) ~ g,
+ rbind(x, y) ~ g) # i.e., anything other than 'cbind'
>
> stopifnot(identical(lapply(l1, egf_sanitize_formula_ts),
+ l1[c(1L, 2L, 2L, 2L, 5:8)]))
> for (formula in l2)
+ assertError(egf_sanitize_formula_ts(formula))
>
>
> ## egf_sanitize_formula_parameters #####################################
>
> model <- egf_model(curve = "exponential", family = "pois")
> top <- egf_top(model)
>
> s <-
+ function(formula)
+ egf_sanitize_formula_parameters(formula, top, check = TRUE)
>
> fp1 <- ~x * y + (z | g) + (zz | g/h)
> l1 <- rep.int(expr(simplify_terms(fp1)), 2L)
> names(l1) <- c("log(r)", "log(c0)")
>
> fp2 <- expr(replace(fp1, 2:3, expr(quote(log(r)), fp1[[2L]])))
> l2 <- replace(l1, "log(c0)", expr(~1))
>
> fp3 <- c(fp2, expr(log(c0) ~ x))
> l3 <- replace(l2, "log(c0)", expr(~x))
>
> stopifnot(exprs = {
+ identical(s(fp1), l1)
+ identical(s(fp2), l2)
+ identical(s(fp3), l3)
+ })
> assertWarning(s(~0 + x))
>
>
> ## egf_sanitize_formula_priors #########################################
>
> p1 <- Normal(mu = 0, sigma = 1)
> p2 <- Normal(mu = 1, sigma = c(0.5, 1))
> p3 <- Normal(mu = -1, sigma = 2)
> p4 <- LKJ(eta = 1)
>
> fp. <- list(foo(bar) ~ p1,
+ baz ~ p1,
+ beta ~ p1,
+ theta[[1L]] ~ p1,
+ theta[2:3] ~ p2,
+ theta[-(1:5)] ~ p3,
+ theta[replace(logical(6L), 4L, TRUE)] ~ p1,
+ Sigma ~ p4)
>
> ip. <- list(
+ top = list(names = c("foo(bar)", "baz"), family = "norm"),
+ bottom = list(
+ beta = list(length = 4L, family = "norm"),
+ theta = list(length = 6L, family = "norm"),
+ Sigma = list(length = 1L, family = c("lkj", "wishart", "invwishart"),
+ rows = 4L)))
>
> priors <- egf_sanitize_formula_priors(formula = fp., info = ip.)
>
> p2.elt <-
+ function(i) {
+ p2[["parameters"]][["sigma"]] <- p2[["parameters"]][["sigma"]][[i]]
+ p2
+ }
>
> stopifnot(exprs = {
+ is.list(priors)
+ length(priors) == 2L
+ identical(names(priors), c("top", "bottom"))
+
+ identical(priors[["top"]],
+ `names<-`(list(p1, p1), ip.[["top"]][["names"]]))
+ identical(priors[["bottom"]],
+ list(beta = list(p1, p1, p1, p1),
+ theta = list(p1, p2.elt(1L), p2.elt(2L), p1, NULL, p3),
+ Sigma = list(p4)))
+ })
>
>
> ## egf_make_frame ######################################################
>
> model <- egf_model(curve = "exponential", family = "pois")
>
> formula_ts <- cbind(day, count) ~ country
> formula_windows <- cbind(left, right) ~ country
> formula_parameters <- list(`log(r)` = ~x1 + (1 | g1) + (1 | g1:g2),
+ `log(c0)` = ~(1 | g3))
>
> data_ts <- data.frame(country = gl(6L, 11L),
+ day = seq.int(0, 10, by = 1),
+ count = rpois(11L, 100 * exp(0.04 * 0:10)))
> data_windows <- data.frame(country = gl(3L, 2L),
+ left = rep.int(c(0, 5), 3L),
+ right = rep.int(c(5, 10), 3L),
+ x1 = c(5.00, 8.34, -0.57, -7.19, -9.71, 1.25),
+ x2 = rnorm(6L),
+ x3 = rnorm(6L),
+ g1 = c("a", "b", "b", "b", "b", "a"),
+ g2 = c("c", "d", "d", "d", "c", "c"),
+ g3 = c("f", "f", "e", "e", "e", "f"))
>
> subset_ts <- quote(day > 0)
> subset_windows <- quote(x1 < 0)
> select_windows <- quote(.)
>
> na_action_ts <- "pass"
> na_action_windows <- "omit"
>
> frame <- egf_make_frame(model = model,
+ formula_ts = formula_ts,
+ formula_windows = formula_windows,
+ formula_parameters = formula_parameters,
+ data_ts = data_ts,
+ data_windows = data_windows,
+ subset_ts = subset_ts,
+ subset_windows = subset_windows,
+ select_windows = select_windows,
+ na_action_ts = na_action_ts,
+ na_action_windows = na_action_windows)
>
> stopifnot(exprs = {
+ is.list(frame)
+ length(frame) == 4L
+ identical(names(frame), c("ts", "windows", "parameters", "extra"))
+ })
>
> l1 <- frame[["ts"]]
> l1.e <- data.frame(ts = gl(2L, 10L, labels = 2:3),
+ window = factor(rep.int(c(NA, 1, 2, NA, 3, NA),
+ c(1L, 4L, 5L, 1L, 4L, 5L)),
+ labels = sprintf("window_%d", 1:3)),
+ time = rep.int(seq.int(1, 10, by = 1), 2L),
+ x = data_ts[["count"]][c(NA, 14:22, NA, 25:33)])
> attr(l1.e, "first") <- c(1L, 5L, 11L)
> attr(l1.e, "last") <- c(5L, 10L, 15L)
> stopifnot(identical(l1, l1.e))
>
> l2 <- frame[["windows"]]
> l2.e <- data.frame(ts = factor(c(2, 2, 3)),
+ window = gl(3L, 1L, labels = sprintf("window_%d", 1:3)),
+ start = c(1, 5, 1),
+ end = c(5, 10, 5))
> stopifnot(identical(l2, l2.e))
Error: identical(l2, l2.e) is not TRUE
Execution halted
Flavor: r-devel-windows-x86_64
Version: 0.15.3
Check: installed package size
Result: NOTE
installed size is 94.3Mb
sub-directories of 1Mb or more:
libs 93.7Mb
Flavors: r-release-macos-arm64, r-release-macos-x86_64, r-release-windows-x86_64, r-oldrel-macos-arm64, r-oldrel-macos-x86_64, r-oldrel-windows-x86_64