tests/testthat/test-mean.R

test_that("get_mean.beaver_mcmc_negbin_indep works against an S3 object of class beaver_mcmc_negbin_indep, produces an object with correct properties", { # nolint

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))

  expect_failure(expect_named(nb_monotone_incr, NULL))
  expect_no_error(
    checkmate::assertSubset(
      c("dose", "response"),
      names(nb_monotone_incr)
    )
  )

  nb_monotone_incr_doses <- nb_monotone_incr %>%
    dplyr::distinct(dose) %>%
    dplyr::arrange(dose) %>%
    dplyr::pull(dose)

  load(test_path("fixtures", "nb_indep_mcmc+_objects.Rdata"))

  expect_failure(
    expect_s3_class(nb_indep_model_samples_updatedattr, NA)
  )
  expect_s3_class(
    nb_indep_model_samples_updatedattr,
    "beaver_mcmc_negbin_indep"
  )
  expect_no_error(
    checkmate::assertSubset(
      c("covariate_names", "formula"),
      names(attributes(nb_indep_model_samples_updatedattr))
    )
  )

  samples_process(
    samples = nb_indep_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean.beaver_mcmc_negbin_indep(
      samples = nb_indep_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept,
      u_doses = nb_monotone_incr_doses
    )
  )

  means <- get_mean.beaver_mcmc_negbin_indep(
    samples = nb_indep_model_samples_updatedattr,
    doses = rep(nb_monotone_incr$dose, each = n_mcmc),
    intercept = intercept,
    u_doses = nb_monotone_incr_doses
  )

  mean_checks(
    means = means,
    samples = nb_indep_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_identical(
    get_mean.beaver_mcmc_negbin_indep(
      samples = nb_indep_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept,
      samps = samps,
      u_doses = nb_monotone_incr_doses
    ),
    means
  )
})

test_that("get_mean works identically to get_mean.beaver_mcmc_negbin_indep", {

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))

  nb_monotone_incr_doses <- nb_monotone_incr %>%
    dplyr::distinct(dose) %>%
    dplyr::arrange(dose) %>%
    dplyr::pull(dose)

  load(test_path("fixtures", "nb_indep_mcmc+_objects.Rdata"))

  samples_process(
    samples = nb_indep_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean(
      samples = nb_indep_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept,
      u_doses = nb_monotone_incr_doses
    )
  )
  expect_equal(
    get_mean(
      samples = nb_indep_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept,
      u_doses = nb_monotone_incr_doses
    ),
    get_mean.beaver_mcmc_negbin_indep(
      samples = nb_indep_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept,
      u_doses = nb_monotone_incr_doses
    )
  )
})

test_that("mean_negbin_linear produces an object with correct properties (small scale)", { # nolint

  dose_vals <- 1:3
  n_samps <- 1L

  set.seed(1234)
  b1 <- runif(n_samps, 2.9, 3.1)
  b2 <- runif(n_samps, 1.4, 1.6)

  expect_no_error(
    mean_negbin_linear(
      x = rep(dose_vals, each = n_samps),
      b1 = matrix(
        rep(b1, each = length(dose_vals)),
        nrow = length(b1),
        byrow = TRUE
      ),
      b2 = b2
    )
  )

  means <-
    mean_negbin_linear(
      x = rep(dose_vals, each = n_samps),
      b1 = matrix(
        rep(b1, each = length(dose_vals)),
        nrow = length(b1),
        byrow = TRUE
      ),
      b2 = b2
    )

  expect_true(is.matrix(means))
  expect_identical(nrow(means), n_samps)
  expect_identical(ncol(means), length(dose_vals))
  expect_identical(as.numeric(means), exp(b1 + b2 * dose_vals))
})

