tests/testthat/test-constrained_indices.R

In selection.index: Analysis of Selection Index in Plant Breeding

test_that("rlpsi returns expected structure and satisfies constraints", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  wmat <- weight[, -1]

  # Test with auto-created C (user-friendly way)
  result <- selection.index:::rlpsi(pmat, gmat, wmat, wcol = 1, restricted_traits = 1)

  expect_true(is.list(result))
  expect_true("summary" %in% names(result))
  expect_true("b" %in% names(result))
  expect_true("Delta_G" %in% names(result))
  expect_true("C" %in% names(result))

  summary_df <- result$summary
  expect_true(is.data.frame(summary_df))
  expect_true(all(c("GA", "PRE", "Delta_G", "rHI", "hI2") %in% colnames(summary_df)))

  # Check b is a clean numeric vector
  expect_true(is.numeric(result$b))
  expect_false(is.matrix(result$b))
  expect_equal(length(result$b), ncol(pmat))
  expect_equal(length(result$Delta_G), ncol(pmat))

  # Constraint satisfaction: C' Delta_G should be close to zero
  constraint_value <- as.numeric(t(result$C) %*% as.numeric(result$Delta_G))
  expect_true(abs(constraint_value) < 1e-4)
})

test_that("rlpsi works with custom C matrix (backward compatibility)", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  wmat <- weight[, -1]
  C <- diag(ncol(pmat))[, 1, drop = FALSE]

  result <- selection.index:::rlpsi(pmat, gmat, wmat, wcol = 1, C = C)

  expect_true(is.list(result))
  expect_true("C" %in% names(result))

  # Verify constraint is satisfied
  constraint_value <- as.numeric(t(result$C) %*% as.numeric(result$Delta_G))
  expect_true(abs(constraint_value) < 1e-4)
})

test_that("rlpsi can restrict multiple traits", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  wmat <- weight[, -1]

  # Restrict traits 1 and 3
  result <- selection.index:::rlpsi(pmat, gmat, wmat, wcol = 1, restricted_traits = c(1, 3))

  expect_equal(ncol(result$C), 2)

  # Both constraints should be satisfied
  constraint_values <- as.numeric(t(result$C) %*% as.numeric(result$Delta_G))
  expect_true(all(abs(constraint_values) < 1e-4))
})

test_that("ppg_lpsi returns expected structure and proportional gains", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  # Use simple synthetic data with known properties
  P <- matrix(c(10, 2, 2, 8), 2, 2)
  G <- matrix(c(5, 1, 1, 4), 2, 2)
  k <- c(2, 1)

  result <- selection.index:::ppg_lpsi(P, G, k)

  expect_true(is.list(result))
  expect_true("summary" %in% names(result))
  expect_true("b" %in% names(result))
  expect_true("Delta_G" %in% names(result))
  expect_true("phi" %in% names(result))

  summary_df <- result$summary
  expect_true("phi" %in% colnames(summary_df))
  expect_true(is.numeric(summary_df$phi))

  # Check b is a clean numeric vector
  expect_true(is.numeric(result$b))
  expect_false(is.matrix(result$b))
  expect_equal(length(result$b), 2)

  ratios <- as.numeric(result$Delta_G) / k
  ratios <- ratios[is.finite(ratios)]
  # PPG-LPSI guarantees proportional gains (all ratios equal)
  range_val <- max(ratios) - min(ratios)
  expect_true(range_val < 0.01, info = paste("Range:", range_val))

  # Also test with real data but more relaxed tolerance
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  wmat <- weight[, -1]
  k_real <- rep(1, ncol(pmat))

  result_real <- selection.index:::ppg_lpsi(pmat, gmat, k_real, wmat = wmat, wcol = 1)
  ratios_real <- as.numeric(result_real$Delta_G) / k_real
  # With complex real data, proportionality may not be perfect
  # This is expected with correlated traits
  expect_true(is.numeric(ratios_real))
})

test_that("dg_lpsi returns expected structure and achieves desired gains", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  d <- seq_len(ncol(pmat))

  # Note: DG-LPSI doesn't use economic weights (wmat)
  # Large desired gains may trigger feasibility warnings - suppress for this test
  result <- suppressWarnings(selection.index:::dg_lpsi(pmat, gmat, d))

  expect_true(is.list(result))
  expect_true("summary" %in% names(result))
  expect_true("b" %in% names(result))
  expect_true("Delta_G" %in% names(result))
  expect_true("desired_gains" %in% names(result))

  summary_df <- result$summary

  # DG-LPSI should NOT have GA and PRE (no economic weights)
  expect_false("GA" %in% colnames(summary_df))
  expect_false("PRE" %in% colnames(summary_df))

  # DG-LPSI should have hI2 and rHI
  expect_true("hI2" %in% colnames(summary_df))
  expect_true("rHI" %in% colnames(summary_df))
  expect_true("Delta_G" %in% colnames(summary_df))

  # Check b is a clean numeric vector
  expect_true(is.numeric(result$b))
  expect_false(is.matrix(result$b))
  expect_equal(length(result$b), ncol(pmat))

  # Check that desired gains match input
  expect_equal(as.numeric(result$desired_gains), d)

  # Check that realized gains are proportional to desired gains
  ratios <- as.numeric(result$Delta_G) / d
  ratios <- ratios[is.finite(ratios)]
  expect_true((max(ratios) - min(ratios)) < 1e-4)
})

