tests/testthat/test_rater.R

In rater: Statistical Models of Repeated Categorical Rating Data

test_that("verbose flag works", {
  expect_silent(
    suppressWarnings(
      rater(anesthesia, "dawid_skene",
            chains = 1, iter = 200, verbose = FALSE)
      )
  )
})

test_that("Passing model as string works", {

  # Unexplained warnings in the past - potentially flaky...
  skip_on_cran()

  # This was failing previously because the check of whether the model and
  # format are compatible requires an *actual* model, so we have to validate
  # and convert string -> model object before validating.
  expect_ok(
    rater(caries, "dawid_skene", method = "optim", data_format = "grouped")
  )

  fit_function <- rater(anesthesia, dawid_skene(), method = "optim")
  fit_string <- rater(anesthesia, "dawid_skene", method = "optim")
  expect_equal(fit_function, fit_string)
})

test_that("rater infernce is 'correct'", {
  # TODO This is a stopgap solution designed to detect large changes in
  # behaviour. In future, it would be great to have a full framework to assess
  # the the performance of the inference.
  pi_est <- point_estimate(ds_fit_optim, pars = "pi")[[1]]
  # Correct value is 0.41.
  expect_lt(pi_est[[2]], 0.45)
  expect_gt(pi_est[[2]], 0.35)
})

test_that("rater returns objects of the correct type", {
  expect_true(is.rater_fit(ds_fit))
  expect_true(is.mcmc_fit(ds_fit))
  expect_true(is.optim_fit(ds_fit_optim))
})

test_that("rater errors correctly", {
  expect_error(
    rater(anesthesia, "not_a_proper_model"),
    "Invalid model string specification."
  )
  expect_error(
    rater(caries, hier_dawid_skene(), data_format = "grouped"),
    "Grouped data can only be used with the Dawid and Skene model."
  )
  expect_error(
    rater(1:10, dawid_skene()),
    "`data` must be a data.frame or matrix."
  )
  expect_error(
    rater(data.frame(1, 2), dawid_skene()),
    "Long format `data` must have exactly three columns."
  )
  expect_error(
    rater(data.frame(item = 1, rater = 1, ratingg = 1), dawid_skene()),
    "Long format `data` must have three columns with names: item, rater, rating."
  )
  expect_error(
    rater(data.frame(anything = 1, not_n = 1), dawid_skene(), data_format = "grouped"),
    "The last column must be named `n`."
  )

  expect_snapshot(
    rater(data.frame(item = 0, rater = 0, rating = 0), dawid_skene()),
    error = TRUE
  )

  expect_snapshot(
    rater(data.frame(thing = 0, n = 0), dawid_skene(), data_format = "grouped"),
    error = TRUE
  )
})

test_that("rater provides useful messages for probably not long data", {

  expect_error(
    suppressMessages(
      expect_message(
        rater(data.frame(1, 2, 3, 3), "dawid_skene"),
        "Is your data in wide format? Consider using `data_format = wide`."
      )
    )
  )

  expect_error(
    suppressMessages(
      expect_message(
        rater(data.frame(1, 2, 3, 31), "dawid_skene"),
        "Is your data in grouped format? Consider using `data_format = grouped`."
      )
    )
  )
})

test_that("parse_priors is correct for the Dawid-Skene model", {

  anesthesia_list <- as_stan_data(anesthesia, "long", default_colnames)

  K <- anesthesia_list$K
  J <- anesthesia_list$J
  ds_priors <- parse_priors(dawid_skene(), K, J)

  # Construct the default priors.
  default_alpha <- rep(3, K)

  N <- 8
  p <- 0.6
  on_diag <- N * p
  off_diag <- N * (1 - p) / (K - 1)
  beta_slice <- matrix(off_diag, nrow = K, ncol = K)
  diag(beta_slice) <- on_diag
  default_beta <- array(dim = c(J, K, K))
  for (j in 1:J) {
    default_beta[j, , ] <- beta_slice
  }

  expect_equal(ds_priors$alpha, default_alpha)
  expect_equal(ds_priors$beta, default_beta)

  test_alpha <- rep(9, K)
  test_beta_mat <- matrix(17, nrow = K, ncol = K)
  test_beta_array <- array(dim = c(J, K, K))
  for (j in 1:J) {
    test_beta_array[j, , ] <- test_beta_mat
  }

  ds_priors_mat <- parse_priors(
    dawid_skene(alpha = test_alpha, beta = test_beta_mat),
    K,
    J
  )

  expect_equal(ds_priors_mat$alpha, test_alpha)
  expect_equal(ds_priors_mat$beta, test_beta_array)

  ds_priors_array <- parse_priors(
    dawid_skene(alpha = test_alpha, beta = test_beta_array),
    K,
    J
  )

  expect_equal(ds_priors_array$beta, test_beta_array)
})