test_that("get_mean.beaver_mcmc_negbin_linear works against an S3 object of class beaver_mcmc_negbin_linear, produces an object with correct properties", { # nolint

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))

  expect_failure(expect_named(nb_monotone_incr, NULL))
  expect_no_error(
    checkmate::assertSubset(
      c("dose", "response"),
      names(nb_monotone_incr)
    )
  )

  load(test_path("fixtures", "nb_linear_mcmc+_objects.Rdata"))

  expect_failure(expect_s3_class(nb_linear_model_samples_updatedattr, NA))
  expect_s3_class(
    nb_linear_model_samples_updatedattr,
    "beaver_mcmc_negbin_linear"
  )
  expect_no_error(
    checkmate::assertSubset(
      c("covariate_names", "formula"),
      names(attributes(nb_linear_model_samples_updatedattr))
    )
  )

  samples_process(
    samples = nb_linear_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean.beaver_mcmc_negbin_linear(
      samples = nb_linear_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )

  means <- get_mean.beaver_mcmc_negbin_linear(
    samples = nb_linear_model_samples_updatedattr,
    doses = rep(nb_monotone_incr$dose, each = n_mcmc),
    intercept = intercept
  )

  mean_checks(
    means = means,
    samples = nb_linear_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_identical(
    get_mean.beaver_mcmc_negbin_linear(
      samples = nb_linear_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept,
      samps = samps
    ),
    means
  )
})

test_that("get_mean works identically to get_mean.beaver_mcmc_negbin_linear", {

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))
  load(test_path("fixtures", "nb_linear_mcmc+_objects.Rdata"))

  samples_process(
    samples = nb_linear_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean(
      samples = nb_linear_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )
  expect_equal(
    get_mean(
      samples = nb_linear_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    ),
    get_mean.beaver_mcmc_negbin_linear(
      samples = nb_linear_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )
})

test_that("mean_negbin_quad produces an object with correct properties (small scale)", { # nolint

  dose_vals <- 1:3
  n_samps <- 1L

  set.seed(1234)
  b1 <- runif(n_samps, 2.9, 3.1)
  b2 <- runif(n_samps, 1.4, 1.6)
  b3 <- runif(n_samps, -3.1, -2.9) # nolint

  expect_no_error(
    mean_negbin_quad(
      x = rep(dose_vals, each = n_samps),
      b1 = matrix(
        rep(b1, each = length(dose_vals)),
        nrow = length(b1),
        byrow = TRUE
      ),
      b2 = b2,
      b3 = b3
    )
  )

  means <-
    mean_negbin_quad(
      x = rep(dose_vals, each = n_samps),
      b1 = matrix(
        rep(b1, each = length(dose_vals)),
        nrow = length(b1),
        byrow = TRUE
      ),
      b2 = b2,
      b3 = b3
    )

  expect_true(is.matrix(means))
  expect_identical(nrow(means), n_samps)
  expect_identical(ncol(means), length(dose_vals))
  expect_identical(
    as.numeric(means),
    exp(b1 + b2 * dose_vals + b3 * dose_vals ^ 2)
  )
})

test_that("get_mean.beaver_mcmc_negbin_quad works against an S3 object of class beaver_mcmc_negbin_quad, produces an object with correct properties", { # nolint

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))

  expect_failure(expect_named(nb_monotone_incr, NULL))
  expect_no_error(
    checkmate::assertSubset(
      c("dose", "response"),
      names(nb_monotone_incr)
    )
  )

  load(test_path("fixtures", "nb_quad_mcmc+_objects.Rdata"))

  expect_failure(expect_s3_class(nb_quad_model_samples_updatedattr, NA))
  expect_s3_class(nb_quad_model_samples_updatedattr, "beaver_mcmc_negbin_quad")
  expect_no_error(
    checkmate::assertSubset(
      c("covariate_names", "formula"),
      names(attributes(nb_quad_model_samples_updatedattr))
    )
  )

  samples_process(
    samples = nb_quad_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean.beaver_mcmc_negbin_quad(
      samples = nb_quad_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )

  means <- get_mean.beaver_mcmc_negbin_quad(
    samples = nb_quad_model_samples_updatedattr,
    doses = rep(nb_monotone_incr$dose, each = n_mcmc),
    intercept = intercept
  )

  mean_checks(
    means = means,
    samples = nb_quad_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_identical(
    get_mean.beaver_mcmc_negbin_quad(
      samples = nb_quad_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept,
      samps = samps
    ),
    means
  )
})

