tests/legacyVsNew.R

In GPArotation: Gradient Projection Factor Rotation

# Regression tests: GPForth and GPFoblq against legacy implementations.
# Tests that the 2026.4-1 updates produce exactly identical results
# to the original 2008 implementations.
# Uses identical() for exact equality — no numerical tolerance.

require("GPArotation")

all.ok <- TRUE

# Test matrices
data(Harman, package = "GPArotation")
data(Thurstone, package = "GPArotation")

A2 <- Harman8   # 8 x 2
A3 <- box26     # 26 x 3

# --- Test 1: GPForth vs GPForth.legacy, varimax, identity start ---
r1  <- GPForth(A2, method = "varimax")
r1L <- GPArotation:::GPForth.legacy(A2, method = "varimax")

if (!identical(r1$loadings, r1L$loadings)) {
  cat("Test 1 failed: GPForth varimax loadings not identical to legacy\n")
  cat("max difference:", max(abs(r1$loadings - r1L$loadings)), "\n")
  all.ok <- FALSE
}
if (!identical(r1$Th, r1L$Th)) {
  cat("Test 1 failed: GPForth varimax Th not identical to legacy\n")
  cat("max difference:", max(abs(r1$Th - r1L$Th)), "\n")
  all.ok <- FALSE
}
if (!identical(r1$convergence, r1L$convergence)) {
  cat("Test 1 failed: GPForth varimax convergence not identical to legacy\n")
  all.ok <- FALSE
}

# --- Test 2: GPForth vs GPForth.legacy, quartimax, 3 factors ---
r2  <- GPForth(A3, method = "quartimax")
r2L <- GPArotation:::GPForth.legacy(A3, method = "quartimax")

if (!identical(r2$loadings, r2L$loadings)) {
  cat("Test 2 failed: GPForth quartimax loadings not identical to legacy\n")
  cat("max difference:", max(abs(r2$loadings - r2L$loadings)), "\n")
  all.ok <- FALSE
}
if (!identical(r2$Th, r2L$Th)) {
  cat("Test 2 failed: GPForth quartimax Th not identical to legacy\n")
  cat("max difference:", max(abs(r2$Th - r2L$Th)), "\n")
  all.ok <- FALSE
}
if (!identical(r2$convergence, r2L$convergence)) {
  cat("Test 2 failed: GPForth quartimax convergence not identical to legacy\n")
  all.ok <- FALSE
}

# --- Test 3: GPForth vs GPForth.legacy, random start ---
set.seed(42)
Tmat2 <- Random.Start(2)
r3  <- GPForth(A2, Tmat = Tmat2, method = "varimax")
set.seed(42)
Tmat2 <- Random.Start(2)
r3L <- GPArotation:::GPForth.legacy(A2, Tmat = Tmat2, method = "varimax")

if (!identical(r3$loadings, r3L$loadings)) {
  cat("Test 3 failed: GPForth random start loadings not identical to legacy\n")
  cat("max difference:", max(abs(r3$loadings - r3L$loadings)), "\n")
  all.ok <- FALSE
}
if (!identical(r3$Th, r3L$Th)) {
  cat("Test 3 failed: GPForth random start Th not identical to legacy\n")
  cat("max difference:", max(abs(r3$Th - r3L$Th)), "\n")
  all.ok <- FALSE
}

# --- Test 4: GPForth vs GPForth.legacy, with normalization ---
r4  <- GPForth(A2, method = "varimax", normalize = TRUE)
r4L <- GPArotation:::GPForth.legacy(A2, method = "varimax", normalize = TRUE)

if (!identical(r4$loadings, r4L$loadings)) {
  cat("Test 4 failed: GPForth normalized loadings not identical to legacy\n")
  cat("max difference:", max(abs(r4$loadings - r4L$loadings)), "\n")
  all.ok <- FALSE
}
if (!identical(r4$Th, r4L$Th)) {
  cat("Test 4 failed: GPForth normalized Th not identical to legacy\n")
  cat("max difference:", max(abs(r4$Th - r4L$Th)), "\n")
  all.ok <- FALSE
}

# --- Test 5: GPForth vs GPForth.legacy, methodArgs ---
r5  <- GPForth(A2, method = "cf", methodArgs = list(kappa = 0.3))
r5L <- GPArotation:::GPForth.legacy(A2, method = "cf",
                                     methodArgs = list(kappa = 0.3))

if (!identical(r5$loadings, r5L$loadings)) {
  cat("Test 5 failed: GPForth cf kappa=0.3 loadings not identical to legacy\n")
  cat("max difference:", max(abs(r5$loadings - r5L$loadings)), "\n")
  all.ok <- FALSE
}
if (!identical(r5$Th, r5L$Th)) {
  cat("Test 5 failed: GPForth cf kappa=0.3 Th not identical to legacy\n")
  cat("max difference:", max(abs(r5$Th - r5L$Th)), "\n")
  all.ok <- FALSE
}

# --- Test 6: GPFoblq vs GPFoblq.legacy, quartimin, identity start ---
r6  <- GPFoblq(A2, method = "quartimin")
r6L <- GPArotation:::GPFoblq.legacy(A2, method = "quartimin")

if (!identical(r6$loadings, r6L$loadings)) {
  cat("Test 6 failed: GPFoblq quartimin loadings not identical to legacy\n")
  cat("max difference:", max(abs(r6$loadings - r6L$loadings)), "\n")
  all.ok <- FALSE
}
if (!identical(r6$Phi, r6L$Phi)) {
  cat("Test 6 failed: GPFoblq quartimin Phi not identical to legacy\n")
  cat("max difference:", max(abs(r6$Phi - r6L$Phi)), "\n")
  all.ok <- FALSE
}
if (!identical(r6$Th, r6L$Th)) {
  cat("Test 6 failed: GPFoblq quartimin Th not identical to legacy\n")
  cat("max difference:", max(abs(r6$Th - r6L$Th)), "\n")
  all.ok <- FALSE
}
if (!identical(r6$convergence, r6L$convergence)) {
  cat("Test 6 failed: GPFoblq quartimin convergence not identical to legacy\n")
  all.ok <- FALSE
}

