tests/testthat/test-mml-cpp11-backend.R

In mfrmr: Estimation and Diagnostics for Many-Facet Measurement Models

make_mml_backend_fixture <- function(model = c("RSM", "PCM")) {
  model <- match.arg(model)
  d <- mfrmr:::sample_mfrm_data(seed = 42)
  prep <- mfrmr:::prepare_mfrm_data(
    d,
    person_col = "Person",
    facet_cols = c("Rater", "Task", "Criterion"),
    score_col = "Score"
  )
  roles <- mfrmr:::resolve_step_and_slope_facets(
    model = model,
    step_facet = if (identical(model, "PCM")) "Criterion" else NULL,
    slope_facet = NULL,
    facet_names = prep$facet_names
  )
  signs <- mfrmr:::build_facet_signs(prep$facet_names)
  idx <- mfrmr:::build_indices(
    prep,
    step_facet = roles$step_facet,
    slope_facet = roles$slope_facet
  )
  cfg <- mfrmr:::build_estimation_config(
    prep = prep,
    model = model,
    method = "MML",
    step_facet = roles$step_facet,
    slope_facet = roles$slope_facet,
    weight_col = NULL,
    facet_signs = signs$signs,
    positive_facets = signs$positive_facets,
    noncenter_facet = "Person",
    dummy_facets = character(0),
    anchor_df = NULL,
    group_anchor_df = NULL,
    population = NULL
  )
  start <- mfrmr:::build_initial_param_vector(cfg$config, cfg$sizes)
  params <- mfrmr:::expand_params(start, cfg$sizes, cfg$config)

  list(
    idx = idx,
    config = cfg$config,
    quad = mfrmr:::gauss_hermite_normal(5L),
    params = params,
    base_eta = mfrmr:::compute_base_eta(idx, params, cfg$config)
  )
}

test_that("cpp11 backend availability and gating are stable", {
  expect_true(mfrmr:::mfrm_cpp11_backend_available())
  expect_false(mfrmr:::mfrm_use_cpp11_backend(list(model = "RSM")))
  expect_false(mfrmr:::mfrm_use_cpp11_backend(list(model = "PCM")))
  expect_false(mfrmr:::mfrm_use_cpp11_backend(list(model = "GPCM")))
  expect_false(mfrmr:::mfrm_use_cpp11_backend(
    list(model = "PCM"),
    include_linear_part = TRUE
  ))

  old_opt <- options(mfrmr.use_cpp11_backend = TRUE)
  on.exit(options(old_opt), add = TRUE)
  expect_true(mfrmr:::mfrm_use_cpp11_backend(list(model = "RSM")))
  expect_true(mfrmr:::mfrm_use_cpp11_backend(list(model = "PCM")))
})

test_that("cpp11 MML kernel matches the pure-R reference for RSM and PCM", {
  skip_if_not(mfrmr:::mfrm_cpp11_backend_available())

  for (model in c("RSM", "PCM")) {
    fixture <- make_mml_backend_fixture(model)

    logprob_r <- mfrmr:::mfrm_mml_logprob_bundle_r(
      idx = fixture$idx,
      config = fixture$config,
      quad = fixture$quad,
      params = fixture$params,
      base_eta = fixture$base_eta,
      include_probs = TRUE
    )
    logprob_cpp <- mfrmr:::mfrm_mml_logprob_bundle_cpp11(
      idx = fixture$idx,
      config = fixture$config,
      quad = fixture$quad,
      params = fixture$params,
      base_eta = fixture$base_eta,
      include_probs = TRUE
    )

    expect_equal(logprob_cpp$log_prob_mat, logprob_r$log_prob_mat, tolerance = 1e-12, info = model)
    expect_equal(logprob_cpp$quad_basis$nodes, logprob_r$quad_basis$nodes, tolerance = 1e-12, info = model)
    expect_identical(logprob_cpp$person_int, logprob_r$person_int)

    for (q in seq_along(logprob_r$prob_list)) {
      expect_equal(
        unname(logprob_cpp$prob_list[[q]]),
        unname(logprob_r$prob_list[[q]]),
        tolerance = 1e-12,
        info = paste(model, q)
      )
    }

    posterior_r <- mfrmr:::mfrm_mml_posterior_bundle(logprob_r)
    posterior_cpp <- mfrmr:::mfrm_mml_posterior_bundle(logprob_cpp)
    expect_equal(
      posterior_cpp$person_bundle$log_marginal,
      posterior_r$person_bundle$log_marginal,
      tolerance = 1e-12,
      info = model
    )
    expect_equal(
      posterior_cpp$obs_posterior,
      posterior_r$obs_posterior,
      tolerance = 1e-12,
      info = model
    )

    expected_r <- mfrmr:::mfrm_mml_expected_category_bundle_r(
      logprob_bundle = logprob_r,
      posterior_bundle = posterior_r,
      include_p_geq = TRUE
    )
    expected_cpp <- mfrmr:::mfrm_mml_expected_category_bundle(
      logprob_bundle = logprob_cpp,
      posterior_bundle = posterior_cpp,
      include_p_geq = TRUE
    )

    expect_equal(
      unname(expected_cpp$posterior_prob),
      unname(expected_r$posterior_prob),
      tolerance = 1e-12,
      info = model
    )
    expect_equal(expected_cpp$expected_k, expected_r$expected_k, tolerance = 1e-12, info = model)
    expect_equal(expected_cpp$var_k, expected_r$var_k, tolerance = 1e-12, info = model)
    expect_equal(
      unname(expected_cpp$p_geq),
      unname(expected_r$p_geq),
      tolerance = 1e-12,
      info = model
    )
  }
})

test_that("automatic MML bundle dispatch uses cpp11 backend for RSM and PCM", {
  skip_if_not(mfrmr:::mfrm_cpp11_backend_available())
  old_opt <- options(mfrmr.use_cpp11_backend = TRUE)
  on.exit(options(old_opt), add = TRUE)

  for (model in c("RSM", "PCM")) {
    fixture <- make_mml_backend_fixture(model)
    auto_bundle <- mfrmr:::mfrm_mml_logprob_bundle(
      idx = fixture$idx,
      config = fixture$config,
      quad = fixture$quad,
      params = fixture$params,
      base_eta = fixture$base_eta,
      include_probs = TRUE
    )
    cpp_bundle <- mfrmr:::mfrm_mml_logprob_bundle_cpp11(
      idx = fixture$idx,
      config = fixture$config,
      quad = fixture$quad,
      params = fixture$params,
      base_eta = fixture$base_eta,
      include_probs = TRUE
    )
    expect_equal(auto_bundle$log_prob_mat, cpp_bundle$log_prob_mat, tolerance = 1e-12, info = model)
  }
})