tests/testthat/test-zzz-class-dcm-estimate.R

In measr: Bayesian Psychometric Measurement Using 'Stan'

test_that("measrdcm creation works", {
  # dina test ------------------------------------------------------------------
  expect_s7_class(rstn_dina, measrfit)
  expect_s7_class(rstn_dina, measrdcm)
  expect_identical(rstn_dina@model_spec@qmatrix, dina_spec@qmatrix)
  expect_identical(
    rstn_dina@model_spec@qmatrix_meta$attribute_names,
    dina_spec@qmatrix_meta$attribute_names
  )
  expect_identical(rstn_dina@model_spec@qmatrix_meta$item_identifier, "item_id")
  expect_identical(
    rstn_dina@model_spec@qmatrix_meta$item_names,
    rlang::set_names(1:20, paste0("item_", 1:20))
  )
  expect_identical(
    rstn_dina@model_spec@measurement_model,
    dina_spec@measurement_model
  )
  expect_identical(
    rstn_dina@model_spec@structural_model,
    dina_spec@structural_model
  )
  expect_identical(rstn_dina@model_spec@priors, dina_spec@priors)

  expect_identical(
    rstn_dina@data$item_identifier,
    rstn_dina@model_spec@qmatrix_meta$item_identifier
  )
  expect_identical(
    rstn_dina@data$item_names,
    rstn_dina@model_spec@qmatrix_meta$item_names
  )

  expect_s3_class(rstn_dina@stancode, "glue")
  expect_s7_class(rstn_dina@method, optim)
  expect_s7_class(rstn_dina@backend, rstan)
  expect_true(is.list(rstn_dina@model))
  expect_true(
    is.list(rstn_dina@respondent_estimates) &&
      rlang::is_empty(rstn_dina@respondent_estimates)
  )
  expect_true(is.list(rstn_dina@fit) && rlang::is_empty(rstn_dina@fit))
  expect_true(
    is.list(rstn_dina@criteria) &&
      rlang::is_empty(rstn_dina@criteria)
  )
  expect_true(
    is.list(rstn_dina@reliability) &&
      rlang::is_empty(rstn_dina@reliability)
  )
  expect_true(is.character(rstn_dina@file) && rlang::is_empty(rstn_dina@file))
  expect_identical(
    names(rstn_dina@version),
    c("R", "R-measr", "R-rstan", "R-StanHeaders", "Stan")
  )

  dina_comp <- get_draws(rstn_dina, vars = c("Vc", "slip", "guess")) |>
    posterior::as_draws_df() |>
    tibble::as_tibble() |>
    dplyr::select(-c(".chain", ".iteration", ".draw")) |>
    tidyr::pivot_longer(cols = everything()) |>
    dplyr::mutate(name = gsub("Vc", "nu", .data$name)) |>
    dplyr::left_join(true_dinoa, by = c("name" = "param"))

  comp_cor <- cor(dina_comp$value, dina_comp$true)
  comp_dif <- abs(dina_comp$value - dina_comp$true)

  expect_gte(comp_cor, 0.85)
  expect_lte(max(comp_dif), 0.2)

  # dino test ------------------------------------------------------------------
  expect_s7_class(rstn_dino, measrfit)
  expect_s7_class(rstn_dino, measrdcm)
  expect_identical(rstn_dino@model_spec, dino_spec)
  expect_identical(
    rstn_dino@data$item_identifier,
    rstn_dino@model_spec@qmatrix_meta$item_identifier
  )
  expect_identical(
    rstn_dino@data$item_names,
    rstn_dino@model_spec@qmatrix_meta$item_names
  )

  expect_s3_class(rstn_dino@stancode, "glue")
  expect_s7_class(rstn_dino@method, optim)
  expect_s7_class(rstn_dino@backend, rstan)
  expect_true(is.list(rstn_dino@model))
  expect_true(
    is.list(rstn_dino@respondent_estimates) &&
      rlang::is_empty(rstn_dino@respondent_estimates)
  )
  expect_true(is.list(rstn_dino@fit) && rlang::is_empty(rstn_dino@fit))
  expect_true(
    is.list(rstn_dino@criteria) &&
      rlang::is_empty(rstn_dino@criteria)
  )
  expect_true(
    is.list(rstn_dino@reliability) &&
      rlang::is_empty(rstn_dino@reliability)
  )
  expect_true(is.character(rstn_dino@file) && rlang::is_empty(rstn_dino@file))
  expect_identical(
    names(rstn_dino@version),
    c("R", "R-measr", "R-rstan", "R-StanHeaders", "Stan")
  )

  dino_comp <- get_draws(rstn_dino, vars = c("Vc", "slip", "guess")) |>
    posterior::as_draws_df() |>
    tibble::as_tibble() |>
    dplyr::select(-c(".chain", ".iteration", ".draw")) |>
    tidyr::pivot_longer(cols = everything()) |>
    dplyr::mutate(name = gsub("Vc", "nu", .data$name)) |>
    dplyr::left_join(true_dinoa, by = c("name" = "param"))

  comp_cor <- cor(dino_comp$value, dino_comp$true)
  comp_dif <- abs(dino_comp$value - dino_comp$true)

  expect_gte(comp_cor, 0.85)
  expect_lte(max(comp_dif), 0.2)
})

test_that("measrdcm setters work", {
  new_fit <- measrfit()

  # @model_spec ----------------------------------------------------------------
  new_fit@model_spec <- rstn_dina@model_spec
  expect_identical(new_fit@model_spec, rstn_dina@model_spec)
  expect_error(
    {
      new_fit@model_spec <- dino_spec
    },
    "@model_spec is read-only"
  )

  # @data ----------------------------------------------------------------------
  expect_error(
    {
      new_fit@data <- rstn_dina@data
    },
    "@data is read-only"
  )

  # @stancode ------------------------------------------------------------------
  expect_error(
    {
      new_fit@stancode <- rstn_dina@stancode
    },
    "@stancode is read-only"
  )

  # @method --------------------------------------------------------------------
  expect_error(
    {
      new_fit@method <- rstn_dina@method
    },
    "@method is read-only"
  )

  # @algorithm -----------------------------------------------------------------
  expect_error(
    {
      new_fit@algorithm <- rstn_dina@algorithm
    },
    "@algorithm is read-only"
  )

  # @backend -------------------------------------------------------------------
  expect_identical(new_fit@backend, stanbackend())
  expect_error(
    {
      new_fit@backend <- rstn_dina@backend
    },
    "@backend is read-only"
  )

  # @model ---------------------------------------------------------------------
  expect_error(
    {
      new_fit@model <- rstn_dina@model
    },
    "@model is read-only"
  )

  # @file ----------------------------------------------------------------------
  expect_error(
    {
      new_fit@file <- "my/path"
    },
    "@file is read-only"
  )

  # @version -------------------------------------------------------------------
  expect_error(
    {
      new_fit@version <- "0.0.0.9000"
    },
    "@version is read-only"
  )
})

test_that("validator works", {
  expect_error(
    {
      measrfit(backend = rstan(), method = mcmc(), model = rstn_dina@model)
    },
    "@model must be a .*stanfit.* object"
  )

  expect_error(
    {
      measrfit(backend = cmdstanr(), method = optim(), model = rstn_dina@model)
    },
    "@model must be a .*CmdStanMLE.* object"
  )

  expect_error(
    {
      measrfit(backend = cmdstanr(), method = mcmc(), model = rstn_dina@model)
    },
    "@model must be a .*CmdStanMCMC.* object"
  )
})