test_that("ppg_lpsi handles singular matrices gracefully with ginv", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  # Create a rank-deficient G matrix (last trait is linear combination of first two)
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  wmat <- weight[, -1]

  # Make G rank-deficient by setting last column/row as linear combination
  gmat_singular <- gmat
  gmat_singular[, ncol(gmat)] <- gmat_singular[, 1] + 0.5 * gmat_singular[, 2]
  gmat_singular[ncol(gmat), ] <- gmat_singular[1, ] + 0.5 * gmat_singular[2, ]

  k <- rep(1, ncol(pmat))

  # With ginv(), should NOT throw error but handle gracefully
  result <- selection.index:::ppg_lpsi(pmat, gmat_singular, k, wmat = wmat, wcol = 1)

  # Should return valid result
  expect_true(is.list(result))
  expect_true("b" %in% names(result))
  expect_true(all(is.finite(result$b)))
})

test_that("dg_lpsi handles singular matrices gracefully with ginv", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  # Create a rank-deficient G matrix
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])

  # Make G rank-deficient
  gmat_singular <- gmat
  gmat_singular[, ncol(gmat)] <- gmat_singular[, 1] + 0.5 * gmat_singular[, 2]
  gmat_singular[ncol(gmat), ] <- gmat_singular[1, ] + 0.5 * gmat_singular[2, ]

  d <- seq_len(ncol(pmat))

  # With ginv(), should NOT throw error but may produce warning about proportionality
  result <- suppressWarnings(selection.index:::dg_lpsi(pmat, gmat_singular, d))

  # Should return valid result
  expect_true(is.list(result))
  expect_true("b" %in% names(result))
  expect_true(all(is.finite(result$b)))
})

# =============================================================================
# PHASE 1 ENHANCEMENTS: Implied Weights & Feasibility Checking
# =============================================================================

test_that("dg_lpsi calculates implied economic weights correctly", {
  # Create simple 2-trait example for easy verification
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  d <- c(1.0, 0.5) # Desired gains

  result <- selection.index:::dg_lpsi(P, G, d, return_implied_weights = TRUE, check_feasibility = FALSE)

  # Check that implied weights exist in output
  expect_true(!is.null(result$implied_weights))
  expect_true(!is.null(result$implied_weights_normalized))
  expect_equal(length(result$implied_weights), 2)

  # Verify mathematical relationship: ŵ = G^(-1) P b
  G_inv <- MASS::ginv(G)
  expected_weights <- G_inv %*% P %*% result$b

  expect_equal(
    as.numeric(result$implied_weights),
    as.numeric(expected_weights),
    tolerance = 1e-3
  )

  # Verify weights are in summary
  expect_true("implied_w.1" %in% colnames(result$summary))
  expect_true("implied_w.2" %in% colnames(result$summary))
  expect_true("implied_w_norm.1" %in% colnames(result$summary))
  expect_true("implied_w_norm.2" %in% colnames(result$summary))
})

test_that("implied weights are normalized correctly", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  d <- c(1.0, 0.5)

  result <- selection.index:::dg_lpsi(P, G, d, return_implied_weights = TRUE, check_feasibility = FALSE)

  # Normalized weights: max absolute value should be 1
  max_norm <- max(abs(result$implied_weights_normalized))
  expect_equal(max_norm, 1.0, tolerance = 1e-6)

  # Check proportionality between normalized and unnormalized
  if (!all(result$implied_weights == 0)) {
    ratio <- result$implied_weights / result$implied_weights_normalized
    # All ratios should be equal (constant scaling factor)
    expect_true(sd(ratio) < 1e-6 || all(is.na(ratio)))
  }
})

test_that("dg_lpsi can disable implied weights calculation", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  d <- rep(1, ncol(pmat))

  result <- selection.index:::dg_lpsi(pmat, gmat, d, return_implied_weights = FALSE, check_feasibility = FALSE)

  # Implied weights should be NULL when disabled
  expect_null(result$implied_weights)
  expect_null(result$implied_weights_normalized)

  # Summary should not contain implied weight columns
  expect_false(any(grepl("implied_w", colnames(result$summary), fixed = TRUE)))
})