test_that("parse_priors is correct for the Hierarchical Dawid-Skene model", {
  default_alpha <- rep(3, K)
  test_alpha <- rep(9, K)

  hds_priors <- parse_priors(hier_dawid_skene(), K, J)
  expect_equal(hds_priors$alpha, default_alpha)

  hds_priors <- parse_priors(hier_dawid_skene(alpha = test_alpha), K, J)
  expect_equal(hds_priors$alpha, test_alpha)
})

test_that("parse_priors is correct for the Class conditional Dawid-Skene model", {

  test_beta_1 <- rep(1, K)
  test_beta_2 <- rep(98, K)
  test_alpha <- rep(9, K)

  ccds_priors <- parse_priors(
    class_conditional_dawid_skene(
      alpha = test_alpha,
      beta_1 = test_beta_1,
      beta_2 = test_beta_2
    ),
    K,
    J
  )

  expect_equal(ccds_priors$alpha, test_alpha)
  expect_equal(ccds_priors$beta_1, test_beta_1)
  expect_equal(ccds_priors$beta_2, test_beta_2)
})

test_that("as_stan_data handles wide data correctly", {

  wide_data <- data.frame(c(3, 2, 2), c(4, 2, 2))
  long_data <- data.frame(item = c(1, 1, 2, 2, 3, 3),
                          rater = c(1, 2, 1, 2, 1, 2),
                          rating = c(3, 4, 2, 2, 2, 2))

  expect_equal(as_stan_data(wide_data, "wide", default_colnames),
               as_stan_data(long_data, "long", default_colnames))
})

test_that("create_inits() works for the Dawid-Skene model", {
  anesthesia_stan_data <- as_stan_data(anesthesia, "long", default_colnames)
  K <- anesthesia_stan_data$K
  J <- anesthesia_stan_data$J

  pi_init <- rep(1 / K, K)
  theta_init <- array(0.2 / (K - 1), c(J, K, K))
  for (j in 1:J) {
      diag(theta_init[j, ,]) <- 0.8
  }

  expect_equal(
    create_inits(dawid_skene(), anesthesia_stan_data),
    function(n) list(theta = theta_init, pi = pi_init),
    ignore_function_env = TRUE
  )
})

test_that("create_inits() works for the class conditional Dawid-Skene model", {
  anesthesia_stan_data <- as_stan_data(anesthesia, "long", default_colnames)
  K <- anesthesia_stan_data$K
  J <- anesthesia_stan_data$J

  pi_init <- rep(1 / K, K)
  theta_init <- matrix(0.8, nrow = J, ncol = K)

  expect_equal(
    create_inits(class_conditional_dawid_skene(), anesthesia_stan_data),
    function(n) list(theta = theta_init, pi = pi_init),
    ignore_function_env = TRUE
  )
})

test_that("create_inits() works for the hierarchical Dawid-Skene model", {
  anesthesia_stan_data <- as_stan_data(anesthesia, "long", default_colnames)

  hds_init_func <- create_inits(hier_dawid_skene(), anesthesia_stan_data)
  expect_named(hds_init_func(), c("pi", "mu", "sigma", "beta_raw"))
})

test_that("Invalid `long_data_colnames` generates appropriate errors", {

  expect_error(
    rater(anesthesia, "dawid_skene", long_data_colnames = lapply(1:4, identity)),
    "`long_data_colnames` must be length three."
  )

  expect_error(
    rater(anesthesia, "dawid_skene", long_data_colnames = 1:3),
    "`long_data_colnames` must be a character vector."
  )

  expect_error(
    rater(anesthesia, "dawid_skene", long_data_colnames = letters[1:3]),
    "`long_data_colnames` must have names: `item`, `rater` and `rating`."
  )

  expect_error(
    rater(anesthesia, "dawid_skene",
          long_data_colnames = c(item = "a", rater = "b", ratingg = "c")),
    "`long_data_colnames` must have names: `item`, `rater` and `rating`."
  )

  expect_warning(
    rater(caries, "dawid_skene", data_format = "grouped", method = "optim",
          long_data_colnames = c(item = "a", rater = "b", rating = "c")),
    "Non-default `long_data_colnames` will be ignored as `data_format` is not `'long'`"
  )
})

test_that("Non-default `long_data_colnames` works", {

  skip_on_cran()

  new_anesthesia_1 <- anesthesia
  colnames(new_anesthesia_1) <- c("a", "b", "c")

  expect_identical(
    rater(new_anesthesia_1, "dawid_skene", method = "optim",
          long_data_colnames = c(item = "a", rater = "b", rating = "c")
          ),
    rater(anesthesia, "dawid_skene", method = "optim")
  )

  new_anesthesia_2 <- anesthesia
  colnames(new_anesthesia_2) <- c("a", "b", "c")
  new_anesthesia_2 <- new_anesthesia_2[, c(2, 1, 3)]

  expect_identical(
    rater(new_anesthesia_2, "dawid_skene", method = "optim",
          long_data_colnames = c(item = "a", rater = "b", rating = "c")
          ),
    rater(anesthesia, "dawid_skene", method = "optim")
  )
})