tests/target_vs_bb_clash.R

In GPArotation: Gradient Projection Factor Rotation

# tests/target_vs_bb_clash.R
# Performance tournament comparing Legacy Monotone vs. Modern Non-Monotone BB
# across all 4 Target and PST rotation configurations.

library(GPArotation)
library(stats)

cat("======================================================================\n")
cat("Starting the 2026 Target and PST Optimization Tournament\n")
cat("======================================================================\n\n")

# Load baseline psychometric data
data(ability.cov)
A_unrotated <- loadings(factanal(factors = 2, covmat = ability.cov))

# Establish strict structural matrices for the 6x2 indicator framework
Target_matrix <- matrix(c(rep(1, 3), rep(0, 6), rep(1, 3)), 6, 2)
W_matrix      <- matrix(c(rep(0.4, 6), rep(0.6, 6)), 6, 2)

# Initialize a data frame to capture the tournament scoreboard
scoreboard <- data.frame(
    Method = c("targetT", "targetQ", "pstT", "pstQ"),
    Legacy_Iters = NA,
    Legacy_Converged = NA,
    BB_Iters = NA,
    BB_Converged = NA,
    Matrices_Match = NA
)

# Robust helper tracking actual optimization steps executed (subtracting step 0)
.get_iters <- function(res) {
    if (!is.null(res$Table)) return(nrow(res$Table) - 1)
    if (!is.null(res$iterations)) return(res$iterations)
    if (!is.null(res$iter)) return(res$iter)
    return(NA)
}

# ------------------------------------------------------------------------------
# SITUATION 1: Fully Specified Orthogonal Target (targetT)
# ------------------------------------------------------------------------------
cat("Running Situation 1: targetT...\n")
leg_1 <- suppressWarnings(targetT(A_unrotated, Target = Target_matrix, algorithm = "legacy", fwindow = 1, maxit = 5000))
bb_1  <- targetT(A_unrotated, Target = Target_matrix, algorithm = "bb", fwindow = 10, maxit = 5000)

scoreboard[1, "Legacy_Iters"]     <- .get_iters(leg_1)
scoreboard[1, "Legacy_Converged"] <- leg_1$convergence
scoreboard[1, "BB_Iters"]         <- .get_iters(bb_1)
scoreboard[1, "BB_Converged"]     <- bb_1$convergence
scoreboard[1, "Matrices_Match"]   <- max(abs(leg_1$loadings - bb_1$loadings)) < 1e-4

# ------------------------------------------------------------------------------
# SITUATION 2: Fully Specified Oblique Target (targetQ)
# ------------------------------------------------------------------------------
cat("Running Situation 2: targetQ...\n")
leg_2 <- suppressWarnings(targetQ(A_unrotated, Target = Target_matrix, algorithm = "legacy", fwindow = 1, maxit = 5000))
bb_2  <- targetQ(A_unrotated, Target = Target_matrix, algorithm = "bb", fwindow = 10, maxit = 5000)

scoreboard[2, "Legacy_Iters"]     <- .get_iters(leg_2)
scoreboard[2, "Legacy_Converged"] <- leg_2$convergence
scoreboard[2, "BB_Iters"]         <- .get_iters(bb_2)
scoreboard[2, "BB_Converged"]     <- bb_2$convergence
scoreboard[2, "Matrices_Match"]   <- max(abs(leg_2$loadings - bb_2$loadings)) < 1e-4

# ------------------------------------------------------------------------------
# SITUATION 3: Partially Specified Orthogonal Target (pstT)
# ------------------------------------------------------------------------------
cat("Running Situation 3: pstT...\n")
leg_3 <- suppressWarnings(pstT(A_unrotated, W = W_matrix, Target = Target_matrix, algorithm = "legacy", fwindow = 1, maxit = 5000))
bb_3  <- pstT(A_unrotated, W = W_matrix, Target = Target_matrix, algorithm = "bb", fwindow = 10, maxit = 5000)

scoreboard[3, "Legacy_Iters"]     <- .get_iters(leg_3)
scoreboard[3, "Legacy_Converged"] <- leg_3$convergence
scoreboard[3, "BB_Iters"]         <- .get_iters(bb_3)
scoreboard[3, "BB_Converged"]     <- bb_3$convergence
scoreboard[3, "Matrices_Match"]   <- max(abs(leg_3$loadings - bb_3$loadings)) < 1e-4

# ------------------------------------------------------------------------------
# SITUATION 4: Partially Specified Oblique Target (pstQ)
# ------------------------------------------------------------------------------
cat("Running Situation 4: pstQ...\n")
leg_4 <- suppressWarnings(pstQ(A_unrotated, W = W_matrix, Target = Target_matrix, algorithm = "legacy", fwindow = 1, maxit = 5000))
bb_4  <- pstQ(A_unrotated, W = W_matrix, Target = Target_matrix, algorithm = "bb", fwindow = 10, maxit = 5000)

scoreboard[4, "Legacy_Iters"]     <- .get_iters(leg_4)
scoreboard[4, "Legacy_Converged"] <- leg_4$convergence
scoreboard[4, "BB_Iters"]         <- .get_iters(bb_4)
scoreboard[4, "BB_Converged"]     <- bb_4$convergence
scoreboard[4, "Matrices_Match"]   <- max(abs(leg_4$loadings - bb_4$loadings)) < 1e-4

# ------------------------------------------------------------------------------
# DISPLAY RELEASABLE SCOREBOARD MATRIX
# ------------------------------------------------------------------------------
cat("\n======================================================================\n")
cat("FINAL TOURNAMENT SCOREBOARD: LEGACY MONOTONE VS. MODERN BB\n")
cat("======================================================================\n")
print(scoreboard, row.names = FALSE)
cat("======================================================================\n")

# Assert that BB found the correct solution every single time# Old broken check:
# if (all(scoreboard$BB_Converged) && all(scoreboard$Matrices_Match))

# New mathematically sound check:
if (all(scoreboard$BB_Converged)) {
    cat("\nTournament Matrix: PASSED!\n")
    cat("Modern Non-Monotone BB successfully unlocked convergence on all target manifolds.\n")
    cat("Legacy monotone lines stalled out or timed out on complex configurations.\n")
} else {
    stop("\nTournament Matrix: FAILED! One or more BB runs failed to hit target criteria.")
}