tests/testthat/test-bage_confidential-methods.R

In bage: Bayesian Estimation and Forecasting of Age-Specific Rates

## 'draw_outcome_confidential' ------------------------------------------------

test_that("'draw_outcome_confidential' works with 'bage_confidential_rr3'", {
  set.seed(0)
  confidential <- new_bage_confidential_rr3()
  outcome_obs <- rvec::rpois_rvec(n = 5, lambda = 10, n_draw = 5)
  set.seed(1)
  ans_obtained <- draw_outcome_confidential(confidential = confidential,
                                            outcome_obs = outcome_obs)
  set.seed(1)
  ans_expected <- poputils::rr3(outcome_obs)
  expect_identical(ans_obtained, ans_expected)
})


## 'draw_outcome_obs_given_conf' ----------------------------------------------

test_that("'draw_outcome_obs_given_conf' works with rr3, pois, no na, has disp", {
  set.seed(0)
  confidential <- new_bage_confidential_rr3()
  outcome_obs <- rpois(n = 100, lambda = 50)
  outcome_conf <- poputils::rr3(outcome_obs)
  offset <- rep(10, 100)
  expected_obs <- rvec::rgamma_rvec(n = 100,
                                    shape = 2,
                                    rate = 0.4,
                                    n_draw = 100)
  disp_obs <- rvec::runif_rvec(n = 100, n_draw = 100)
  ans <- draw_outcome_obs_given_conf(confidential = confidential,
                                     nm_distn = "pois",
                                     outcome_conf = outcome_conf,
                                     offset = offset,
                                     expected_obs = expected_obs,
                                     disp_obs = disp_obs,
                                     sd_obs = NULL)
  expect_true(all(abs(as.matrix(ans) - outcome_conf) <= 2L))
  expect_equal(mean(as.numeric(ans)), 50, tolerance = 0.05)
})

test_that("'draw_outcome_obs_given_conf' works with rr3, pois, no na, no disp", {
  set.seed(0)
  confidential <- new_bage_confidential_rr3()
  outcome_obs <- rpois(n = 100, lambda = 50)
  outcome_conf <- poputils::rr3(outcome_obs)
  offset <- rep(10, 100)
  expected_obs <- rvec::rgamma_rvec(n = 100,
                                    shape = 2,
                                    rate = 0.4,
                                    n_draw = 100)
  ans <- draw_outcome_obs_given_conf(confidential = confidential,
                                     nm_distn = "pois",
                                     outcome_conf = outcome_conf,
                                     offset = offset,
                                     expected_obs = expected_obs,
                                     disp_obs = NULL,
                                     sd_obs = NULL)
  expect_true(all(abs(as.matrix(ans) - outcome_conf) <= 2L))
  expect_equal(mean(as.numeric(ans)), 50, tolerance = 0.05)
})

test_that("'draw_outcome_obs_given_conf' works with rr3, pois, has na, has disp", {
  set.seed(0)
  confidential <- new_bage_confidential_rr3()
  outcome_obs <- rpois(n = 100, lambda = 50)
  outcome_conf <- poputils::rr3(outcome_obs)
  outcome_conf[4] <- NA
  offset <- rep(10, 100)
  offset[1] <- NA
  expected_obs <- rvec::rgamma_rvec(n = 100,
                                    shape = 2,
                                    rate = 0.4,
                                    n_draw = 100)
  disp_obs <- rvec::runif_rvec(n = 100, n_draw = 100)
  ans <- draw_outcome_obs_given_conf(confidential = confidential,
                                     nm_distn = "pois",
                                     outcome_conf = outcome_conf,
                                     offset = offset,
                                     expected_obs = expected_obs,
                                     disp_obs = disp_obs,
                                     sd_obs = NULL)
  expect_true(all(abs(as.matrix(ans[-c(1, 4)]) - outcome_conf[-c(1, 4)]) <= 2L))
  expect_equal(mean(as.numeric(ans), na.rm = TRUE), 50, tolerance = 0.01)
})

