tests/testthat/test-irm.R

In exametrika: Test Data Engineering

library(exametrika)

### IRM (Infinite Relational Model) Tests

### Setup - run model once and share across tests.
### Skipped on CRAN because the J35S515 Gibbs run dominates the file's
### runtime; all dependent tests below also call skip_on_cran().
NOT_CRAN <- identical(Sys.getenv("NOT_CRAN"), "true")
if (NOT_CRAN) {
  tmp_irm <- dataFormat(J35S515)
  result_irm <- Biclustering_IRM(tmp_irm, gamma_c = 1, gamma_f = 1, seed = 123, verbose = FALSE)
}

test_that("IRM Basic Execution", {
  skip_on_cran()
  # Basic structure checks
  expect_s3_class(result_irm, "exametrika")
  expect_true("IRM" %in% class(result_irm))

  # Result components exist
  expect_true(!is.null(result_irm$n_class))
  expect_true(!is.null(result_irm$n_field))
  expect_true(!is.null(result_irm$TRP))
  expect_true(!is.null(result_irm$LCD))
  expect_true(!is.null(result_irm$LFD))
  expect_true(!is.null(result_irm$FRP))
  expect_true(!is.null(result_irm$FieldEstimated))
  expect_true(!is.null(result_irm$ClassEstimated))

  # Dimensions are consistent
  expect_equal(length(result_irm$TRP), result_irm$n_class)
  expect_equal(length(result_irm$LCD), result_irm$n_class)
  expect_equal(length(result_irm$LFD), result_irm$n_field)
  expect_equal(length(result_irm$FieldEstimated), result_irm$testlength)
})

test_that("IRM Backward Compatibility", {
  skip_on_cran()
  # Deprecated field names should still work
  # 2.0.0 で削除: $Nclass はもう無く，$n_class だけが残る
  expect_null(result_irm$Nclass)
  expect_false(is.null(result_irm$n_class))
  # 2.0.0 で削除: $Nfield はもう無く，$n_field だけが残る
  expect_null(result_irm$Nfield)
  expect_false(is.null(result_irm$n_field))
  # 2.0.0 で削除: $N_Cycle はもう無く，$n_cycle だけが残る
  expect_null(result_irm$N_Cycle)
  expect_false(is.null(result_irm$n_cycle))
  expect_equal(result_irm$EM_Cycle, result_irm$em_cycle)
})

test_that("IRM Test Fit Indices", {
  skip_on_cran()
  # TestFitIndices
  expect_true(!is.null(result_irm$TestFitIndices))
  tfi <- result_irm$TestFitIndices
  expect_true(!is.null(tfi$model_log_like))
  expect_true(!is.null(tfi$AIC))
  expect_true(!is.null(tfi$BIC))

  # Log-likelihood should be negative
  expect_true(tfi$model_log_like < 0)

  # log_lik field should match
  expect_equal(result_irm$log_lik, tfi$model_log_like)
})

test_that("IRM FRP Validity", {
  skip_on_cran()
  # FRP should contain values between 0 and 1
  expect_true(all(result_irm$FRP >= 0 & result_irm$FRP <= 1))

  # FRP dimensions: n_field rows x n_class columns
  expect_equal(nrow(result_irm$FRP), result_irm$n_field)
  expect_equal(ncol(result_irm$FRP), result_irm$n_class)
})

test_that("IRM FRPIndex Exists", {
  skip_on_cran()
  # FRPIndex should exist
  expect_true(!is.null(result_irm$FRPIndex))
})

test_that("IRM Seed Reproducibility", {
  skip_on_cran()
  # Same seed should produce identical results
  result_a <- Biclustering_IRM(tmp_irm, gamma_c = 1, gamma_f = 1, seed = 42, verbose = FALSE)
  result_b <- Biclustering_IRM(tmp_irm, gamma_c = 1, gamma_f = 1, seed = 42, verbose = FALSE)

  expect_equal(result_a$n_class, result_b$n_class)
  expect_equal(result_a$n_field, result_b$n_field)
  expect_equal(result_a$FRP, result_b$FRP)
  expect_equal(result_a$TRP, result_b$TRP)
  expect_equal(result_a$FieldEstimated, result_b$FieldEstimated)
  expect_equal(result_a$ClassEstimated, result_b$ClassEstimated)
  expect_equal(result_a$log_lik, result_b$log_lik)
})

test_that("IRM Seed NULL does not set seed", {
  skip_on_cran()
  # With seed = NULL, the function should not call set.seed()
  # and the results should depend on the current RNG state.
  # We verify that the function runs without error with seed = NULL.
  result_null <- Biclustering_IRM(tmp_irm, gamma_c = 1, gamma_f = 1, seed = NULL, verbose = FALSE)
  expect_s3_class(result_null, "exametrika")
  expect_true("IRM" %in% class(result_null))
  expect_true(!is.null(result_null$n_class))
  expect_true(!is.null(result_null$n_field))
})

test_that("IRM Default seed is 123", {
  # Verify the default value of seed parameter is 123
  fn_formals <- formals(Biclustering_IRM.binary)
  expect_equal(fn_formals$seed, 123)
})


test_that("Bug #2 regression: Biclustering_IRM.binary handles missing data", {
  # Real-data missingness (HCI, SAT12) used to crash with
  # "確率ベクトル中にNAがあります" because tmp$U retained the -1
  # missingness marker that propagated through tmp$U %*% fld01.
  # Fixed in v1.14.0 by tmp$U <- tmp$U * tmp$Z masking at line 120.
  skip_on_cran()
  set.seed(20260527)
  n <- 500
  J <- 20
  U <- matrix(rbinom(n * J, 1, 0.55), n, J)
  U[sample.int(n * J, size = round(0.02 * n * J))] <- -1L
  df_miss <- dataFormat(data = U, na = -1)
  expect_true(any(df_miss$Z == 0))

  fit <- suppressWarnings(
    Biclustering_IRM(df_miss,
      gamma_c = 1, gamma_f = 1, mic = 10,
      max_iter = 300, seed = 20260527, verbose = FALSE
    )
  )
  expect_s3_class(fit, "exametrika")
  expect_true("IRM" %in% class(fit))
  expect_true(!is.null(fit$n_class) && fit$n_class >= 1)
  expect_true(!is.null(fit$n_field) && fit$n_field >= 1)
})