## 'default_prior' ------------------------------------------------------------ test_that("'default_prior' works with ordinary term", { expect_identical(default_prior(nm_term = "x", var_age = "age", var_time = "time", length_effect = 5L), N()) }) test_that("'default_prior' works with term with length 1", { expect_identical(default_prior(nm_term = "(Intercept)", var_age = "age", var_time = "time", length_effect = 1L), NFix()) }) test_that("'default_prior' works with term with length 2", { expect_identical(default_prior(nm_term = "reg", var_age = "age", var_time = "time", length_effect = 1L), NFix()) }) test_that("'default_prior' works with age main effect", { expect_identical(default_prior(nm_term = "AgeGroup", var_age = "AgeGroup", var_time = "time", length_effect = 5), RW()) expect_identical(default_prior(nm_term = "AgeGroup", var_age = "AgeGroup", var_time = NULL, length_effect = 5), RW()) expect_identical(default_prior(nm_term = "AgeGroup", var_age = NULL, var_time = NULL, length_effect = 5), N()) }) test_that("'default_prior' works with age interaction", { expect_identical(default_prior(nm_term = "AgeGroup:sex", var_age = "AgeGroup", var_time = "time", length_effect = 5), RW()) expect_identical(default_prior(nm_term = "time:AgeGroup", var_age = "AgeGroup", var_time = "time", length_effect = 5), RW()) expect_identical(default_prior(nm_term = "period:AgeGroup", var_age = NULL, var_time = NULL, length_effect = 5), N()) }) test_that("'default_prior' works with time main effect term", { expect_identical(default_prior(nm_term = "year", var_age = "AgeGroup", var_time = "year", length_effect = 5), RW()) }) test_that("'default_prior' works with time interaction", { expect_identical(default_prior(nm_term = "sex:year", var_age = "AgeGroup", var_time = "year", length_effect = 5), RW()) expect_identical(default_prior(nm_term = "sex:year:region", var_age = "AgeGroup", var_time = "year", length_effect = 5), RW()) }) ## 'dimnames_to_levels' ------------------------------------------------------- test_that("'dimnames_to_levels' works with 0D dimnames", { dimnames <- list() ans_obtained <- dimnames_to_levels(dimnames) ans_expected <- "(Intercept)" expect_identical(ans_obtained, ans_expected) }) test_that("'dimnames_to_levels' works with 1D dimnames", { dimnames <- list(age = 0:4) ans_obtained <- dimnames_to_levels(dimnames) ans_expected <- as.character(0:4) expect_identical(ans_obtained, ans_expected) }) test_that("'dimnames_to_levels' works with 2D dimnames", { dimnames <- list(age = 0:4, reg = c("a", "b")) ans_obtained <- dimnames_to_levels(dimnames) ans_expected <- paste(0:4, rep(c("a", "b"), each = 5), sep = ".") expect_identical(ans_obtained, ans_expected) }) ## 'dimnames_to_nm' ------------------------------------------------------- test_that("'dimnames_to_nm' works with 0D dimnames", { dimnames <- list() ans_obtained <- dimnames_to_nm(dimnames) ans_expected <- "(Intercept)" expect_identical(ans_obtained, ans_expected) }) test_that("'dimnames_to_nm' works with 1D dimnames", { dimnames <- list(age = 0:4) ans_obtained <- dimnames_to_nm(dimnames) ans_expected <- "age" expect_identical(ans_obtained, ans_expected) }) test_that("'dimnames_to_nm' works with 2D dimnames", { dimnames <- list(age = 0:4, reg = c("a", "b")) ans_obtained <- dimnames_to_nm(dimnames) ans_expected <- "age:reg" expect_identical(ans_obtained, ans_expected) }) ## 'dimnames_to_nm_split' ----------------------------------------------------- test_that("'dimnames_to_nm_split' works with 0D dimnames", { dimnames <- list() ans_obtained <- dimnames_to_nm_split(dimnames) ans_expected <- "(Intercept)" expect_identical(ans_obtained, ans_expected) }) test_that("'dimnames_to_nm_split' works with 1D dimnames", { dimnames <- list(age = 0:4) ans_obtained <- dimnames_to_nm_split(dimnames) ans_expected <- "age" expect_identical(ans_obtained, ans_expected) }) test_that("'dimnames_to_nm_split' works with 2D dimnames", { dimnames <- list(age = 0:4, reg = c("a", "b")) ans_obtained <- dimnames_to_nm_split(dimnames) ans_expected <- c("age", "reg") expect_identical(ans_obtained, ans_expected) }) ## 'eval_offset_formula' ------------------------------------------------------ test_that("'eval_offset_formula' works with valid inputs - simple formula", { vname_offset <- "~popn + other" data <- data.frame(popn = 1, other = 2) ans_obtained <- eval_offset_formula(vname_offset = vname_offset, data = data) ans_expected <- 3 expect_identical(ans_obtained, ans_expected) }) test_that("'eval_offset_formula' works with valid inputs - complicated formula", { vname_offset <- "~popn^2 + log(other) + 6" data <- data.frame(popn = 1:2, other = 2:3) ans_obtained <- eval_offset_formula(vname_offset = vname_offset, data = data) ans_expected <- (1:2)^2 + log(2:3) + 6 expect_identical(ans_obtained, ans_expected) }) test_that("'eval_offset_formula' works with valid inputs - ifelse", { vname_offset <- "~ifelse(popn <= 0, 0.1, popn)" data <- data.frame(popn = 0:2) ans_obtained <- eval_offset_formula(vname_offset = vname_offset, data = data) ans_expected <- c(0.1, 1, 2) expect_identical(ans_obtained, ans_expected) }) ## 'get_matrix_offset_svd_prior' ---------------------------------------------- test_that("'get_matrix_or_offset_svd_prior' works with age main effect, type is total, matrix", { ssvd <- sim_ssvd() prior <- SVD(ssvd, n_comp = 3) ans_obtained <- get_matrix_or_offset_svd_prior(prior = prior, dimnames_term = list(age = c("0-4", "5-9")), var_age = "age", var_sexgender = "sex", get_matrix = TRUE) ans_expected <- Matrix::Matrix(1, nr = 2, nc = 3, dimnames = list(c("0-4", "5-9"), NULL)) expect_equal(ans_obtained, ans_expected) }) test_that("'get_matrix_or_offset_svd_prior' works with age main effect, type is total, offset", { ssvd <- sim_ssvd() prior <- SVD(ssvd, n_comp = 3) ans_obtained <- get_matrix_or_offset_svd_prior(prior = prior, dimnames_term = list(age = c("0-4", "5-9")), var_age = "age", var_sexgender = "sex", get_matrix = FALSE) ans_expected <- c("0-4" = 1, "5-9" = 2) expect_identical(ans_obtained, ans_expected) }) test_that("'get_matrix_or_offset_svd_prior' works with sex-age interaction, type is joint, offset", { ssvd <- sim_ssvd() prior <- SVD(ssvd, indep = FALSE) dimnames_term <- list(age = c("0-4", "5-9"), sex = c("Male", "Female")) ans_obtained <- get_matrix_or_offset_svd_prior(prior = prior, dimnames_term = dimnames_term, var_age = "age", var_sexgender = "sex", get_matrix = FALSE) ans_expected <- c("Male.0-4" = 3, "Male.5-9" = 4, "Female.0-4" = 1, "Female.5-9" = 2) expect_identical(ans_obtained, ans_expected) }) test_that("'get_matrix_or_offset_svd_prior' works with age-sex interaction, type is indep, matrix", { ssvd <- sim_ssvd() prior <- SVD(ssvd) dimnames_term <- list(sex = c("Female", "Male"), age = c("0-4", "5-9")) ans_obtained <- get_matrix_or_offset_svd_prior(prior, dimnames_term = dimnames_term, var_age = "age", var_sexgender = "sex", get_matrix = TRUE) ans_expected <- Matrix::Matrix(3, nr = 4, nc = 10, dimnames = list(c("Female.0-4", "Male.0-4", "Female.5-9", "Male.5-9"), NULL)) expect_identical(ans_obtained, ans_expected) }) ## 'get_n_comp_spline' -------------------------------------------------------- test_that("'get_n_comp_spline' works with n_comp supplied", { expect_identical(get_n_comp_spline(Sp(n_comp = 4), n_along = 10), 4L) }) test_that("'get_n_comp_spline' works with n_comp supplied", { expect_identical(get_n_comp_spline(Sp(), n_along = 10), 7L) }) ## 'get_print_prior_n_offset' ------------------------------------------------- test_that("'get_print_prior_n_offset' works", { expect_identical(get_print_prior_n_offset(), 10L) }) ## 'infer_var_age' ------------------------------------------------------------ test_that("'infer_var_age' returns name when single valid answer", { expect_identical(infer_var_age(deaths ~ age * sex + time), "age") expect_identical(infer_var_age(deaths ~ age * sex + time + age), "age") expect_identical(infer_var_age(deaths ~ Age * sex + time), "Age") expect_identical(infer_var_age(deaths ~ AGE_GROUP * sex + time), "AGE_GROUP") expect_identical(infer_var_age(deaths ~ agegroup * sex + time), "agegroup") expect_identical(infer_var_age(deaths ~ ageinterval * sex + time), "ageinterval") expect_identical(infer_var_age(deaths ~ age.years * sex + time), "age.years") expect_identical(infer_var_age(deaths ~ age.year * sex + time), "age.year") }) test_that("'infer_var_age' returns NULL when not single valid answer", { expect_identical(infer_var_age(deaths ~ agex * sex + time), NULL) expect_identical(infer_var_age(deaths ~ sex + time), NULL) expect_identical(infer_var_age(deaths ~ 1), NULL) }) ## 'infer_var_sexgender' ------------------------------------------------------------ test_that("'infer_var_sexgender' returns name when single valid answer", { expect_identical(infer_var_sexgender(deaths ~ age * sex + time), "sex") expect_identical(infer_var_sexgender(deaths ~ age:gender + time + age), "gender") }) test_that("'infer_var_sexgender' returns NULL when not single valid answer", { expect_identical(infer_var_sexgender(deaths ~ age * sex + gender), NULL) expect_identical(infer_var_sexgender(deaths ~ age + time), NULL) expect_identical(infer_var_sexgender(deaths ~ 1), NULL) }) ## 'infer_var_time' ----------------------------------------------------------- test_that("'infer_var_time' returns name when single valid answer", { expect_identical(infer_var_time(deaths ~ time * sex + age), "time") expect_identical(infer_var_time(deaths ~ Time * sex + age), "Time") expect_identical(infer_var_time(deaths ~ PERIOD * sex + age), "PERIOD") expect_identical(infer_var_time(deaths ~ QUARters * sex + age), "QUARters") expect_identical(infer_var_time(deaths ~ month * sex + age), "month") expect_identical(infer_var_time(deaths ~ years * sex + age), "years") expect_identical(infer_var_time(deaths ~ year * sex + age), "year") expect_identical(infer_var_time(deaths ~ sex + month_year), "month_year") expect_identical(infer_var_time(deaths ~ sex + year_quarter), "year_quarter") expect_identical(infer_var_time(deaths ~ sex + quarter_year), "quarter_year") }) test_that("'infer_var_time' returns NULL when not single valid answer", { expect_identical(infer_var_time(deaths ~ xTime + sex + age), NULL) expect_identical(infer_var_time(deaths ~ time * sex + year_month), NULL) expect_identical(infer_var_time(deaths ~ age * sex + PERIODX), NULL) expect_identical(infer_var_time(deaths ~ 1), NULL) }) ## 'make_agesex' -------------------------------------------------------------- test_that("'make_agesex' works with valid inputs", { expect_identical(make_agesex("agegroup", var_age = "agegroup", var_sexgender = "gender"), "age") expect_identical(make_agesex("agegroup", var_age = NULL, var_sexgender = "gender"), "other") expect_identical(make_agesex("(Intercept)", var_age = "agegroup", var_sexgender = "gender"), "other") expect_identical(make_agesex("agegroup:gender", var_age = "agegroup", var_sexgender = "gender"), "age:sex") expect_identical(make_agesex("gender:agegroup", var_age = "agegroup", var_sexgender = "gender"), "sex:age") expect_identical(make_agesex("agegroup:gender", var_age = "agegroup", var_sexgender = NULL), "age:other") expect_identical(make_agesex("gender:agegroup:reg", var_age = "agegroup", var_sexgender = "gender"), "sex:age:other") expect_identical(make_agesex("region:agegroup", var_age = "agegroup", var_sexgender = "gender"), "age:other") expect_identical(make_agesex("gender:agegroup:region", var_age = "agegroup", var_sexgender = "gender"), "sex:age:other") expect_identical(make_agesex("agegroup:gender:region", var_age = "agegroup", var_sexgender = "gender"), "age:sex:other") expect_identical(make_agesex("agegroup:bla:region", var_age = "agegroup", var_sexgender = "gender"), "age:other") expect_identical(make_agesex("gender:agegroup:region", var_age = NULL, var_sexgender = NULL), "other") }) ## 'make_const' --------------------------------------------------------------- test_that("'make_const' works with valid inputs", { set.seed(0) data <- expand.grid(agegp = 0:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp + SEX mod <- mod_pois(formula = formula, data = data, exposure = popn) |> set_prior((Intercept) ~ Known(3)) ans_obtained <- make_const(mod) ans_expected <- c("(Intercept)" = 0, agegp.scale = 1, agegp.sd = 1, SEX.sd = 1) expect_identical(ans_obtained, ans_expected) }) test_that("'make_const' works with valid inputs - no terms", { set.seed(0) data <- expand.grid(agegp = 0:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp + SEX mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- reduce_model_terms(mod, use_term = rep(F, 3)) ans_obtained <- make_const(mod) ans_expected <- double() expect_identical(ans_obtained, ans_expected) }) ## 'make_dimnames_terms' ------------------------------------------------------ test_that("'make_dimnames_terms' works - includes intercept", { set.seed(0) data <- expand.grid(age = 0:9, time = 2000:2005, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex + time ans_obtained <- make_dimnames_terms(data = data, formula = formula) ans_expected <- list("(Intercept)" = list(), age = list(age = as.character(0:9)), sex = list(sex = c("F", "M")), time = list(time = as.character(2000:2005)), "age:sex" = list(age = as.character(0:9), sex = c("F", "M"))) expect_identical(ans_obtained, ans_expected) }) test_that("'make_dimnames_terms' works - no intercept", { set.seed(0) data <- expand.grid(age = 0:9, time = 2000:2005, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex + time - 1 ans_obtained <- make_dimnames_terms(data = data, formula = formula) ans_expected <- list(age = list(age = as.character(0:9)), sex = list(sex = c("F", "M")), time = list(time = as.character(2000:2005)), "age:sex" = list(age = as.character(0:9), sex = c("F", "M"))) expect_identical(ans_obtained, ans_expected) }) ## 'make_effectfree' ------------------------------------------------------------- test_that("'make_effectfree' works with valid inputs", { set.seed(0) data <- expand.grid(agegp = 0:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp + SEX mod <- mod_pois(formula = formula, data = data, exposure = popn) |> set_prior((Intercept) ~ Known(3)) ans_obtained <- make_effectfree(mod) ans_expected <- c("(Intercept)" = 3, agegp = 0, agegp = 0, agegp = 0, SEX = 0, SEX = 0) expect_identical(ans_obtained, ans_expected) }) test_that("'make_effectfree' works with valid inputs", { set.seed(0) data <- expand.grid(agegp = 0:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp + SEX mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- reduce_model_terms(mod, use_term = rep(F, 3)) ans_obtained <- make_effectfree(mod) ans_expected <- double() expect_identical(ans_obtained, ans_expected) }) ## 'make_hyper' --------------------------------------------------------------- test_that("'make_hyper' works with valid inputs", { set.seed(0) data <- expand.grid(agegp = 0:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp * SEX mod <- mod_pois(formula = formula, data = data, exposure = popn) ans_obtained <- make_hyper(mod) ans_expected <- c(agegp = 0, "agegp:SEX" = 0) expect_identical(ans_obtained, ans_expected) }) ## 'make_hyperrandfree' ------------------------------------------------------- test_that("'make_hyperrandfree' works with valid inputs - no hyperrandfree", { set.seed(0) data <- expand.grid(agegp = 0:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp * SEX mod <- mod_pois(formula = formula, data = data, exposure = popn) ans_obtained <- make_hyperrandfree(mod) ans_expected <- numeric() names(ans_expected) <- character() expect_identical(ans_obtained, ans_expected) }) test_that("'make_hyperrandfree' works with valid inputs - has hyperrandfree", { set.seed(0) data <- expand.grid(agegp = 0:2, SEX = c("F", "M"), time = 2001:2005) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp + SEX * time mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- set_prior(mod, SEX:time ~ Lin()) ans_obtained <- make_hyperrandfree(mod) ans_expected <- rep(c("SEX:time" = 0), 2) expect_identical(ans_obtained, ans_expected) }) ## 'make_i_prior' ------------------------------------------------------------- test_that("'make_i_prior' works with valid inputs", { mod <- list(priors = list(a = N(), b = RW(), c = N())) ans_obtained <- make_i_prior(mod) ans_expected <- c(a = 4L, b = 19L, c = 4L) expect_identical(ans_obtained, ans_expected) }) ## 'make_is_in_lik' ----------------------------------------------------------- test_that("'make_is_in_lik' works with no NAs", { mod <- list(outcome = c(0, 1, 5), offset = c(1, 0, 3)) ans_obtained <- make_is_in_lik(mod) ans_expected <- c(TRUE, FALSE, TRUE) expect_identical(ans_obtained, ans_expected) }) test_that("'make_is_in_lik' works with NAs", { mod <- list(outcome = c(0, 1, NA, 7), offset = c(1, 0, 3, NA)) ans_obtained <- make_is_in_lik(mod) ans_expected <- c(TRUE, FALSE, FALSE, FALSE) expect_identical(ans_obtained, ans_expected) }) ## 'make_lengths_effect' --------------------------------------------------------- test_that("'make_lengths_effect' works with valid inputs - has intercept", { set.seed(0) data <- expand.grid(age = 0:9, time = 2000:2005, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex + time dimnames_terms <- make_dimnames_terms(data = data, formula = formula) ans_obtained <- make_lengths_effect(dimnames_terms) ans_expected <- c("(Intercept)" = 1L, age = 10L, sex = 2L, time = 6L, "age:sex" = 20L) expect_identical(ans_obtained, ans_expected) }) test_that("'make_lengths_effect' works with valid inputs - no intercept", { set.seed(0) data <- expand.grid(age = 0:9, time = 2000:2005, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex + time - 1 dimnames_terms <- make_dimnames_terms(data = data, formula = formula) ans_obtained <- make_lengths_effect(dimnames_terms) ans_expected <- c(age = 10L, sex = 2L, time = 6L, "age:sex" = 20L) expect_identical(ans_obtained, ans_expected) }) ## 'make_lengths_effectfree' ----------------------------------------------------------- test_that("'make_lengths_effectfree' works with valid inputs", { set.seed(0) data <- expand.grid(agegp = 0:9, region = 1:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp * SEX + region mod <- mod_pois(formula = formula, data = data, exposure = popn) ans_obtained <- make_lengths_effectfree(mod) ans_expected <- c("(Intercept)" = 1L, agegp = 10L, SEX = 2L, region = 2L, "agegp:SEX" = 20L) expect_identical(ans_obtained, ans_expected) }) ## 'make_lengths_hyper' ------------------------------------------------------- test_that("'make_lengths_hyper' works with valid inputs", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:3, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex + region mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- set_prior(mod, age:sex ~ Lin()) mod <- set_prior(mod, sex ~ NFix()) ans_obtained <- make_lengths_hyper(mod) ans_expected <- c("(Intercept)" = 0L, age = 1L, sex = 0L, region = 1L, "age:sex" = 1L) expect_identical(ans_obtained, ans_expected) }) ## 'make_lengths_hyperrandfree' ----------------------------------------------- test_that("'make_lengths_hyperrandfree' works with valid inputs", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:2, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex + region mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- set_prior(mod, age:sex ~ Lin()) mod <- set_prior(mod, sex ~ NFix()) ans_obtained <- make_lengths_hyperrandfree(mod) ans_expected <- c("(Intercept)" = 0L, age = 0L, sex = 0L, region = 0L, "age:sex" = 2L) expect_identical(ans_obtained, ans_expected) }) ## 'make_levels_effects' ---------------------------------------------------------- test_that("'make_levels_effects' works with valid inputs - pois, complete levels", { set.seed(0) data <- expand.grid(age = 0:9, time = 2000:2005, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex + time dimnames_terms <- make_dimnames_terms(formula = formula, data = data) ans_obtained <- make_levels_effects(dimnames_terms) ans_expected <- c("(Intercept)", 0:9, c("F", "M"), 2000:2005, paste(rep(0:9, times = 2), rep(c("F", "M"), each = 10), sep = ".")) expect_identical(ans_obtained, ans_expected) }) test_that("'make_levels_effects' works with valid inputs - pois, incomplete levels", { set.seed(0) data <- expand.grid(age = 0:9, time = 2000:2005, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) data <- data[-3, ] formula <- deaths ~ age * sex + time dimnames_terms <- make_dimnames_terms(formula = formula, data = data) ans_obtained <- make_levels_effects(dimnames_terms) ans_expected <- c("(Intercept)", 0:9, c("F", "M"), 2000:2005, paste(rep(0:9, times = 2), rep(c("F", "M"), each = 10), sep = ".")) expect_identical(ans_obtained, ans_expected) }) test_that("'make_levels_effects' works with valid inputs - norm", { set.seed(0) data <- expand.grid(age = 0:9, time = 2000:2005, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$income <- rnorm(n = nrow(data)) formula <- income ~ age * sex + time dimnames_terms <- make_dimnames_terms(formula = formula, data = data) ans_obtained <- make_levels_effects(dimnames_terms) ans_expected <- c("(Intercept)", 0:9, c("F", "M"), 2000:2005, paste(rep(0:9, times = 2), rep(c("F", "M"), each = 10), sep = ".")) expect_identical(ans_obtained, ans_expected) }) test_that("'make_levels_effects' works with valid inputs - no terms", { ans_obtained <- make_levels_effects(list()) ans_expected <- character() expect_identical(ans_obtained, ans_expected) }) ## 'make_levels_forecast_all' ------------------------------------------------- test_that("'make_levels_forecast_all' works with single time dimension", { set.seed(0) data <- expand.grid(age = 0:2, time = 2000:2005, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) mod <- mod_pois(deaths ~ age + sex + time, data = data, exposure = popn) ans_obtained <- make_levels_forecast_all(mod, labels_forecast = 2006:2007) ans_expected <- list("(Intercept)" = NULL, age = NULL, sex = NULL, time = as.character(2006:2007)) expect_identical(ans_obtained, ans_expected) }) test_that("'make_levels_forecast_all' works with time interaction", { set.seed(0) data <- expand.grid(age = 0:2, time = 2000:2005, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) mod <- mod_pois(deaths ~ age + sex * time, data = data, exposure = popn) ans_obtained <- make_levels_forecast_all(mod, labels_forecast = 2006:2007) ans_expected <- list("(Intercept)" = NULL, age = NULL, sex = NULL, time = as.character(2006:2007), "sex:time" = paste(c("F", "M"), c(2006, 2006, 2007, 2007), sep = ".")) expect_identical(ans_obtained, ans_expected) }) test_that("'make_levels_forecast_all' works with no intercept", { set.seed(0) data <- expand.grid(age = 0:2, time = 2000:2005, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) mod <- mod_pois(deaths ~ age + sex + time, data = data, exposure = popn) mod <- reduce_model_terms(mod, use_term = c(F, T, T, T)) ans_obtained <- make_levels_forecast_all(mod, labels_forecast = 2006:2007) ans_expected <- list(age = NULL, sex = NULL, time = as.character(2006:2007)) expect_identical(ans_obtained, ans_expected) }) ## 'make_map' ----------------------------------------------------------------- test_that("'make_map' works with no parameters fixed", { set.seed(0) data <- expand.grid(time = 2000:2009, region = 1:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ time * SEX + region mod <- mod_pois(formula = formula, data = data, exposure = popn) ans_obtained <- make_map(mod) ans_expected <- NULL expect_identical(ans_obtained, ans_expected) }) test_that("'make_map' works when 'effectfree' contains known values", { set.seed(0) data <- expand.grid(time = 0:3, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ time * SEX mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- set_prior(mod, SEX ~ Known(c(0.1, -0.1))) ans_obtained <- make_map(mod) ans_expected <- list(effectfree = factor(c("(Intercept)" = 1, time = 2, time = 3, time = 4, time = 5, SEX = NA, SEX = NA, "time:SEX" = 6, "time:SEX" = 7, "time:SEX" = 8, "time:SEX" = 9, "time:SEX" = 10, "time:SEX" = 11, "time:SEX" = 12, "time:SEX" = 13))) expect_identical(ans_obtained, ans_expected) }) test_that("'make_map' works dispersion is 0", { set.seed(0) data <- expand.grid(time = 2000:2009, region = 1:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ time * SEX + region mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- set_disp(mod, mean = 0) ans_obtained <- make_map(mod) ans_expected <- list(log_disp = factor(NA)) expect_identical(ans_obtained, ans_expected) }) test_that("'make_map' works when effectfree has known values", { set.seed(0) data <- expand.grid(time = 0:3, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ time * SEX mod <- mod_pois(formula = formula, data = data, exposure = popn) |> set_prior(time ~ RW(sd = 0)) |> set_prior(time:SEX ~ RW(sd = 0)) mod <- set_prior(mod, SEX ~ Known(c(0.1, -0.1))) ans_obtained <- make_map(mod) ans_expected <- list(effectfree = factor(c("(Intercept)" = 1, time = 2, time = 3, time = 4, SEX = NA, SEX = NA, "time:SEX" = 5, "time:SEX" = 6, "time:SEX" = 7, "time:SEX" = 8, "time:SEX" = 9, "time:SEX" = 10))) expect_identical(ans_obtained, ans_expected) }) ## 'make_map_effectfree_fixed' --------------------------------------------------- test_that("'make_map_effectfree_fixed' works with valid inputs", { set.seed(0) data <- expand.grid(time = 0:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ time + SEX mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- set_prior(mod, SEX ~ Known(c(-1, 1))) ans_obtained <- make_map_effectfree_fixed(mod) ans_expected <- factor(c("(Intercept)" = 1, time = 2, time = 3, time = 4, SEX = NA, SEX = NA)) expect_identical(ans_obtained, ans_expected) expect_identical(length(make_map_effectfree_fixed(mod)), length(make_effectfree(mod))) }) ## 'make_matrices_along_by_effectfree' ------------------------------------------------ test_that("'make_matrices_along_by_effectfree' works", { set.seed(0) data <- expand.grid(agegp = 0:9, region = 1:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp * SEX + SEX * region mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- set_prior(mod, agegp ~ Sp(n_comp = 4)) ans <- make_matrices_along_by_effectfree(mod) expect_true(all(sapply(ans, is.matrix))) expect_identical(names(ans), names(mod$priors)) }) test_that("'make_matrices_along_by_effectfree' works - with SVD", { set.seed(0) data <- expand.grid(age = c(0:59, "60+"), time = 2000:2005, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex + age * time mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- set_prior(mod, age:time ~ SVD_RW(HMD)) ans <- make_matrices_along_by_effectfree(mod) expect_true(all(sapply(ans, is.matrix))) expect_identical(names(ans), names(mod$priors)) }) ## 'make_matrices_along_by_forecast' ------------------------------------------ test_that("'make_matrices_along_by_forecast' works with intercept", { set.seed(0) data <- expand.grid(age = 0:9, time = 1:2, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex + age * time mod <- mod_pois(formula = formula, data = data, exposure = popn) ans_obtained <- make_matrices_along_by_forecast(mod = mod, labels_forecast = 3:4) time <- matrix(0:1, nr = 2) rownames(time) <- 3:4 names(dimnames(time)) <- "time" agetime <- t(matrix(0:19, nr = 10)) dimnames(agetime) <- list(time = 3:4, age = 0:9) ans_expected <- list("(Intercept)" = NULL, age = NULL, sex = NULL, time = time, "age:sex" = NULL, "age:time" = agetime) expect_identical(ans_obtained, ans_expected) }) test_that("'make_matrices_along_by_forecast' works with no intercept", { set.seed(0) data <- expand.grid(age = 0:9, time = 1:2, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex + age * time mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- reduce_model_terms(mod, use_term = c(F, T, T, T, F, F)) ans_obtained <- make_matrices_along_by_forecast(mod = mod, labels_forecast = 3:4) time <- matrix(0:1, nr = 2) rownames(time) <- 3:4 names(dimnames(time)) <- "time" ans_expected <- list(age = NULL, sex = NULL, time = time) expect_identical(ans_obtained, ans_expected) }) ## 'make_matrices_effect_outcome' -------------------------------------------- test_that("'make_matrices_effect_outcome' works with valid inputs - has intercept", { data <- expand.grid(age = 0:5, time = 2000:2001, sex = 1:2) data$val <- 1 data <- data[-c(3, 5), ] formula <- deaths ~ age:sex + time dimnames_terms <- make_dimnames_terms(formula = formula, data = data) ans_obtained <- make_matrices_effect_outcome(data = data, dimnames_terms = dimnames_terms) data_fac <- data[1:3] data_fac[] <- lapply(data_fac, factor) ans_expected <- Matrix::sparse.model.matrix(~age:sex + time, data = data_fac, contrasts.arg = lapply(data_fac, contrasts, contrast = FALSE), row.names = FALSE) v <- rnorm(n = ncol(ans_expected)) expect_equal(do.call(cbind, ans_obtained) %*% v, ans_expected %*% v) expect_identical(names(ans_obtained), c("(Intercept)", "time", "age:sex")) }) test_that("'make_matrices_effect_outcome' works with valid inputs - no intercept", { data <- expand.grid(age = 0:5, time = 2000:2001, sex = 1:2) data$val <- 1 data <- data[-c(3, 5), ] formula <- deaths ~ age:sex + time - 1 dimnames_terms <- make_dimnames_terms(formula = formula, data = data) ans_obtained <- make_matrices_effect_outcome(data = data, dimnames_terms = dimnames_terms) data_fac <- data[1:3] data_fac[] <- lapply(data_fac, factor) ans_expected <- Matrix::sparse.model.matrix(~age:sex + time - 1, data = data_fac, contrasts.arg = lapply(data_fac, contrasts, contrast = FALSE), row.names = FALSE) v <- rnorm(n = ncol(ans_expected)) expect_equal(do.call(cbind, ans_obtained) %*% v, ans_expected %*% v) expect_identical(names(ans_obtained), c("time", "age:sex")) }) ## 'make_matrices_effectfree_effect' ------------------------------------------------ test_that("'make_matrices_effectfree_effect' works with valid inputs", { set.seed(0) data <- expand.grid(agegp = 0:9, region = 1:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp + SEX + region mod <- mod_pois(formula = formula, data = data, exposure = popn) |> set_prior(agegp ~ RW(sd = 0)) ans_obtained <- make_matrices_effectfree_effect(mod) agegp <- rbind(0,Matrix::.sparseDiagonal(9)) ans_expected <- list("(Intercept)" = Matrix::.sparseDiagonal(1), agegp = agegp, SEX = Matrix::.sparseDiagonal(2), region = Matrix::.sparseDiagonal(2)) expect_identical(ans_obtained, ans_expected) }) ## 'make_offset' -------------------------------------------------------------- test_that("'make_offset' works with valid inputs - no NA", { data <- expand.grid(age = 0:2, time = 2000:2001, sex = 1:2) data$wt <- seq_len(nrow(data)) ans_obtained <- make_offset(vname_offset = "wt", data = data) ans_expected <- as.double(data$wt) expect_identical(ans_obtained, ans_expected) }) test_that("'make_offset' works with valid inputs - has NA", { data <- expand.grid(age = 0:2, time = 2000:2001, sex = 1:2) data$wt <- seq_len(nrow(data)) data$wt[3] <- NA ans_obtained <- make_offset(vname_offset = "wt", data = data) ans_expected <- xtabs(wt ~ age + sex + time, data = data) ans_expected[3] <- NA ans_expected <- as.double(data$wt) expect_identical(ans_obtained, ans_expected) }) test_that("'make_offset' works with valid inputs - no NA", { data <- expand.grid(age = 0:2, time = 2000:2001, sex = 1:2) data$wt <- seq_len(nrow(data)) ans_obtained <- make_offset(vname_offset = "~ wt + 1", data = data) ans_expected <- as.double(data$wt) + 1 expect_identical(ans_obtained, ans_expected) }) ## 'make_offset_ones' ----------------------------------------------------- test_that("'make_offset_ones' works with valid inputs", { data <- expand.grid(age = 0:2, time = 2000:2001, sex = 1:2) data$deaths <- 1:12 ans_obtained <- make_offset_ones(data) ans_expected <- rep(1.0, times = 12) expect_identical(ans_obtained, ans_expected) }) ## 'make_offsets_effectfree_effect' ------------------------------------------------ test_that("'make_offsets_effectfree_effect' works with valid inputs", { set.seed(0) data <- expand.grid(agegp = 0:9, region = 1:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp * SEX + region mod <- mod_pois(formula = formula, data = data, exposure = popn) ans_obtained <- make_offsets_effectfree_effect(mod) ans_expected <- list("(Intercept)" = 0, agegp = rep(0, 10), SEX = rep(0, 2), region = rep(0, 2), "agegp:SEX" = rep(0, 20)) expect_identical(ans_obtained, ans_expected) }) ## 'make_outcome' ------------------------------------------------------------- test_that("'make_outcome' works with valid inputs", { data <- expand.grid(age = 0:2, time = 2000:2001, sex = 1:2) data$deaths <- seq_len(nrow(data)) data$deaths[3] <- NA formula <- deaths ~ age:sex + time ans_obtained <- make_outcome(formula = formula, data = data) ans_expected <- as.double(data$deaths) expect_identical(ans_obtained, ans_expected) }) ## 'make_prior_class' --------------------------------------------------------- test_that("'make_prior_class' works with valid inputs", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:5, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) mod <- mod_pois(deaths ~ age * sex + region, data = data, exposure = popn) ans_obtained <- make_prior_class(mod) ans_expected <- tibble::tibble(term = c("(Intercept)", "age", "sex", "region", "age:sex"), class = c("bage_prior_normfixed", "bage_prior_rwrandom", "bage_prior_normfixed", "bage_prior_norm", "bage_prior_rwrandom")) expect_identical(ans_obtained, ans_expected) }) ## 'make_priors' -------------------------------------------------------------- test_that("'make_priors' works with valid inputs - has intercept", { formula <- deaths ~ age:sex + time ans_obtained <- make_priors(formula, var_age = "age", var_time = "time", lengths_effect = c(1L, 10L, 12L)) ans_expected <- list("(Intercept)" = NFix(), time = RW(), "age:sex" = RW()) expect_identical(ans_obtained, ans_expected) }) ## 'make_random' -------------------------------------------------------------- test_that("'make_random' works when no hyper, no hyperrandfree", { mod <- structure(.Data = list(priors = list(NFix(), Known(c(2, 3))))) expect_identical(make_random(mod), NULL) }) test_that("'make_random' works when hyper, no hyperrandfree", { mod <- structure(.Data = list(priors = list(N(), RW2()))) expect_identical(make_random(mod), "effectfree") }) test_that("'make_random' works when hyper, hyperrand", { mod <- structure(.Data = list(priors = list(N(), RW2(), Lin()))) expect_identical(make_random(mod), c("effectfree", "hyperrandfree")) }) ## 'make_seed' -------------------------------------------------------------- test_that("'make_seed' returns a single unique integer", { set.seed(0) ans1 <- make_seed() ans2 <- make_seed() expect_true(is.integer(ans1)) expect_identical(length(ans1), 1L) expect_false(ans1 == ans2) }) ## 'make_terms_const' --------------------------------------------------------- test_that("'make_terms_const' works with valid inputs", { set.seed(0) data <- expand.grid(agegp = 0:9, region = 1:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp * SEX + region mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- set_prior(mod, agegp ~ AR1()) ans_obtained <- make_terms_const(mod) ans_expected <- factor(c("(Intercept)", rep("agegp", 5), "SEX", "region", "agegp:SEX", "agegp:SEX"), levels = c("(Intercept)", "agegp", "SEX", "region", "agegp:SEX")) expect_identical(ans_obtained, ans_expected) }) ## 'make_terms_effects' ----------------------------------------------------------- test_that("'make_terms_effects' works with valid inputs", { set.seed(0) data <- expand.grid(agegp = 0:9, region = 1:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp * SEX + region mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- set_prior(mod, agegp ~ AR1()) ans_obtained <- make_terms_effects(mod$dimnames_terms) ans_expected <- factor(c("(Intercept)", rep("agegp", 10), rep("SEX", 2), rep("region", 2), rep("agegp:SEX", 20)), levels = c("(Intercept)", "agegp", "SEX", "region", "agegp:SEX")) expect_identical(ans_obtained, ans_expected) }) ## 'make_terms_effectfree' ----------------------------------------------------------- test_that("'make_terms_effectfree' works with valid inputs", { set.seed(0) data <- expand.grid(agegp = 0:9, region = 1:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp * SEX + region mod <- mod_pois(formula = formula, data = data, exposure = popn) |> set_prior(agegp ~ RW(sd = 0)) ans_obtained <- make_terms_effectfree(mod) ans_expected <- factor(c("(Intercept)", rep("agegp", times = 9), rep("SEX", times = 2), rep("region", times = 2), rep("agegp:SEX", times = 20)), levels = c("(Intercept)", "agegp", "SEX", "region", "agegp:SEX")) expect_identical(ans_obtained, ans_expected) }) ## 'make_terms_hyper' --------------------------------------------------------- test_that("'make_terms_hyper' works with valid inputs", { set.seed(0) data <- expand.grid(agegp = 0:9, region = 1:3, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp * SEX + region mod <- mod_pois(formula = formula, data = data, exposure = popn) ans_obtained <- make_terms_hyper(mod) ans_expected <- factor(c("agegp", "region", "agegp:SEX"), levels = c("(Intercept)", "agegp", "SEX", "region", "agegp:SEX")) expect_identical(ans_obtained, ans_expected) }) ## 'make_terms_hyperrandfree' ------------------------------------------------- test_that("'make_terms_hyperrandfree' works", { set.seed(0) data <- expand.grid(age = 0:9, time = 2000:2005, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age + sex*time mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- set_prior(mod, sex:time ~ Lin()) ans_obtained <- make_terms_hyperrandfree(mod) ans_expected <- factor(rep("sex:time", 2), levels = c("(Intercept)", "age", "sex", "time", "sex:time")) expect_identical(ans_obtained, ans_expected) }) ## 'make_use_term' ------------------------------------------------------------ test_that("'make_use_term' works", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:3, sex = c("F", "M"), time = 1:3, deaths = 3) mod <- mod_pois(deaths ~ age * sex + age * region + sex * time, data = data, exposure = 1) vars_inner <- c("sex", "age") ans_obtained <- make_use_term(mod = mod, vars_inner = vars_inner) ans_expected <- c(T, T, T, F, F, T, F, F) names(ans_expected) <- names(mod$priors) expect_identical(ans_obtained, ans_expected) }) test_that("'make_use_term' throws correct error when 'vars_inner' has invalid variable", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:3, sex = c("F", "M"), time = 1:3, deaths = 3) mod <- mod_pois(deaths ~ age * sex + age * region + sex * time, data = data, exposure = 1) vars_inner <- c("sex", "wrong") expect_error(make_use_term(mod = mod, vars_inner = vars_inner), "`vars_inner` has variable not found in model.") }) test_that("'make_use_term' throws correct error when cannot form term from 'vars_inner'", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:3, sex = c("F", "M"), time = 1:3, deaths = 3) mod <- mod_pois(deaths ~ age : sex + age : region + sex * time, data = data, exposure = 1) vars_inner <- "age" expect_error(make_use_term(mod = mod, vars_inner = vars_inner), "No terms in model can be formed from `vars_inner`.") }) test_that("'make_use_term' throws correct error when can form all terms from 'vars_inner'", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:3, sex = c("F", "M"), time = 1:3, deaths = 3) mod <- mod_pois(deaths ~ age : sex + age : region + sex * time, data = data, exposure = 1) vars_inner <- c("age", "sex", "region", "time") expect_error(make_use_term(mod = mod, vars_inner = vars_inner), "All terms in model can be formed from `vars_inner`.") }) ## 'make_uses_hyper' ---------------------------------------------------------- test_that("'make_uses_hyper' works with valid inputs", { set.seed(0) data <- expand.grid(agegp = 0:9, region = 1:3, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp * SEX + region mod <- mod_pois(formula = formula, data = data, exposure = popn) %>% set_prior(agegp ~ NFix()) ans_obtained <- make_uses_hyper(mod) ans_expected <- c("(Intercept)" = 0L, agegp = 0L, SEX = 0L, region = 1L, "agegp:SEX" = 1L) expect_identical(ans_obtained, ans_expected) }) ## 'make_uses_hyperrandfree' -------------------------------------------------- test_that("'make_uses_hyperrandfree' works", { set.seed(0) data <- expand.grid(age = 0:9, time = 2000:2005, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age + sex*time mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- set_prior(mod, sex:time ~ Lin()) ans_obtained <- make_uses_hyperrandfree(mod) ans_expected <- c("(Intercept)" = 0L, age = 0L, sex = 0L, time = 0L, "sex:time" = 1L) expect_identical(ans_obtained, ans_expected) }) ## 'make_uses_matrix_effectfree_effect' --------------------------------------- test_that("'make_uses_matrix_effectfree_effect' works with valid inputs", { set.seed(0) data <- expand.grid(agegp = 0:9, region = 1:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp * SEX + region mod <- mod_pois(formula = formula, data = data, exposure = popn) %>% set_prior(agegp ~ Sp()) ans_obtained <- make_uses_matrix_effectfree_effect(mod) ans_expected <- c("(Intercept)" = 0L, agegp = 1L, SEX = 0L, region = 0L, "agegp:SEX" = 1L) expect_identical(ans_obtained, ans_expected) }) ## 'make_uses_matrix_effectfree_effect' --------------------------------------------- test_that("'make_uses_offset_effectfree_effect' works with valid inputs", { set.seed(0) data <- expand.grid(agegp = 0:9, region = 1:2, SEX = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ agegp * SEX + region mod <- mod_pois(formula = formula, data = data, exposure = popn) %>% set_prior(agegp ~ Sp()) ans_obtained <- make_uses_offset_effectfree_effect(mod) ans_expected <- c("(Intercept)" = 0L, agegp = 0L, SEX = 0L, region = 0L, "agegp:SEX" = 0L) expect_identical(ans_obtained, ans_expected) }) ## 'make_vals_ag' ------------------------------------------------------------- test_that("'make_vals_ag' works with model with offset", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:2, sex = c("F", "M"), time = 1:2) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex + region mod <- mod_pois(formula = formula, data = data, exposure = popn) ans_obtained <- make_vals_ag(mod) data_ag <- aggregate(data[c("deaths", "popn")], data[c("age", "region", "sex")], sum) data_ag <- data_ag[with(data_ag, order(age, sex, region)), ] ans_expected <- list(outcome = data_ag[["deaths"]], offset = data_ag[["popn"]], matrices_effect_outcome = make_matrices_effect_outcome(data_ag, mod$dimnames_terms)) expect_equal(ans_obtained, ans_expected) }) test_that("'make_vals_ag' works with model without offset", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:2, sex = c("F", "M"), time = 1:2) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex + region mod <- mod_pois(formula = formula, data = data, exposure = 1) ans_obtained <- make_vals_ag(mod) data_ag <- aggregate(data["deaths"], data[c("age", "sex", "region")], sum) ans_expected <- list(outcome = data_ag[["deaths"]], offset = rep(1, times = nrow(data_ag)), matrices_effect_outcome = make_matrices_effect_outcome(data_ag, mod$dimnames_terms)) expect_equal(ans_obtained, ans_expected) }) ## 'make_vals_in_lik' ------------------------------------------------------------- test_that("'make_vals_in_lik' works with model with offset", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:2, sex = c("F", "M"), time = 1:2) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) data$popn[1] <- 0 data$deaths[1] <- 0 formula <- deaths ~ age * sex + region mod <- mod_pois(formula = formula, data = data, exposure = popn) ans_obtained <- make_vals_in_lik(mod) ans_expected <- list(outcome = mod$outcome[-1], offset = mod$offset[-1], matrices_effect_outcome = make_matrices_effect_outcome(data[-1,], mod$dimnames_terms)) expect_equal(ans_obtained, ans_expected) }) test_that("'make_vals_in_lik' works with model with offset", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:2, sex = c("F", "M"), time = 1:2) data$deaths <- rpois(n = nrow(data), lambda = 10) data$deaths[1] <- NA formula <- deaths ~ age * sex + region mod <- mod_pois(formula = formula, data = data, exposure = 1) ans_obtained <- make_vals_in_lik(mod) ans_expected <- list(outcome = mod$outcome[-1], offset = mod$offset[-1], matrices_effect_outcome = make_matrices_effect_outcome(data[-1,], mod$dimnames_terms)) expect_equal(ans_obtained, ans_expected) }) ## 'make_vars_inner' ---------------------------------------------------------- test_that("'make_vars_inner' works with age, sex, time present", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:2, sex = c("F", "M"), time = 1:2) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex + region + time mod <- mod_pois(formula = formula, data = data, exposure = popn) ans_obtained <- make_vars_inner(mod) ans_expected <- c("age", "sex", "time") expect_identical(ans_obtained, ans_expected) }) test_that("'make_vars_inner' works with age, sex present", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:2, sex = c("F", "M"), time = 1:2) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex + region mod <- mod_pois(formula = formula, data = data, exposure = popn) expect_message(make_vars_inner(mod), "Setting `vars_inner` to \"age\" and \"sex\".") ans_obtained <- suppressMessages(make_vars_inner(mod)) ans_expected <- c("age", "sex") expect_identical(ans_obtained, ans_expected) }) test_that("'make_vars_inner' throws correct error with age, sex, time not present", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:2, sex = c("F", "M"), time = 1:2) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ region mod <- mod_pois(formula = formula, data = data, exposure = popn) expect_error(make_vars_inner(mod), "Unable to infer `vars_inner`.") }) ## 'n_col' -------------------------------------------------------------------- test_that("'n_col' works with ordinary matrix", { m <- matrix(1:6, nr = 2) expect_identical(n_col(m), 3L) }) test_that("'n_col' works with Matrix matrix", { m <- Matrix::Matrix(1:6, nr = 2) expect_identical(n_col(m), 3L) }) ## 'n_comp_svd' --------------------------------------------------------------- test_that("'n_comp_svd' works when no 'n' supplied", { ans_obtained <- n_comp_svd(n_comp = NULL, nm_n_comp = "n", ssvd = HMD) ans_expected <- 3L expect_identical(ans_obtained, ans_expected) }) test_that("'n_comp_svd' works when valid 'n' supplied", { ans_obtained <- n_comp_svd(n_comp = 3, nm_n_comp = "n", ssvd = HMD) ans_expected <- 3L expect_identical(ans_obtained, ans_expected) }) test_that("'n_comp_svd' throws correct error when n is too high", { expect_error(n_comp_svd(n_comp = 11, nm_n_comp = "n_component", ssvd = HMD), "`n_component` larger than number of components of `ssvd`.") }) ## 'print_prior' ------------------------------------------------------- test_that("'print_prior' works", { expect_snapshot(print_prior(RW(), nms = c("s", "along"), slots = c("scale", "along"))) }) ## 'print_prior_header' ------------------------------------------------------- test_that("'print_prior_header' works", { expect_snapshot(print_prior_header(AR())) }) ## 'print_prior_slot' --------------------------------------------------------- test_that("'print_prior_slot' works", { expect_snapshot(print_prior_slot(AR(), nm = "n_coef", slot = "n_coef")) }) ## 'reduce_model_terms' ------------------------------------------------------- test_that("'reduce_model' works with excluding non-intercept terms", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:3, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) set.seed(1) mod <- mod_pois(deaths ~ age * sex + sex * region, data = data, exposure = popn) use_term <- make_use_term(mod, vars_inner = c("age", "sex")) ans_obtained <- reduce_model_terms(mod, use_term = use_term) set.seed(1) ## needed because mod_pois sets random seed ans_expected <- mod_pois(deaths ~ age * sex, data = data, exposure = popn) expect_identical(ans_expected$formula, deaths ~ age * sex) ans_expected$formula <- ans_obtained$formula expect_identical(ans_obtained, ans_expected) }) test_that("'reduce_model' works with excluding intercept", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:3, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) set.seed(1) mod <- mod_pois(deaths ~ age * sex + sex * region, data = data, exposure = popn) use_term <- make_use_term(mod, vars_inner = c("age", "sex")) use_term[[1]] <- FALSE set.seed(1) ans_no_intercept <- reduce_model_terms(mod, use_term = use_term) expect_false("(Intercept)" %in% names(ans_no_intercept$priors)) expect_identical(deparse(ans_no_intercept$formula), "deaths ~ age + sex + age:sex - 1") }) test_that("'reduce_model' works intercept is only term", { set.seed(0) data <- expand.grid(age = 0:9, region = 1:3, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) set.seed(1) mod <- mod_pois(deaths ~ age * sex + sex * region, data = data, exposure = popn) use_term <- make_use_term(mod, vars_inner = c("age", "sex")) use_term[[1]] <- TRUE use_term[-1] <- FALSE set.seed(1) ans_intercept_only <- reduce_model_terms(mod, use_term = use_term) expect_identical(names(ans_intercept_only$priors), "(Intercept)") expect_identical(deparse(ans_intercept_only$formula), "deaths ~ 1") }) ## 'set_priors_known' --------------------------------------------------------- test_that("'set_priors_known' works with valid inputs", { set.seed(0) data <- expand.grid(age = 0:9, sex = c("F", "M")) data$popn <- rpois(n = nrow(data), lambda = 100) data$deaths <- rpois(n = nrow(data), lambda = 10) formula <- deaths ~ age * sex mod <- mod_pois(formula = formula, data = data, exposure = popn) mod <- fit(mod) prior_values <- make_point_est_effects(mod) ans_obtained <- set_priors_known(mod, prior_values = prior_values) ans_expected <- unfit(mod) ans_expected$priors[[1]] <- Known(prior_values[["(Intercept)"]]) ans_expected$priors[[2]] <- Known(prior_values[["age"]]) ans_expected$priors[[3]] <- Known(prior_values[["sex"]]) ans_expected$priors[[4]] <- Known(prior_values[["age:sex"]]) expect_equal(ans_obtained, ans_expected) }) ## 'str_call_args_along' --------------------------------------------------------- test_that("'str_call_args_along' works - no along", { prior <- RW() ans_obtained <- str_call_args_along(prior) ans_expected <- "" expect_identical(ans_obtained, ans_expected) }) test_that("'str_call_args_along' works - has along", { prior <- RW(along = "cohort") ans_obtained <- str_call_args_along(prior) ans_expected <- "along=\"cohort\"" expect_identical(ans_obtained, ans_expected) }) ## 'str_call_args_ar' --------------------------------------------------------- test_that("'str_call_args_ar' works - AR1", { prior <- AR1(s = 0.5) ans_obtained <- str_call_args_ar(prior) ans_expected <- c("s=0.5", "", "", "", "") expect_identical(ans_obtained, ans_expected) }) test_that("'str_call_args_svd' works - AR", { prior <- AR(n_coef = 3, shape1 = 2, shape2 = 2) ans_obtained <- str_call_args_ar(prior) ans_expected <- c("n_coef=3", "", "shape1=2", "shape2=2") expect_identical(ans_obtained, ans_expected) }) ## 'str_call_args_con' -------------------------------------------------------- test_that("'str_call_args_con' works - con is 'none'", { prior <- RW() ans_obtained <- str_call_args_con(prior) ans_expected <- "" expect_identical(ans_obtained, ans_expected) }) test_that("'str_call_args_con' works - con is 'by'", { prior <- RW(con = "by") ans_obtained <- str_call_args_con(prior) ans_expected <- 'con="by"' expect_identical(ans_obtained, ans_expected) }) ## 'str_call_args_lin' -------------------------------------------------------- test_that("'str_call_args_lin' works - mean_slope = 0, sd_slope = 1", { prior <- Lin() ans_obtained <- str_call_args_lin(prior) ans_expected <- c("", "") expect_identical(ans_obtained, ans_expected) }) test_that("'str_call_args_lin' works - sd_slope not 1", { prior <- Lin(sd = 0.3, mean_slope = -0.02) ans_obtained <- str_call_args_lin(prior) ans_expected <- c("mean_slope=-0.02", "sd_slope=0.3") expect_identical(ans_obtained, ans_expected) }) ## 'str_call_args_n_comp' -------------------------------------------------------- test_that("'str_call_args_n_comp' works - no n_comp", { prior <- Sp() ans_obtained <- str_call_args_n_comp(prior) ans_expected <- "" expect_identical(ans_obtained, ans_expected) }) test_that("'str_call_args_n_comp' works - n_comp provided", { prior <- Sp(n_comp=5) ans_obtained <- str_call_args_n_comp(prior) ans_expected <- "n_comp=5" expect_identical(ans_obtained, ans_expected) }) ## 'str_call_args_n_seas' -------------------------------------------------------- test_that("'str_call_args_n_seas' works", { prior <- RW_Seas(n_seas=3) ans_obtained <- str_call_args_n_seas(prior) ans_expected <- "n_seas=3" expect_identical(ans_obtained, ans_expected) }) ## 'str_call_args_s_seas' ------------------------------------------------------ test_that("'str_call_args_s_seas' works", { prior <- RW_Seas(n=2,s_seas = 0.3) ans_obtained <- str_call_args_s_seas(prior) ans_expected <- "s_seas=0.3" expect_identical(ans_obtained, ans_expected) }) ## 'str_call_args_scale' ------------------------------------------------------ test_that("'str_call_args_scale' works - scale = 1", { prior <- N() ans_obtained <- str_call_args_scale(prior) ans_expected <- "" expect_identical(ans_obtained, ans_expected) }) test_that("'str_call_args_scale' works - scale not 1", { prior <- N(s = 0.3) ans_obtained <- str_call_args_scale(prior) ans_expected <- "s=0.3" expect_identical(ans_obtained, ans_expected) }) ## 'str_call_args_sd' ----------------------------------------------------- test_that("'str_call_args_sd' works - sd = 1", { prior <- RW_Seas(n=3) ans_obtained <- str_call_args_sd(prior) ans_expected <- "" expect_identical(ans_obtained, ans_expected) }) test_that("'str_call_args_sd' works - sd not 1", { prior <- RW_Seas(n=2,sd = 0.3) ans_obtained <- str_call_args_sd(prior) ans_expected <- "sd=0.3" expect_identical(ans_obtained, ans_expected) }) ## 'str_call_args_sd_seas' ----------------------------------------------------- test_that("'str_call_args_sd_seas' works - sd_seas = 1", { prior <- RW_Seas(n=3) ans_obtained <- str_call_args_sd_seas(prior) ans_expected <- "" expect_identical(ans_obtained, ans_expected) }) test_that("'str_call_args_sd_seas' works - sd_seas not 1", { prior <- RW_Seas(n=2,sd_seas = 0.3) ans_obtained <- str_call_args_sd_seas(prior) ans_expected <- "sd_seas=0.3" expect_identical(ans_obtained, ans_expected) }) ## 'str_call_args_sd_slope' --------------------------------------------------- test_that("'str_call_args_sd_slope' works - sd_slope = 1", { prior <- RW2() ans_obtained <- str_call_args_sd_slope(prior) ans_expected <- "" expect_identical(ans_obtained, ans_expected) }) test_that("'str_call_args_sd_slope' works - non-default", { prior <- RW2(sd_slope = 0.2) ans_obtained <- str_call_args_sd_slope(prior) ans_expected <- "sd_slope=0.2" expect_identical(ans_obtained, ans_expected) }) ## 'str_call_args_svd' -------------------------------------------------------- test_that("'str_call_args_svd' works - total", { prior <- SVD(HMD) ans_obtained <- str_call_args_svd(prior) ans_expected <- c("HMD", "", "") expect_identical(ans_obtained, ans_expected) }) test_that("'str_call_args_svd' works - indep", { prior <- SVD(HMD, n_comp = 2) ans_obtained <- str_call_args_svd(prior) ans_expected <- c("HMD", "n_comp=2", "") expect_identical(ans_obtained, ans_expected) }) test_that("'str_call_args_svd' works - joint", { prior <- SVD(HMD, indep = FALSE, n_comp = 3) ans_obtained <- str_call_args_svd(prior) ans_expected <- c("HMD", "", "indep=FALSE") expect_identical(ans_obtained, ans_expected) }) ## 'to_factor' ---------------------------------------------------------------- test_that("'to_factor' leaves existing factor unchanged", { x <- factor(letters) expect_identical(to_factor(x), x) }) test_that("'to_factor' orders numeric x by values", { x <- c(3, 1, 0.2, 1) expect_identical(to_factor(x), factor(x, levels = c(0.2, 1, 3))) }) test_that("'to_factor' orders non-numeric non-factor by order of appearance", { x <- c("b", "a", 1, "a") expect_identical(to_factor(x), factor(x, levels = c("b", "a", 1))) })