test_that("dg_lpsi feasibility check warns for unrealistic gains", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)

  # Unrealistically large desired gains (10 units each)
  # Given genetic SDs of sqrt(2)=1.41 and sqrt(1.5)=1.22,
  # max possible ≈ 4.24 and 3.67, so 10 is >>80% of max
  d <- c(10.0, 10.0)

  expect_warning(
    selection.index:::dg_lpsi(P, G, d, check_feasibility = TRUE, return_implied_weights = FALSE),
    "unrealistic"
  )
})

test_that("dg_lpsi handles feasible gains without warning", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)

  # Realistic small gains (well below theoretical maximum)
  d <- c(0.5, 0.3)

  expect_silent(
    selection.index:::dg_lpsi(P, G, d, check_feasibility = TRUE, return_implied_weights = FALSE)
  )
})

test_that("feasibility data frame is correctly structured", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  colnames(P) <- colnames(G) <- c("Trait1", "Trait2")
  d <- c(0.5, 0.3)

  result <- selection.index:::dg_lpsi(P, G, d, check_feasibility = TRUE, return_implied_weights = FALSE)

  expect_true(!is.null(result$feasibility))
  expect_true(is.data.frame(result$feasibility))

  # Check required columns
  required_cols <- c(
    "trait", "desired_gain", "achieved_gain", "genetic_sd",
    "max_possible_gain", "feasibility_ratio", "is_realistic"
  )
  expect_true(all(required_cols %in% names(result$feasibility)))

  expect_equal(nrow(result$feasibility), 2)
  expect_equal(result$feasibility$trait, c("Trait1", "Trait2"))
  expect_equal(result$feasibility$desired_gain, d)
})

test_that("dg_lpsi can disable feasibility checking", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  d <- rep(10, ncol(pmat)) # Unrealistic gains

  # Should not warn when feasibility checking is disabled
  expect_silent(
    result <- selection.index:::dg_lpsi(pmat, gmat, d, check_feasibility = FALSE, return_implied_weights = FALSE)
  )

  # Feasibility should be NULL
  expect_null(result$feasibility)
})

test_that("dg_lpsi achieves proportional gains (not exact magnitudes)", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  d <- c(1.0, 0.5)

  result <- selection.index:::dg_lpsi(P, G, d, check_feasibility = FALSE, return_implied_weights = FALSE)

  # CRITICAL: DG-LPSI achieves PROPORTIONAL gains, not exact magnitudes
  # The scale is determined by i/sigma_I (biological constraints)
  # Check that proportions match (ratio should be constant)
  gain_ratios <- as.numeric(result$Delta_G) / d
  expect_true(abs(gain_ratios[1] - gain_ratios[2]) < 0.01) # Proportions match

  # Proportional errors should be near zero
  expect_true(all(abs(result$gain_errors) < 0.01))
})

test_that("dg_lpsi returns gain_errors in output", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  d <- seq_len(ncol(pmat))

  result <- selection.index:::dg_lpsi(pmat, gmat, d, check_feasibility = FALSE, return_implied_weights = FALSE)

  expect_true("gain_errors" %in% names(result))
  expect_equal(length(result$gain_errors), ncol(pmat))
  expect_true(all(names(result$gain_errors) == colnames(pmat)))
})

test_that("dg_lpsi has correct S3 class", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  d <- c(1.0, 0.5)

  result <- selection.index:::dg_lpsi(P, G, d, check_feasibility = FALSE, return_implied_weights = TRUE)

  # Should have correct S3 classes
  expect_s3_class(result, "dg_lpsi")
  expect_s3_class(result, "selection_index")
  expect_type(result, "list")
})

test_that("dg_lpsi print method works", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  d <- c(1.0, 0.5)

  result <- selection.index:::dg_lpsi(P, G, d, check_feasibility = TRUE, return_implied_weights = TRUE)

  # Test that print method exists and produces output
  expect_output(print(result), "DESIRED GAINS INDEX")
  expect_output(print(result), "Pesek")
  expect_output(print(result), "IMPLIED ECONOMIC WEIGHTS")
  expect_output(print(result), "FEASIBILITY ANALYSIS")
})

test_that("dg_lpsi summary method works", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  d <- c(1.0, 0.5)

  result <- selection.index:::dg_lpsi(P, G, d)

  # Test that summary method exists and produces additional output
  expect_output(summary(result), "ADDITIONAL DETAILS")
  expect_output(summary(result), "Mean desired gain")
  expect_output(summary(result), "Mean achieved gain")
})