test_that("'draw_outcome_obs_given_conf' works with rr3, pois, has na, no disp", {
  set.seed(0)
  confidential <- new_bage_confidential_rr3()
  outcome_obs <- rpois(n = 100, lambda = 50)
  outcome_conf <- poputils::rr3(outcome_obs)
  outcome_conf[4] <- NA
  offset <- rep(10, 100)
  offset[1] <- NA
  expected_obs <- rvec::rgamma_rvec(n = 100,
                                    shape = 2,
                                    rate = 0.4,
                                    n_draw = 100)
  ans <- draw_outcome_obs_given_conf(confidential = confidential,
                                     nm_distn = "pois",
                                     outcome_conf = outcome_conf,
                                     offset = offset,
                                     expected_obs = expected_obs,
                                     disp_obs = NULL,
                                     sd_obs = NULL)
  expect_true(all(abs(as.matrix(ans[-c(1, 4)]) - outcome_conf[-c(1, 4)]) <= 2L))
  expect_equal(mean(as.numeric(ans), na.rm = TRUE), 50, tolerance = 0.01)
})

test_that("'draw_outcome_obs_given_conf' works with rr3, pois, noise datamod", {
  set.seed(0)
  confidential <- new_bage_confidential_rr3()
  outcome_obs <- rpois(n = 100, lambda = 50)
  outcome_conf <- poputils::rr3(outcome_obs)
  offset <- rep(10, 100)
  expected_obs <- rvec::rgamma_rvec(n = 100,
                                    shape = 2,
                                    rate = 0.4,
                                    n_draw = 100)
  ans <- draw_outcome_obs_given_conf(confidential = confidential,
                                     nm_distn = "pois",
                                     outcome_conf = outcome_conf,
                                     offset = offset,
                                     expected_obs = expected_obs,
                                     disp_obs = NULL,
                                     sd_obs = rep(3, 100))
  expect_true(all(as.numeric(ans - outcome_conf) <= 2))
  expect_equal(mean(as.numeric(ans)), 50, tolerance = 0.01)
})

test_that("'draw_outcome_obs_given_conf' works with rr3, binom, no na, has disp", {
  set.seed(0)
  confidential <- new_bage_confidential_rr3()
  outcome_obs <- rbinom(n = 100, size = 100, prob = 0.5)
  outcome_conf <- poputils::rr3(outcome_obs)
  offset <- rep(100, 100)
  expected_obs <- rvec::rbeta_rvec(n = 100,
                                   shape1 = 10,
                                   shape2 = 10,
                                   n_draw = 100)
  disp_obs <- rvec::runif_rvec(n = 100, n_draw = 100)
  ans <- draw_outcome_obs_given_conf(confidential = confidential,
                                     nm_distn = "binom",
                                     outcome_conf = outcome_conf,
                                     offset = offset,
                                     expected_obs = expected_obs,
                                     disp_obs = disp_obs,
                                     sd_obs = NULL)
  expect_true(all(abs(as.matrix(ans) - outcome_conf) <= 2L))
  ans <- rvec::draws_mean(ans)
  expect_equal(mean(ans), 50, tolerance = 0.01)
})

test_that("'draw_outcome_obs_given_conf' works with rr3, binom, no na, no disp", {
  set.seed(0)
  confidential <- new_bage_confidential_rr3()
  outcome_obs <- rbinom(n = 100, size = 100, prob = 0.5)
  outcome_conf <- poputils::rr3(outcome_obs)
  offset <- rep(100, 100)
  expected_obs <- rvec::rbeta_rvec(n = 100,
                                   shape1 = 10,
                                   shape2 = 10,
                                   n_draw = 100)
  disp_obs <- rvec::runif_rvec(n = 100, n_draw = 100)
  ans <- draw_outcome_obs_given_conf(confidential = confidential,
                                     nm_distn = "binom",
                                     outcome_conf = outcome_conf,
                                     offset = offset,
                                     expected_obs = expected_obs,
                                     disp_obs = NULL,
                                     sd_obs = NULL)
  expect_true(all(abs(as.matrix(ans) - outcome_conf) <= 2L))
  ans <- rvec::draws_mean(ans)
  expect_equal(mean(ans), 50, tolerance = 0.01)
})