test_that("get_mean works identically to get_mean.beaver_mcmc_negbin_quad", {

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))
  load(test_path("fixtures", "nb_quad_mcmc+_objects.Rdata"))

  samples_process(
    samples = nb_quad_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean(
      samples = nb_quad_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )
  expect_equal(
    get_mean(
      samples = nb_quad_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    ),
    get_mean.beaver_mcmc_negbin_quad(
      samples = nb_quad_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )
})

test_that("mean_negbin_emax produces an object with correct properties (small scale)", { # nolint

  dose_vals <- 1:3
  n_samps <- 1L

  set.seed(1234)
  b1 <- runif(n_samps, 1.9, 2.1)
  b2 <- runif(n_samps, 2.9, 3.1)
  b3 <- runif(n_samps, 0.2, 0.4)

  expect_no_error(
    mean_negbin_emax(
      x = rep(dose_vals, each = n_samps),
      b1 = matrix(
        rep(b1, each = length(dose_vals)),
        nrow = length(b1),
        byrow = TRUE
      ),
      b2 = b2,
      b3 = b3
    )
  )

  means <-
    mean_negbin_emax(
      x = rep(dose_vals, each = n_samps),
      b1 = matrix(
        rep(b1, each = length(dose_vals)),
        nrow = length(b1),
        byrow = TRUE
      ),
      b2 = b2,
      b3 = b3
    )

  expect_true(is.matrix(means))
  expect_identical(nrow(means), n_samps)
  expect_identical(ncol(means), length(dose_vals))
  expect_identical(
    as.numeric(means),
    exp(b1 + b2 * dose_vals / (b3 + dose_vals))
  )
})

test_that("get_mean.beaver_mcmc_negbin_emax works against an S3 object of class beaver_mcmc_negbin_emax, produces an object with correct properties", { # nolint

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))

  expect_failure(expect_named(nb_monotone_incr, NULL))
  expect_no_error(
    checkmate::assertSubset(
      c("dose", "response"),
      names(nb_monotone_incr)
    )
  )

  load(test_path("fixtures", "nb_emax_mcmc+_objects.Rdata"))

  expect_failure(expect_s3_class(nb_emax_model_samples_updatedattr, NA))
  expect_s3_class(nb_emax_model_samples_updatedattr, "beaver_mcmc_negbin_emax")
  expect_no_error(
    checkmate::assertSubset(
      c("covariate_names", "formula"),
      names(attributes(nb_emax_model_samples_updatedattr))
    )
  )

  samples_process(
    samples = nb_emax_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean.beaver_mcmc_negbin_emax(
      samples = nb_emax_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )

  means <- get_mean.beaver_mcmc_negbin_emax(
    samples = nb_emax_model_samples_updatedattr,
    doses = rep(nb_monotone_incr$dose, each = n_mcmc),
    intercept = intercept
  )

  mean_checks(
    means = means,
    samples = nb_emax_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_identical(
    get_mean.beaver_mcmc_negbin_emax(
      samples = nb_emax_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept,
      samps = samps
    ),
    means
  )
})

test_that("get_mean works identically to get_mean.beaver_mcmc_negbin_emax", {

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))
  load(test_path("fixtures", "nb_emax_mcmc+_objects.Rdata"))

  samples_process(
    samples = nb_emax_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean(
      samples = nb_emax_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )
  expect_equal(
    get_mean(
      samples = nb_emax_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    ),
    get_mean.beaver_mcmc_negbin_emax(
      samples = nb_emax_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )
})

test_that("mean_negbin_exp produces an object with correct properties (small scale)", { # nolint

  dose_vals <- 1:3
  n_samps <- 1L

  set.seed(1234)
  b1 <- runif(n_samps, 2.1, 2.3)
  b2 <- runif(n_samps, 2.5, 2.7)
  b3 <- runif(n_samps, 2.9, 3.1)

  expect_no_error(
    mean_negbin_exp(
      x = rep(dose_vals, each = n_samps),
      b1 = matrix(
        rep(b1, each = length(dose_vals)),
        nrow = length(b1),
        byrow = TRUE
      ),
      b2 = b2,
      b3 = b3
    )
  )

  means <-
    mean_negbin_exp(
      x = rep(dose_vals, each = n_samps),
      b1 = matrix(
        rep(b1, each = length(dose_vals)),
        nrow = length(b1),
        byrow = TRUE
      ),
      b2 = b2,
      b3 = b3
    )

  expect_true(is.matrix(means))
  expect_identical(nrow(means), n_samps)
  expect_identical(ncol(means), length(dose_vals))
  expect_identical(
    as.numeric(means),
    exp(b1 + b2 * (1 - exp(- b3 * dose_vals)))
  )
})