# --- Test 7: GPFoblq vs GPFoblq.legacy, oblimin, 3 factors ---
r7  <- GPFoblq(A3, method = "oblimin")
r7L <- GPArotation:::GPFoblq.legacy(A3, method = "oblimin")

if (!identical(r7$loadings, r7L$loadings)) {
  cat("Test 7 failed: GPFoblq oblimin loadings not identical to legacy\n")
  cat("max difference:", max(abs(r7$loadings - r7L$loadings)), "\n")
  all.ok <- FALSE
}
if (!identical(r7$Phi, r7L$Phi)) {
  cat("Test 7 failed: GPFoblq oblimin Phi not identical to legacy\n")
  cat("max difference:", max(abs(r7$Phi - r7L$Phi)), "\n")
  all.ok <- FALSE
}
if (!identical(r7$convergence, r7L$convergence)) {
  cat("Test 7 failed: GPFoblq oblimin convergence not identical to legacy\n")
  all.ok <- FALSE
}

# --- Test 8: GPFoblq vs GPFoblq.legacy, random start ---
set.seed(42)
Tmat3 <- Random.Start(3)
r8  <- GPFoblq(A3, Tmat = Tmat3, method = "quartimin")
set.seed(42)
Tmat3 <- Random.Start(3)
r8L <- GPArotation:::GPFoblq.legacy(A3, Tmat = Tmat3, method = "quartimin")

if (!identical(r8$loadings, r8L$loadings)) {
  cat("Test 8 failed: GPFoblq random start loadings not identical to legacy\n")
  cat("max difference:", max(abs(r8$loadings - r8L$loadings)), "\n")
  all.ok <- FALSE
}
if (!identical(r8$Phi, r8L$Phi)) {
  cat("Test 8 failed: GPFoblq random start Phi not identical to legacy\n")
  cat("max difference:", max(abs(r8$Phi - r8L$Phi)), "\n")
  all.ok <- FALSE
}
if (!identical(r8$Th, r8L$Th)) {
  cat("Test 8 failed: GPFoblq random start Th not identical to legacy\n")
  cat("max difference:", max(abs(r8$Th - r8L$Th)), "\n")
  all.ok <- FALSE
}

# --- Test 9: GPFoblq vs GPFoblq.legacy, with normalization ---
r9  <- GPFoblq(A2, method = "quartimin", normalize = TRUE)
r9L <- GPArotation:::GPFoblq.legacy(A2, method = "quartimin",
                                     normalize = TRUE)

if (!identical(r9$loadings, r9L$loadings)) {
  cat("Test 9 failed: GPFoblq normalized loadings not identical to legacy\n")
  cat("max difference:", max(abs(r9$loadings - r9L$loadings)), "\n")
  all.ok <- FALSE
}
if (!identical(r9$Phi, r9L$Phi)) {
  cat("Test 9 failed: GPFoblq normalized Phi not identical to legacy\n")
  cat("max difference:", max(abs(r9$Phi - r9L$Phi)), "\n")
  all.ok <- FALSE
}

# --- Test 10: convergence indicators agree ---
if (!identical(r1$convergence, r1L$convergence)) {
  cat("Test 10 failed: GPForth convergence indicator not identical to legacy\n")
  all.ok <- FALSE
}
if (!identical(r6$convergence, r6L$convergence)) {
  cat("Test 10 failed: GPFoblq convergence indicator not identical to legacy\n")
  all.ok <- FALSE
}

# --- Test 11: Table structure for non-converged case ---
# Uses a matrix that requires many iterations with maxit = 3
# to verify Table trimming produces same result as rbind growth
r11  <- GPForth(A3, method = "simplimax", maxit = 3)
r11L <- GPArotation:::GPForth.legacy(A3, method = "simplimax", maxit = 3)

if (!identical(nrow(r11$Table), nrow(r11L$Table))) {
  cat("Test 11 failed: GPForth Table nrow not identical to legacy\n")
  cat("new:", nrow(r11$Table), "legacy:", nrow(r11L$Table), "\n")
  all.ok <- FALSE
}
if (!identical(unname(r11$Table[nrow(r11$Table), 2]),
               unname(r11L$Table[nrow(r11L$Table), 2]))) {
  cat("Test 11 failed: GPForth Table last row f value not identical to legacy\n")
  all.ok <- FALSE
}

# --- Test 12: Table structure for non-converged oblique case ---
r12  <- GPFoblq(A3, method = "simplimax", maxit = 3)
r12L <- GPArotation:::GPFoblq.legacy(A3, method = "simplimax", maxit = 3)

if (!identical(nrow(r12$Table), nrow(r12L$Table))) {
  cat("Test 12 failed: GPFoblq Table nrow not identical to legacy\n")
  cat("new:", nrow(r12$Table), "legacy:", nrow(r12L$Table), "\n")
  all.ok <- FALSE
}
if (!identical(unname(r12$Table[nrow(r12$Table), 2]),
               unname(r12L$Table[nrow(r12L$Table), 2]))) {
  cat("Test 12 failed: GPFoblq Table last row f value not identical to legacy\n")
  all.ok <- FALSE
}

cat("Legacy regression tests completed.\n")
if (!all.ok) stop("some tests FAILED")