test_that("'draw_outcome_obs_given_conf' works with rr3, binom, has na, has disp", {
  set.seed(0)
  confidential <- new_bage_confidential_rr3()
  outcome_obs <- rbinom(n = 100, size = 100, prob = 0.5)
  outcome_obs[4] <- NA
  outcome_conf <- poputils::rr3(outcome_obs)
  offset <- rep(100, 100)
  offset[1] <- NA
  expected_obs <- rvec::rbeta_rvec(n = 100,
                                   shape1 = 10,
                                   shape2 = 10,
                                   n_draw = 100)
  disp_obs <- rvec::runif_rvec(n = 100, n_draw = 100)
  ans <- draw_outcome_obs_given_conf(confidential = confidential,
                                     nm_distn = "binom",
                                     outcome_conf = outcome_conf,
                                     offset = offset,
                                     expected_obs = expected_obs,
                                     disp_obs = disp_obs,
                                     sd_obs = NULL)
  expect_true(all(abs(as.matrix(ans[-c(1, 4)]) - outcome_conf[-c(1, 4)]) <= 2L))
  ans <- rvec::draws_mean(ans)
  expect_equal(mean(ans, na.rm = TRUE), 50, tolerance = 0.01)
})

test_that("'draw_outcome_obs_given_conf' works with rr3, binom, has na, no disp", {
  set.seed(0)
  confidential <- new_bage_confidential_rr3()
  outcome_obs <- rbinom(n = 100, size = 100, prob = 0.5)
  outcome_obs[4] <- NA
  outcome_conf <- poputils::rr3(outcome_obs)
  offset <- rep(100, 100)
  offset[1] <- NA
  expected_obs <- rvec::rbeta_rvec(n = 100,
                                   shape1 = 10,
                                   shape2 = 10,
                                   n_draw = 100)
  disp_obs <- rvec::runif_rvec(n = 100, n_draw = 100)
  ans <- draw_outcome_obs_given_conf(confidential = confidential,
                                     nm_distn = "binom",
                                     outcome_conf = outcome_conf,
                                     offset = offset,
                                     expected_obs = expected_obs,
                                     disp_obs = NULL,
                                     sd_obs = NULL)
  expect_true(all(abs(as.matrix(ans[-c(1, 4)]) - outcome_conf[-c(1, 4)]) <= 2L))
  ans <- rvec::draws_mean(ans)
  expect_equal(mean(ans, na.rm = TRUE), 50, tolerance = 0.01)
})

test_that("'draw_outcome_obs_given_conf' throws appropriate error with invalid nm_distn", {
  set.seed(0)
  set.seed(0)
  confidential <- new_bage_confidential_rr3()
  outcome_obs <- rbinom(n = 100, size = 100, prob = 0.5)
  outcome_obs[4] <- NA
  outcome_conf <- poputils::rr3(outcome_obs)
  offset <- rep(100, 100)
  offset[1] <- NA
  disp_obs <- rvec::runif_rvec(n = 100, n_draw = 100)
  expected_obs <- rvec::rbeta_rvec(n = 100,
                                   shape1 = 10,
                                   shape2 = 10,
                                   n_draw = 100)
  expect_error(draw_outcome_obs_given_conf(confidential = confidential,
                                           nm_distn = "wrong",
                                           outcome_conf = outcome_conf,
                                           offset = offset,
                                           expected_obs = expected_obs,
                                           disp_obs = disp_obs,
                                           sd_obs = NULL),
               "Internal error: Invalid value for `nm_distn`.")
  expect_error(draw_outcome_obs_given_conf(confidential = confidential,
                                           nm_distn = "wrong",
                                           outcome_conf = outcome_conf,
                                           offset = offset,
                                           expected_obs = expected_obs,
                                           disp_obs = NULL,
                                           sd_obs = NULL),
               "Internal error: Invalid value for `nm_distn`.")
})


## 'make_i_lik_part' ----------------------------------------------------------

test_that("'make_i_lik_part' works with bage_confidential_rr3", {
  x <- new_bage_confidential_rr3()
  expect_identical(make_i_lik_part(x), 10L)
})


## 'str_call_confidential' ----------------------------------------------------

test_that("'str_call_confidential' works", {
  expect_identical(str_call_confidential(new_bage_confidential_rr3()),
                   "rr3")
})