test_that("get_mean.beaver_mcmc_negbin_exp works against an S3 object of class beaver_mcmc_negbin_exp, produces an object with correct properties", { # nolint

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))

  expect_failure(expect_named(nb_monotone_incr, NULL))
  expect_no_error(
    checkmate::assertSubset(
      c("dose", "response"),
      names(nb_monotone_incr)
    )
  )

  load(test_path("fixtures", "nb_exp_mcmc+_objects.Rdata"))

  expect_failure(expect_s3_class(nb_exp_model_samples_updatedattr, NA))
  expect_s3_class(nb_exp_model_samples_updatedattr, "beaver_mcmc_negbin_exp")
  expect_no_error(
    checkmate::assertSubset(
      c("covariate_names", "formula"),
      names(attributes(nb_exp_model_samples_updatedattr))
    )
  )

  samples_process(
    samples = nb_exp_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean.beaver_mcmc_negbin_exp(
      samples = nb_exp_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )

  means <- get_mean.beaver_mcmc_negbin_exp(
    samples = nb_exp_model_samples_updatedattr,
    doses = rep(nb_monotone_incr$dose, each = n_mcmc),
    intercept = intercept
  )

  mean_checks(
    means = means,
    samples = nb_exp_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_identical(
    get_mean.beaver_mcmc_negbin_exp(
      samples = nb_exp_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept,
      samps = samps
    ),
    means
  )
})

test_that("get_mean works identically to get_mean.beaver_mcmc_negbin_exp", {

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))
  load(test_path("fixtures", "nb_exp_mcmc+_objects.Rdata"))

  samples_process(
    samples = nb_exp_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean(
      samples = nb_exp_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )
  expect_equal(
    get_mean(
      samples = nb_exp_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    ),
    get_mean.beaver_mcmc_negbin_exp(
      samples = nb_exp_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )
})

test_that("mean_negbin_sigmoid_emax produces an object with correct properties (small scale)", { # nolint

  dose_vals <- 1:3
  n_samps <- 1L

  set.seed(1234)
  b1 <- runif(n_samps, 1.9, 2.1)
  b2 <- runif(n_samps, 2.9, 3.1)
  b3 <- runif(n_samps, 0.2, 0.4)
  b4 <- runif(n_samps, 1.1, 1.3)

  expect_no_error(
    mean_negbin_sigmoid_emax(
      x = rep(dose_vals, each = n_samps),
      b1 = matrix(
        rep(b1, each = length(dose_vals)),
        nrow = length(b1),
        byrow = TRUE
      ),
      b2 = b2,
      b3 = b3,
      b4 = b4
    )
  )

  means <-
    mean_negbin_sigmoid_emax(
      x = rep(dose_vals, each = n_samps),
      b1 = matrix(
        rep(b1, each = length(dose_vals)),
        nrow = length(b1),
        byrow = TRUE
      ),
      b2 = b2,
      b3 = b3,
      b4 = b4
    )

  expect_true(is.matrix(means))
  expect_identical(nrow(means), n_samps)
  expect_identical(ncol(means), length(dose_vals))
  expect_identical(
    as.numeric(means),
    exp(b1 + b2 * dose_vals ^ b4 / (b3 ^ b4 + dose_vals ^ b4))
  )
})