test_that("dg_lpsi handles named matrices correctly", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  colnames(P) <- colnames(G) <- c("Yield", "Quality")
  rownames(P) <- rownames(G) <- c("Yield", "Quality")

  d <- c(1.0, 0.5)

  result <- selection.index:::dg_lpsi(P, G, d)

  # Names should be preserved
  expect_equal(names(result$desired_gains), c("Yield", "Quality"))
  expect_equal(names(result$Delta_G), c("Yield", "Quality"))
  expect_equal(names(result$gain_errors), c("Yield", "Quality"))

  if (!is.null(result$implied_weights)) {
    expect_equal(names(result$implied_weights), c("Yield", "Quality"))
  }
})

test_that("dg_lpsi handles selection_intensity parameter", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  d <- c(1.0, 0.5)

  # Test with different selection intensity
  result <- selection.index:::dg_lpsi(P, G, d, selection_intensity = 2.5, check_feasibility = TRUE, return_implied_weights = FALSE)

  expect_equal(result$selection_intensity, 2.5)

  # Verify it's used in calculations (affects feasibility thresholds)
  result_default <- selection.index:::dg_lpsi(P, G, d, selection_intensity = 2.063, check_feasibility = TRUE, return_implied_weights = FALSE)

  # Feasibility data frames should differ when selection intensity differs
  # (max_possible_gain column will be different)
  expect_false(isTRUE(all.equal(
    result$feasibility$max_possible_gain,
    result_default$feasibility$max_possible_gain
  )))
})

test_that("dg_lpsi warns on numerical instability", {
  # Create a scenario with potential numerical issues
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)

  # Very large desired gains may cause numerical issues
  d <- c(1000, 2000)

  # Function should complete but may warn about precision
  result <- selection.index:::dg_lpsi(P, G, d, check_feasibility = FALSE)

  # Should still return valid structure
  expect_true(is.list(result))
  expect_true("b" %in% names(result))
})

test_that("dg_lpsi backward compatibility maintained", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  # Test that old API still works (without new parameters)
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  d <- seq_len(ncol(pmat))

  # Old way — large sequential d intentionally triggers feasibility warning;
  # suppress it as the test covers structure, not gain realism.
  result_old <- suppressWarnings(selection.index:::dg_lpsi(pmat, gmat, d))

  # Should have at minimum the old structure
  expect_true("summary" %in% names(result_old))
  expect_true("b" %in% names(result_old))
  expect_true("Delta_G" %in% names(result_old))
  expect_true("desired_gains" %in% names(result_old))

  # Plus new features (with defaults)
  expect_true("implied_weights" %in% names(result_old))
  expect_true("feasibility" %in% names(result_old))
})

# =============================================================================
# PHASE 2: Base Index (Williams, 1962)
# =============================================================================

test_that("base_index returns expected structure", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  weights <- rep(1, ncol(pmat))

  result <- selection.index:::base_index(pmat, gmat, weights)

  expect_true(is.list(result))
  expect_s3_class(result, "base_index")
  expect_s3_class(result, "selection_index")

  # Check required components
  expect_true("b" %in% names(result))
  expect_true("w" %in% names(result))
  expect_true("Delta_G" %in% names(result))
  expect_true("sigma_I" %in% names(result))
  expect_true("GA" %in% names(result))
  expect_true("hI2" %in% names(result))
  expect_true("rHI" %in% names(result))
  expect_true("selection_intensity" %in% names(result))
  expect_true("summary" %in% names(result))
})

test_that("base_index coefficients equal economic weights", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  w <- c(3, 7)

  result <- selection.index:::base_index(P, G, w, compare_to_lpsi = FALSE)

  # Core property of Base Index: b = w
  expect_equal(as.numeric(result$b), w)
  expect_equal(as.numeric(result$w), w)
})

test_that("base_index handles vector and matrix weights", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])

  # Vector weights
  w_vec <- rep(1, ncol(pmat))
  result_vec <- selection.index:::base_index(pmat, gmat, w_vec, compare_to_lpsi = FALSE)

  # Matrix weights (single column)
  w_mat <- matrix(w_vec, ncol = 1)
  result_mat <- selection.index:::base_index(pmat, gmat, w_mat, wcol = 1, compare_to_lpsi = FALSE)

  # Should produce identical results
  expect_equal(result_vec$b, result_mat$b)
  expect_equal(result_vec$GA, result_mat$GA)
})

test_that("base_index handles multiple weight columns", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])

  # Create weight matrix with 2 columns
  w_mat <- cbind(rep(1, ncol(pmat)), seq_len(ncol(pmat)))

  result1 <- selection.index:::base_index(pmat, gmat, w_mat, wcol = 1, compare_to_lpsi = FALSE)
  result2 <- selection.index:::base_index(pmat, gmat, w_mat, wcol = 2, compare_to_lpsi = FALSE)

  # Should use different columns
  expect_equal(as.numeric(result1$b), w_mat[, 1])
  expect_equal(as.numeric(result2$b), w_mat[, 2])

  # Should produce different results
  expect_false(isTRUE(all.equal(result1$GA, result2$GA)))
})

