tests/testthat/test_cpca.R

In multivarious: Extensible Data Structures for Multivariate Analysis

library(testthat)
library(multivarious) # Load the package

# Helper function to prepare Iris data for cPCA context
# X_f: Between-group means (Foreground, 3 samples x 4 features)
# X_b: Original centered data (Background, 150 samples x 4 features)
prepare_iris_data <- function() {
  data(iris)
  X_full <- iris[, 1:4] # Numeric features only

  # Calculate between-group means (X_f)
  species <- iris$Species
  levels_species <- levels(species)
  X_f <- vapply(levels_species, function(sp) {
    colMeans(X_full[species == sp, , drop = FALSE])
  }, FUN.VALUE = numeric(ncol(X_full)))
  X_f <- t(X_f)
  rownames(X_f) <- levels_species

  # Use original data centered by overall mean as X_b (common use case)
  overall_means <- colMeans(X_full)
  # Note: cPCAplus internally centers by background mean if center_background=TRUE
  # Here we just return the raw data for X_b
  X_b <- as.matrix(X_full)

  return(list(X_f = X_f, X_b = X_b, n_f = nrow(X_f), n_b = nrow(X_b), p = ncol(X_f)))
}

test_that("cPCAplus basic structure and methods ('geigen' family)", {
  iris_data <- prepare_iris_data()
  X_f <- iris_data$X_f
  X_b <- iris_data$X_b
  n_components <- 2 # Test fewer components than features/samples

  # Test a geigen family method
  method <- "geigen" # Can also test "primme", "sdiag" if available/desired

  # --- Test with lambda = 0 ---
  result_lambda_0 <- cPCAplus(X_f, X_b, ncomp = n_components, lambda = 0, method = method)

  # Check classes
  expect_s3_class(result_lambda_0, "cPCAplus")
  expect_s3_class(result_lambda_0, "bi_projector")

  # Check dimensions using accessors
  expect_equal(ncomp(result_lambda_0), n_components)
  expect_equal(nrow(coef(result_lambda_0)), iris_data$p) # features x ncomp
  expect_equal(ncol(coef(result_lambda_0)), n_components)
  expect_equal(nrow(scores(result_lambda_0)), iris_data$n_f) # n_f_samples x ncomp
  expect_equal(ncol(scores(result_lambda_0)), n_components)

  # Check values/sdev length
  expect_length(result_lambda_0$values, n_components)
  expect_length(result_lambda_0$sdev, n_components)
  expect_equal(result_lambda_0$sdev, sqrt(pmax(result_lambda_0$values, 0)))

  # Check preprocessor class (use correct name)
  expect_s3_class(result_lambda_0$preproc, "pre_processor")

  # Check stored method info
  expect_equal(result_lambda_0$method_used$method, method)
  expect_equal(result_lambda_0$method_used$ncomp, n_components)

  # --- Test with lambda > 0 ---
  result_lambda_pos <- cPCAplus(X_f, X_b, ncomp = n_components, lambda = 0.1, method = method)

  # Basic structure checks again
  expect_s3_class(result_lambda_pos, "cPCAplus")
  expect_equal(ncomp(result_lambda_pos), n_components)
  expect_length(result_lambda_pos$values, n_components)

  # Check if results differ due to lambda (eigenvalues should change)
  # Use tolerance due to potential numerical noise
  expect_false(isTRUE(all.equal(result_lambda_0$values, result_lambda_pos$values)))

  # --- Test Strategy Force ---
  # Force "feature" strategy (should work for small iris data)
  result_feat_strat <- cPCAplus(X_f, X_b, ncomp = n_components, lambda = 0, method = method, strategy = "feature")
  expect_equal(result_feat_strat$method_used$strategy, "feature")
  # Compare with auto strategy result (should be identical here as auto chooses feature)
  expect_equal(coef(result_lambda_0), coef(result_feat_strat))
  expect_equal(result_lambda_0$values, result_feat_strat$values)

})

test_that("cPCAplus method 'corpcor'", {
  iris_data <- prepare_iris_data()
  X_f <- iris_data$X_f
  X_b <- iris_data$X_b
  n_components <- 2

  # --- Test corpcor method ---
  result_corpcor <- cPCAplus(X_f, X_b, ncomp = n_components, lambda = 0.1, method = "corpcor")

  # Check classes (includes corpcor_pca)
  expect_s3_class(result_corpcor, "cPCAplus")
  expect_s3_class(result_corpcor, "corpcor_pca")
  expect_s3_class(result_corpcor, "bi_projector")

  # Check dimensions
  expect_equal(ncomp(result_corpcor), n_components)
  expect_equal(nrow(coef(result_corpcor)), iris_data$p)
  expect_equal(nrow(scores(result_corpcor)), iris_data$n_f)

  # Check values/sdev length (these are from PCA on whitened data)
  expect_length(result_corpcor$values, n_components)
  expect_length(result_corpcor$sdev, n_components)
  expect_equal(result_corpcor$values, result_corpcor$sdev^2)

  # Check preprocessor
  expect_s3_class(result_corpcor$preproc, "pre_processor")

  # Check stored method info
  expect_equal(result_corpcor$method_used$method, "corpcor")

})

# Test centering option
test_that("cPCAplus center_background = FALSE works", {
  iris_data <- prepare_iris_data()
  # Pre-center data using background mean
  mean_b <- colMeans(iris_data$X_b)
  X_f_cent <- sweep(iris_data$X_f, 2, mean_b, "-")
  X_b_cent <- sweep(iris_data$X_b, 2, mean_b, "-")

  res_no_center <- cPCAplus(X_f_cent, X_b_cent, ncomp = 2, center_background = FALSE, method = "geigen")

  expect_s3_class(res_no_center, "cPCAplus")
  expect_equal(ncomp(res_no_center), 2)
  # Check preprocessor class
  expect_s3_class(res_no_center$preproc, "pre_processor")

  # Compare with default centering (should be numerically close)
  res_center <- cPCAplus(iris_data$X_f, iris_data$X_b, ncomp = 2, center_background = TRUE, method = "geigen")
  expect_equal(res_no_center$values, res_center$values, tolerance = 1e-6)
  # Check cosine similarity of eigenvectors (more robust than direct comparison)
  v1 <- coef(res_no_center)
  v2 <- coef(res_center)
  cos_sim <- abs(diag(crossprod(v1, v2))) # Absolute cosine similarity
  expect_true(all(cos_sim > 0.999)) # Expect vectors to point in same/opposite direction
})


# TODO: Add tests for strategy="sample" if feasible (requires p >> n data)
# TODO: Add tests for edge cases (e.g., ncomp=1, singular Rb)