test_that("get_mean.beaver_mcmc_negbin_sigmoid_emax works against an S3 object of class beaver_mcmc_negbin_sigmoid_emax, produces an object with correct properties", { # nolint

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))

  expect_failure(expect_named(nb_monotone_incr, NULL))
  expect_no_error(
    checkmate::assertSubset(
      c("dose", "response"),
      names(nb_monotone_incr)
    )
  )

  load(test_path("fixtures", "nb_sigmoid_emax_mcmc+_objects.Rdata"))

  expect_failure(
    expect_s3_class(nb_sigmoid_emax_model_samples_updatedattr, NA)
  )
  expect_s3_class(
    nb_sigmoid_emax_model_samples_updatedattr,
    "beaver_mcmc_negbin_sigmoid_emax"
  )
  expect_no_error(
    checkmate::assertSubset(
      c("covariate_names", "formula"),
      names(attributes(nb_sigmoid_emax_model_samples_updatedattr))
    )
  )

  samples_process(
    samples = nb_sigmoid_emax_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean.beaver_mcmc_negbin_sigmoid_emax(
      samples = nb_sigmoid_emax_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )

  means <- get_mean.beaver_mcmc_negbin_sigmoid_emax(
    samples = nb_sigmoid_emax_model_samples_updatedattr,
    doses = rep(nb_monotone_incr$dose, each = n_mcmc),
    intercept = intercept
  )

  mean_checks(
    means = means,
    samples = nb_sigmoid_emax_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_identical(
    get_mean.beaver_mcmc_negbin_sigmoid_emax(
      samples = nb_sigmoid_emax_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept,
      samps = samps
    ),
    means
  )
})

test_that("get_mean works identically to get_mean.beaver_mcmc_negbin_sigmoid_emax", { # nolint

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))
  load(test_path("fixtures", "nb_sigmoid_emax_mcmc+_objects.Rdata"))

  samples_process(
    samples = nb_sigmoid_emax_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean(
      samples = nb_sigmoid_emax_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )
  expect_equal(
    get_mean(
      samples = nb_sigmoid_emax_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    ),
    get_mean.beaver_mcmc_negbin_sigmoid_emax(
      samples = nb_sigmoid_emax_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )
})

test_that("mean_negbin_loglinear produces an object with correct properties (small scale)", { # nolint

  dose_vals <- 1:3
  n_samps <- 1L

  set.seed(1234)
  b1 <- runif(n_samps, 2.9, 3.1)
  b2 <- runif(n_samps, 1.4, 1.6)

  expect_no_error(
    mean_negbin_loglinear(
      x = rep(dose_vals, each = n_samps),
      b1 = matrix(
        rep(b1, each = length(dose_vals)),
        nrow = length(b1),
        byrow = TRUE
      ),
      b2 = b2
    )
  )

  means <-
    mean_negbin_loglinear(
      x = rep(dose_vals, each = n_samps),
      b1 = matrix(
        rep(b1, each = length(dose_vals)),
        nrow = length(b1),
        byrow = TRUE
      ),
      b2 = b2
    )

  expect_true(is.matrix(means))
  expect_identical(nrow(means), n_samps)
  expect_identical(ncol(means), length(dose_vals))
  expect_identical(as.numeric(means), exp(b1 + b2 * log(1 + dose_vals)))
})

test_that("get_mean.beaver_mcmc_negbin_loglinear works against an S3 object of class beaver_mcmc_negbin_loglinear, produces an object with correct properties", { # nolint

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))

  expect_failure(expect_named(nb_monotone_incr, NULL))
  expect_no_error(
    checkmate::assertSubset(
      c("dose", "response"),
      names(nb_monotone_incr)
    )
  )

  load(test_path("fixtures", "nb_loglinear_mcmc+_objects.Rdata"))

  expect_failure(
    expect_s3_class(nb_loglinear_model_samples_updatedattr, NA)
  )
  expect_s3_class(
    nb_loglinear_model_samples_updatedattr,
    "beaver_mcmc_negbin_loglinear"
  )
  expect_no_error(
    checkmate::assertSubset(
      c("covariate_names", "formula"),
      names(attributes(nb_loglinear_model_samples_updatedattr))
    )
  )

  samples_process(
    samples = nb_loglinear_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean.beaver_mcmc_negbin_loglinear(
      samples = nb_loglinear_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )

  means <- get_mean.beaver_mcmc_negbin_loglinear(
    samples = nb_loglinear_model_samples_updatedattr,
    doses = rep(nb_monotone_incr$dose, each = n_mcmc),
    intercept = intercept
  )

  mean_checks(
    means = means,
    samples = nb_loglinear_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_identical(
    get_mean.beaver_mcmc_negbin_loglinear(
      samples = nb_loglinear_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept,
      samps = samps
    ),
    means
  )
})