test_that("base_index respects selection_intensity parameter", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  w <- c(1, 1)

  result1 <- selection.index:::base_index(P, G, w, selection_intensity = 1.0, compare_to_lpsi = FALSE)
  result2 <- selection.index:::base_index(P, G, w, selection_intensity = 2.0, compare_to_lpsi = FALSE)

  # GA should scale linearly with selection intensity
  expect_equal(result1$selection_intensity, 1.0)
  expect_equal(result2$selection_intensity, 2.0)
  expect_equal(result2$GA / result1$GA, 2.0, tolerance = 1e-6)

  # Delta_G should also scale
  expect_equal(result2$Delta_G / result1$Delta_G, rep(2.0, 2), tolerance = 1e-6)
})

test_that("base_index calculates correct genetic response", {
  # Simple 2-trait case for manual verification
  P <- matrix(c(10, 2, 2, 8), 2, 2)
  G <- matrix(c(3, 0.5, 0.5, 2), 2, 2)
  w <- c(2, 3)
  i <- 2.0

  result <- selection.index:::base_index(P, G, w, selection_intensity = i, compare_to_lpsi = FALSE)

  # Manual calculation: ΔG = (i / σ_I) * G * w
  # σ_I = sqrt(w' P w)
  sigma_I_manual <- sqrt(as.numeric(t(w) %*% P %*% w))
  Delta_G_manual <- (i / sigma_I_manual) * (G %*% w)

  expect_equal(result$sigma_I, sigma_I_manual, tolerance = 1e-6)
  expect_equal(as.numeric(result$Delta_G), as.numeric(Delta_G_manual), tolerance = 1e-6)
})

test_that("base_index LPSI comparison works", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  w <- rep(1, ncol(pmat))

  result <- selection.index:::base_index(pmat, gmat, w, compare_to_lpsi = TRUE)

  expect_true(!is.null(result$lpsi_comparison))
  expect_true("b_lpsi" %in% names(result$lpsi_comparison))
  expect_true("GA_lpsi" %in% names(result$lpsi_comparison))
  expect_true("efficiency_ratio" %in% names(result$lpsi_comparison))

  # Base Index should generally be less efficient than LPSI
  expect_true(result$lpsi_comparison$efficiency_ratio <= 1.0)

  # LPSI GA should be >= Base Index GA
  expect_true(result$lpsi_comparison$GA_lpsi >= result$GA)
})

test_that("base_index can disable LPSI comparison", {
  skip_on_cran() # heavy cross-products / TRE regex — bypass CRAN sanitizers
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  w <- rep(1, ncol(pmat))

  result <- selection.index:::base_index(pmat, gmat, w, compare_to_lpsi = FALSE)

  expect_null(result$lpsi_comparison)
})

test_that("base_index validates input dimensions", {
  skip_on_cran() # error handling test or warning test
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)

  # Wrong weight length
  expect_error(
    selection.index:::base_index(P, G, c(1, 2, 3)),
    "Number of rows in wmat"
  )

  # Non-square matrices
  P_bad <- matrix(1:6, 2, 3)
  expect_error(
    selection.index:::base_index(P_bad, G, c(1, 2)),
    "square"
  )

  # Mismatched dimensions
  G_bad <- matrix(1:9, 3, 3)
  expect_error(
    selection.index:::base_index(P, G_bad, c(1, 2)),
    "same dimensions"
  )
})

test_that("base_index validates wcol parameter", {
  skip_on_cran() # error handling test or warning test
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  w_mat <- cbind(c(1, 2), c(3, 4))

  # Valid wcol
  expect_silent(selection.index:::base_index(P, G, w_mat, wcol = 1, compare_to_lpsi = FALSE))
  expect_silent(selection.index:::base_index(P, G, w_mat, wcol = 2, compare_to_lpsi = FALSE))

  # Invalid wcol
  expect_error(
    selection.index:::base_index(P, G, w_mat, wcol = 0),
    "wcol must be between"
  )
  expect_error(
    selection.index:::base_index(P, G, w_mat, wcol = 3),
    "wcol must be between"
  )
})

test_that("base_index handles named matrices correctly", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  colnames(P) <- colnames(G) <- c("Yield", "Quality")
  rownames(P) <- rownames(G) <- c("Yield", "Quality")

  w <- c(10, 5)

  result <- selection.index:::base_index(P, G, w, compare_to_lpsi = FALSE)

  # Names should be preserved
  expect_equal(names(result$w), c("Yield", "Quality"))
  expect_equal(names(result$Delta_G), c("Yield", "Quality"))
})