test_that("get_mean works identically to get_mean.beaver_mcmc_negbin_loglinear", { # nolint

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))
  load(test_path("fixtures", "nb_loglinear_mcmc+_objects.Rdata"))

  samples_process(
    samples = nb_loglinear_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean(
      samples = nb_loglinear_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )
  expect_equal(
    get_mean(
      samples = nb_loglinear_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    ),
    get_mean.beaver_mcmc_negbin_loglinear(
      samples = nb_loglinear_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )
})

test_that("mean_negbin_logquad produces an object with correct properties (small scale)", { # nolint

  dose_vals <- 1:3
  n_samps <- 1L

  set.seed(1234)
  b1 <- runif(n_samps, 2.9, 3.1)
  b2 <- runif(n_samps, 1.4, 1.6)
  b3 <- runif(n_samps, -3.1, -2.9) # nolint

  expect_no_error(
    mean_negbin_logquad(
      x = rep(dose_vals, each = n_samps),
      b1 = matrix(
        rep(b1, each = length(dose_vals)),
        nrow = length(b1),
        byrow = TRUE
      ),
      b2 = b2,
      b3 = b3
    )
  )

  means <-
    mean_negbin_logquad(
      x = rep(dose_vals, each = n_samps),
      b1 = matrix(
        rep(b1, each = length(dose_vals)),
        nrow = length(b1),
        byrow = TRUE
      ),
      b2 = b2,
      b3 = b3
    )

  expect_true(is.matrix(means))
  expect_identical(nrow(means), n_samps)
  expect_identical(ncol(means), length(dose_vals))
  expect_identical(
    as.numeric(means),
    exp(b1 + b2 * log(1 + dose_vals) + b3 * log(1 + dose_vals) ^ 2)
  )
})

test_that("get_mean.beaver_mcmc_negbin_logquad works against an S3 object of class beaver_mcmc_negbin_logquad, produces an object with correct properties", { # nolint

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))

  expect_failure(expect_named(nb_monotone_incr, NULL))
  expect_no_error(
    checkmate::assertSubset(
      c("dose", "response"),
      names(nb_monotone_incr)
    )
  )

  load(test_path("fixtures", "nb_logquad_mcmc+_objects.Rdata"))

  expect_failure(
    expect_s3_class(nb_logquad_model_samples_updatedattr, NA)
  )
  expect_s3_class(
    nb_logquad_model_samples_updatedattr,
    "beaver_mcmc_negbin_logquad"
  )
  expect_no_error(
    checkmate::assertSubset(
      c("covariate_names", "formula"),
      names(attributes(nb_logquad_model_samples_updatedattr))
    )
  )

  samples_process(
    samples = nb_logquad_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean.beaver_mcmc_negbin_logquad(
      samples = nb_logquad_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )

  means <- get_mean.beaver_mcmc_negbin_logquad(
    samples = nb_logquad_model_samples_updatedattr,
    doses = rep(nb_monotone_incr$dose, each = n_mcmc),
    intercept = intercept
  )

  mean_checks(
    means = means,
    samples = nb_logquad_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_identical(
    get_mean.beaver_mcmc_negbin_logquad(
      samples = nb_logquad_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept,
      samps = samps
    ),
    means
  )
})

test_that("get_mean works identically to get_mean.beaver_mcmc_negbin_logquad", { # nolint

  nb_monotone_incr <- readRDS(test_path("fixtures", "nb_monotone_incr.rds"))
  load(test_path("fixtures", "nb_logquad_mcmc+_objects.Rdata"))

  samples_process(
    samples = nb_logquad_model_samples_updatedattr,
    data = nb_monotone_incr
  )

  expect_no_error(
    get_mean(
      samples = nb_logquad_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )
  expect_equal(
    get_mean(
      samples = nb_logquad_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    ),
    get_mean.beaver_mcmc_negbin_logquad(
      samples = nb_logquad_model_samples_updatedattr,
      doses = rep(nb_monotone_incr$dose, each = n_mcmc),
      intercept = intercept
    )
  )
})

Try the beaver package in your browser

Any scripts or data that you put into this service are public.

beaver documentation built on May 29, 2024, 1:49 a.m.