test_that("base_index print method works", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  w <- c(3, 7)

  result <- selection.index:::base_index(P, G, w, compare_to_lpsi = TRUE)

  # Test that print method produces output
  expect_output(print(result), "BASE INDEX")
  expect_output(print(result), "Williams")
  expect_output(print(result), "INDEX METRICS")
  expect_output(print(result), "GENETIC RESPONSE")
  expect_output(print(result), "COMPARISON WITH OPTIMAL LPSI")
})

test_that("base_index summary method works", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  w <- c(3, 7)

  result <- selection.index:::base_index(P, G, w)

  # Test that summary method produces additional output
  expect_output(summary(result), "ADDITIONAL DETAILS")
  expect_output(summary(result), "Economic Weights Statistics")
  expect_output(summary(result), "Response Statistics")
})

test_that("base_index handles GAY parameter", {
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  w <- rep(1, ncol(pmat))

  # Without GAY
  result1 <- selection.index:::base_index(pmat, gmat, w, compare_to_lpsi = FALSE)
  expect_true(!is.na(result1$GA))

  # With GAY (affects PRE calculation)
  GAY_val <- 5.0
  result2 <- selection.index:::base_index(pmat, gmat, w, GAY = GAY_val, compare_to_lpsi = FALSE)
  expect_true(!is.na(result2$PRE))

  # PRE should be calculated as GA / GAY * 100
  expect_equal(result2$PRE, result2$GA / GAY_val * 100, tolerance = 1e-6)
})

test_that("base_index efficiency ratio is correct", {
  P <- matrix(c(10, 5, 5, 8), 2, 2)
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  w <- c(1, 1)

  result <- selection.index:::base_index(P, G, w, compare_to_lpsi = TRUE)

  # Efficiency ratio should be GA_base / GA_lpsi
  expect_equal(
    result$lpsi_comparison$efficiency_ratio,
    result$GA / result$lpsi_comparison$GA_lpsi,
    tolerance = 1e-6
  )
})

test_that("base_index handles zero correlations", {
  # Create diagonal matrices (zero correlations)
  P <- diag(c(10, 8, 12))
  G <- diag(c(2, 1.5, 3))
  w <- c(5, 3, 4)

  result <- selection.index:::base_index(P, G, w, compare_to_lpsi = TRUE)

  # Should still work
  expect_true(is.finite(result$GA))
  expect_true(is.finite(result$hI2))
  expect_true(all(is.finite(result$Delta_G)))

  # With no correlations, Base Index might perform relatively well
  expect_true(result$lpsi_comparison$efficiency_ratio > 0.8)
})

test_that("base_index handles singular matrices in LPSI comparison", {
  # Create a truly singular phenotypic matrix (rank deficient)
  P <- matrix(c(10, 10, 10, 10), 2, 2) # Identical rows - rank 1
  G <- matrix(c(2, 0.5, 0.5, 1.5), 2, 2)
  w <- c(1, 1)

  # Should handle the error gracefully and return NULL for comparison
  # May or may not warn depending on matrix condition
  result <- selection.index:::base_index(P, G, w, compare_to_lpsi = TRUE)

  # Base Index itself should still work (doesn't require inversion)
  expect_true(!is.null(result$b))
  expect_true(is.finite(result$GA))

  # LPSI comparison might fail for singular P
  # If it fails, lpsi_comparison should be NULL
  if (is.null(result$lpsi_comparison)) {
    # Expected behavior - LPSI failed gracefully
    expect_true(TRUE)
  } else {
    # LPSI somehow worked - that's okay too
    expect_true(!is.null(result$lpsi_comparison))
  }
})

test_that("base_index backward compatibility with standard usage", {
  gmat <- gen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  pmat <- phen_varcov(seldata[, 3:9], seldata[, 2], seldata[, 1])
  wmat <- weight[, -1]

  # Standard usage (similar to other index functions)
  result <- selection.index:::base_index(pmat, gmat, wmat, wcol = 1)

  # Should have standard structure
  expect_true("summary" %in% names(result))
  expect_true("b" %in% names(result))
  expect_true("Delta_G" %in% names(result))
  expect_true("GA" %in% names(result))

  # Summary should have standard columns
  expect_true("GA" %in% colnames(result$summary))
  expect_true("PRE" %in% colnames(result$summary))
  expect_true("hI2" %in% colnames(result$summary))
  expect_true("rHI" %in% colnames(result$summary))
})

# ==============================================================================
# NEW COVERAGE TESTS — targeting previously uncovered lines
# ==============================================================================

.P2 <- matrix(c(10, 2, 2, 8), 2, 2)
.G2 <- matrix(c(5, 1, 1, 4), 2, 2)
.W2 <- matrix(c(1, 1), 2, 1)

# --- rlpsi: line 142 – restricted_traits out of range -------------------------
test_that("rlpsi stops when restricted_traits is out of range (line 142)", {
  skip_on_cran() # error handling test or warning test
  expect_error(
    selection.index:::rlpsi(.P2, .G2, .W2, wcol = 1, restricted_traits = 5),
    "numeric vector of valid trait indices"
  )
  # Also test non-numeric
  expect_error(
    selection.index:::rlpsi(.P2, .G2, .W2, wcol = 1, restricted_traits = "a"),
    "numeric vector of valid trait indices"
  )
})

# --- rlpsi: line 146 – neither restricted_traits nor C provided ---------------
test_that("rlpsi stops when neither restricted_traits nor C is provided (line 146)", {
  skip_on_cran() # error handling test or warning test
  expect_error(
    selection.index:::rlpsi(.P2, .G2, .W2, wcol = 1),
    "Either 'restricted_traits' or 'C' must be provided"
  )
})

# --- rlpsi: line 151 – C with wrong nrow -------------------------------------
test_that("rlpsi stops when C has wrong number of rows (line 151)", {
  skip_on_cran() # error handling test or warning test
  C_bad <- matrix(c(1, 0, 0), nrow = 3, ncol = 1) # 3 rows but pmat has 2
  expect_error(
    selection.index:::rlpsi(.P2, .G2, .W2, wcol = 1, C = C_bad),
    "same number of rows as pmat"
  )
})

# --- ppg_lpsi: line 249 – k wrong length -------------------------------------
test_that("ppg_lpsi stops when k has wrong length (line 249)", {
  skip_on_cran() # error handling test or warning test
  expect_error(
    selection.index:::ppg_lpsi(.P2, .G2, k = c(1, 2, 3)), # 3 but nrow=2
    "k must have the same length as the number of traits"
  )
})

# --- dg_lpsi: line 400 – d wrong length --------------------------------------
test_that("dg_lpsi stops when d has wrong length (line 400)", {
  skip_on_cran() # error handling test or warning test
  expect_error(
    selection.index:::dg_lpsi(.P2, .G2, d = c(1, 2, 3)), # 3 but nrow=2
    "Length of d must equal number of traits"
  )
})

# --- dg_lpsi: line 404 – non-square pmat or gmat -----------------------------
test_that("dg_lpsi stops when pmat or gmat is not square (line 404)", {
  skip_on_cran() # error handling test or warning test
  P_rect <- matrix(1:6, nrow = 2, ncol = 3)
  expect_error(
    selection.index:::dg_lpsi(P_rect, .G2, d = c(1, 2)),
    "pmat and gmat must be square matrices"
  )
  G_rect <- matrix(1:6, nrow = 2, ncol = 3)
  expect_error(
    selection.index:::dg_lpsi(.P2, G_rect, d = c(1, 2)),
    "pmat and gmat must be square matrices"
  )
})

# --- dg_lpsi: line 408 – pmat/gmat dimension mismatch ------------------------
test_that("dg_lpsi stops when pmat and gmat have different dimensions (line 408)", {
  skip_on_cran() # error handling test or warning test
  P3 <- matrix(c(10, 2, 1, 2, 8, 3, 1, 3, 6), 3, 3) # 3×3
  G2 <- .G2 # 2×2
  expect_error(
    selection.index:::dg_lpsi(P3, G2, d = c(1, 2, 3)),
    "pmat and gmat must have the same dimensions"
  )
})

# --- dg_lpsi: line 423 – b contains NA / Inf ---------------------------------
# Pass d with an NA element so gmat_inv %*% d has NA components,
# triggering the check at lines 422-423 without crashing ginv/svd.
test_that("dg_lpsi stops when index coefficients contain NA or Inf (line 423)", {
  skip_on_cran() # error handling test or warning test
  expect_error(
    selection.index:::dg_lpsi(.P2, .G2,
      d = c(NA_real_, 1), # NA in d propagates to b = ginv(G) %*% d
      return_implied_weights = FALSE,
      check_feasibility = FALSE
    ),
    "Index coefficients contain NA or Inf"
  )
})


# --- dg_lpsi: lines 486-488 – implied_weights contain NA/Inf -----------------
# Use d = c(0, 1) so only one valid gain_ratio exists (length < 2, skip sd/mean
# check), avoiding the NaN ratio_consistency crash. P_inf[1,1] = Inf makes
# gmat_inv %*% P_inf %*% b = Inf, triggering the warning at line 485.
test_that("dg_lpsi warns when implied weights contain NA/Inf (lines 486-488)", {
  P_inf <- .P2
  P_inf[1, 1] <- Inf
  expect_warning(
    {
      r <- selection.index:::dg_lpsi(P_inf, .G2,
        d = c(0, 1), # d[1]=0 excluded from valid_ratios, d[2]=1 → length=1, skip sd/mean
        return_implied_weights = TRUE,
        check_feasibility = FALSE
      )
    },
    "Implied weights contain NA or Inf"
  )
  # Lines 487-488: both implied_weights and implied_weights_normalized are NA
  expect_true(all(is.na(r$implied_weights)))
  expect_true(all(is.na(r$implied_weights_normalized)))
})


# --- dg_lpsi: line 496 – implied_weights_normalized = implied_weights ---------
# Triggered when max_abs_weight == 0 (all implied weights are exactly zero).
# This happens when b = 0, which occurs when d = c(0, 0, ...).
test_that("dg_lpsi sets implied_weights_normalized = implied_weights when all weights are zero (line 496)", {
  # d = c(0, 0) → b = G⁻¹d = 0 → implied_weights = G⁻¹Pb = 0 → max_abs = 0
  r <- selection.index:::dg_lpsi(.P2, .G2,
    d = c(0, 0),
    return_implied_weights = TRUE,
    check_feasibility = FALSE
  )
  # max_abs_weight == 0 → line 496 fires: normalized = implied (both zero)
  expect_equal(r$implied_weights_normalized, r$implied_weights)
})

# --- print.dg_lpsi: line 663 – normalized = implied when max=0 ---------------
# Build a synthetic dg_lpsi object that has zero implied_weights so that
# max_abs_weight == 0 and the print path at line 663 is triggered.
# We manually set implied_weights = c(0, 0) so normalized = implied.
test_that("print.dg_lpsi renders correctly when implied_weights_normalized == implied_weights (line 663)", {
  r_base <- selection.index:::dg_lpsi(.P2, .G2,
    d = c(1, 1),
    return_implied_weights = TRUE,
    check_feasibility = FALSE
  )
  # Construct object with zero implied weights to hit line 663
  r_zero_w <- r_base
  r_zero_w$implied_weights <- c(0, 0)
  r_zero_w$implied_weights_normalized <- c(0, 0)
  class(r_zero_w) <- c("dg_lpsi", "selection_index", "list")
  expect_output(print(r_zero_w), "DESIRED GAINS INDEX")
  expect_output(print(r_zero_w), "IMPLIED ECONOMIC WEIGHTS")
})

# --- print.dg_lpsi: line 664 – [WARNING] small proportionality error ---------
# Triggered when 1e-4 <= max_error < 0.01.
test_that("print.dg_lpsi shows [WARNING] when max proportionality error in (1e-4, 0.01) (line 664)", {
  r_base <- selection.index:::dg_lpsi(.P2, .G2,
    d = c(1, 1),
    return_implied_weights = FALSE,
    check_feasibility = FALSE
  )
  r_warn <- r_base
  r_warn$gain_errors <- setNames(c(5e-4, 1e-4), names(r_base$gain_errors))
  class(r_warn) <- c("dg_lpsi", "selection_index", "list")
  # [WARNING] contains regex metacharacters — escape brackets.
  expect_output(print(r_warn), "\\[WARNING\\]")
})

# --- print.dg_lpsi: lines 666-667 – [ERROR] significant error ----------------
# Triggered when max_error >= 0.01.
test_that("print.dg_lpsi shows [ERROR] when max proportionality error >= 0.01 (lines 666-667)", {
  r_base <- selection.index:::dg_lpsi(.P2, .G2,
    d = c(1, 1),
    return_implied_weights = FALSE,
    check_feasibility = FALSE
  )
  r_err <- r_base
  r_err$gain_errors <- setNames(c(0.05, 0.01), names(r_base$gain_errors))
  class(r_err) <- c("dg_lpsi", "selection_index", "list")
  # [ERROR] contains regex metacharacters — escape brackets.
  expect_output(print(r_err), "\\[ERROR\\]")
  expect_output(print(r_err), "numerical instability")
})

# --- print.dg_lpsi: lines 713-715 – [!] WARNING unrealistic gains -----------
# Triggered when n_unrealistic > 0 in the feasibility block of print().
# Build a synthetic dg_lpsi result with feasibility$is_realistic containing FALSE.
test_that("print.dg_lpsi shows [!] WARNING for unrealistic desired gains (lines 713-715)", {
  r_base <- selection.index:::dg_lpsi(.P2, .G2,
    d = c(1, 1),
    return_implied_weights = FALSE,
    check_feasibility = TRUE
  )
  # Manually flag one trait as unrealistic
  r_unreal <- r_base
  r_unreal$feasibility$is_realistic <- c(FALSE, TRUE)
  class(r_unreal) <- c("dg_lpsi", "selection_index", "list")
  # [!] contains regex metacharacters [] and ! — escape them.
  expect_output(print(r_unreal), "\\[!\\] WARNING")
  expect_output(print(r_unreal), "unrealistic desired gains")
  expect_output(print(r_unreal), "Consider reducing targets")
})