tests/testthat/test-anova_helpers.R

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

# ==============================================================================
# Tests for ANOVA Helpers (R/anova_helpers.R)
# ==============================================================================

# Note: .calculate_anova() is a deprecated internal function that wraps
# the design_stats_api(). These tests ensure backward compatibility.

test_that(".calculate_anova works for RCBD design", {
  # Create test RCBD data
  set.seed(123)
  n_gen <- 10
  n_rep <- 3
  n_traits <- 4
  n_obs <- n_gen * n_rep

  data_mat <- matrix(rnorm(n_obs * n_traits), nrow = n_obs, ncol = n_traits)
  gen_idx <- rep(1:n_gen, each = n_rep)
  rep_idx <- rep(1:n_rep, times = n_gen)

  # Suppress deprecation warning for testing
  result <- suppressWarnings(
    selection.index:::.calculate_anova(
      data_mat = data_mat,
      gen_idx = gen_idx,
      rep_idx = rep_idx,
      design_type = 1L # RCBD
    )
  )

  # Check structure
  expect_type(result, "list")
  expect_true("GMS" %in% names(result))
  expect_true("EMS" %in% names(result))
  expect_true("MSG" %in% names(result))
  expect_true("MSE" %in% names(result))
  expect_true("DFG" %in% names(result))
  expect_true("DFE" %in% names(result))
  expect_true("n_rep" %in% names(result))
  expect_true("n_gen" %in% names(result))

  # Check dimensions
  expect_equal(length(result$GMS), n_traits)
  expect_equal(length(result$EMS), n_traits)
  expect_equal(dim(result$MSG), c(n_traits, n_traits))
  expect_equal(dim(result$MSE), c(n_traits, n_traits))

  # Check degrees of freedom
  expect_equal(result$DFG, n_gen - 1)
  expect_equal(result$DFE, (n_gen - 1) * (n_rep - 1))
  expect_equal(result$n_gen, n_gen)
  expect_equal(result$n_rep, n_rep)

  # Check values are finite
  expect_true(all(is.finite(result$GMS)))
  expect_true(all(is.finite(result$EMS)))
  expect_true(all(is.finite(result$MSG)))
  expect_true(all(is.finite(result$MSE)))
})

test_that(".calculate_anova works for LSD design", {
  # Create test Latin Square data
  set.seed(456)
  n_gen <- 5
  n_rep <- 5
  n_col <- 5
  n_traits <- 3
  n_obs <- n_gen * n_rep

  data_mat <- matrix(rnorm(n_obs * n_traits), nrow = n_obs, ncol = n_traits)
  gen_idx <- rep(1:n_gen, each = n_rep)
  rep_idx <- rep(1:n_rep, times = n_gen)
  col_idx <- rep(1:n_col, length.out = n_obs)

  # Suppress deprecation warning
  result <- suppressWarnings(
    selection.index:::.calculate_anova(
      data_mat = data_mat,
      gen_idx = gen_idx,
      rep_idx = rep_idx,
      col_idx = col_idx,
      design_type = 2L # LSD
    )
  )

  # Check structure
  expect_type(result, "list")
  expect_true("GMS" %in% names(result))
  expect_true("EMS" %in% names(result))
  expect_true("MSG" %in% names(result))
  expect_true("MSE" %in% names(result))

  # Check dimensions
  expect_equal(length(result$GMS), n_traits)
  expect_equal(length(result$EMS), n_traits)
  expect_equal(dim(result$MSG), c(n_traits, n_traits))
  expect_equal(dim(result$MSE), c(n_traits, n_traits))

  # Check degrees of freedom for LSD
  expect_equal(result$DFG, n_gen - 1)
  df_error_lsd <- (n_gen - 1) * (n_rep - 1) - (n_col - 1)
  expect_equal(result$DFE, df_error_lsd)

  # Check values are finite
  expect_true(all(is.finite(result$GMS)))
  expect_true(all(is.finite(result$EMS)))
})

test_that(".calculate_anova works for SPD design", {
  # Create test Split Plot data
  set.seed(789)
  n_gen <- 8
  n_rep <- 3
  n_main <- 4
  n_traits <- 3
  n_obs <- n_gen * n_rep

  data_mat <- matrix(rnorm(n_obs * n_traits), nrow = n_obs, ncol = n_traits)
  gen_idx <- rep(1:n_gen, each = n_rep)
  rep_idx <- rep(1:n_rep, times = n_gen)
  main_idx <- rep(1:n_main, each = (n_obs / n_main))

  # Suppress deprecation warning
  result <- suppressWarnings(
    selection.index:::.calculate_anova(
      data_mat = data_mat,
      gen_idx = gen_idx,
      rep_idx = rep_idx,
      main_idx = main_idx,
      design_type = 3L # SPD
    )
  )

  # Check structure
  expect_type(result, "list")
  expect_true("GMS" %in% names(result))
  expect_true("EMS" %in% names(result))
  expect_true("EMS_MAIN" %in% names(result))
  expect_true("DFE_MAIN" %in% names(result))
  expect_true("n_main" %in% names(result))

  # Check dimensions
  expect_equal(length(result$GMS), n_traits)
  expect_equal(length(result$EMS), n_traits)
  expect_equal(length(result$EMS_MAIN), n_traits)

  # Check SPD-specific components
  expect_false(is.na(result$DFE_MAIN))
  expect_equal(result$n_main, n_main)

  # Check values are finite
  expect_true(all(is.finite(result$GMS)))
  expect_true(all(is.finite(result$EMS)))
  expect_true(all(is.finite(result$EMS_MAIN)))
})

test_that(".calculate_anova issues deprecation warning", {
  set.seed(111)
  n_obs <- 30
  n_traits <- 2

  data_mat <- matrix(rnorm(n_obs * n_traits), nrow = n_obs, ncol = n_traits)
  gen_idx <- rep(1:10, each = 3)
  rep_idx <- rep(1:3, times = 10)

  # Expect deprecation warning
  expect_warning(
    selection.index:::.calculate_anova(
      data_mat = data_mat,
      gen_idx = gen_idx,
      rep_idx = rep_idx,
      design_type = 1L
    ),
    "deprecated"
  )

  expect_warning(
    selection.index:::.calculate_anova(
      data_mat = data_mat,
      gen_idx = gen_idx,
      rep_idx = rep_idx,
      design_type = 1L
    ),
    "design_stats_api"
  )
})

test_that(".calculate_anova returns matrices for MSG and MSE", {
  set.seed(222)
  n_gen <- 5
  n_rep <- 3
  n_traits <- 3
  n_obs <- n_gen * n_rep

  data_mat <- matrix(rnorm(n_obs * n_traits), nrow = n_obs, ncol = n_traits)
  gen_idx <- rep(1:n_gen, each = n_rep)
  rep_idx <- rep(1:n_rep, times = n_gen)

  result <- suppressWarnings(
    selection.index:::.calculate_anova(
      data_mat = data_mat,
      gen_idx = gen_idx,
      rep_idx = rep_idx,
      design_type = 1L
    )
  )

  # MSG and MSE should be square matrices
  expect_true(is.matrix(result$MSG))
  expect_true(is.matrix(result$MSE))
  expect_equal(nrow(result$MSG), ncol(result$MSG))
  expect_equal(nrow(result$MSE), ncol(result$MSE))
  expect_equal(nrow(result$MSG), n_traits)
})

test_that(".calculate_anova diagonal of MSG equals GMS vector", {
  set.seed(333)
  n_gen <- 6
  n_rep <- 4
  n_traits <- 3
  n_obs <- n_gen * n_rep

  data_mat <- matrix(rnorm(n_obs * n_traits), nrow = n_obs, ncol = n_traits)
  gen_idx <- rep(1:n_gen, each = n_rep)
  rep_idx <- rep(1:n_rep, times = n_gen)

  result <- suppressWarnings(
    selection.index:::.calculate_anova(
      data_mat = data_mat,
      gen_idx = gen_idx,
      rep_idx = rep_idx,
      design_type = 1L
    )
  )

  # Diagonal of MSG should equal GMS vector
  expect_equal(diag(result$MSG), result$GMS)
  expect_equal(diag(result$MSE), result$EMS)
})

test_that(".calculate_anova handles single trait", {
  set.seed(444)
  n_gen <- 8
  n_rep <- 3
  n_traits <- 1
  n_obs <- n_gen * n_rep

  data_mat <- matrix(rnorm(n_obs * n_traits), nrow = n_obs, ncol = n_traits)
  gen_idx <- rep(1:n_gen, each = n_rep)
  rep_idx <- rep(1:n_rep, times = n_gen)

  result <- suppressWarnings(
    selection.index:::.calculate_anova(
      data_mat = data_mat,
      gen_idx = gen_idx,
      rep_idx = rep_idx,
      design_type = 1L
    )
  )

  # Check single trait results
  expect_equal(length(result$GMS), 1)
  expect_equal(length(result$EMS), 1)
  expect_equal(dim(result$MSG), c(1, 1))
  expect_equal(dim(result$MSE), c(1, 1))

  # Single value should still be finite
  expect_true(is.finite(result$GMS))
  expect_true(is.finite(result$EMS))
})

test_that(".calculate_anova for SPD has NA for non-SPD fields in RCBD/LSD", {
  set.seed(555)
  n_gen <- 5
  n_rep <- 3
  n_traits <- 2
  n_obs <- n_gen * n_rep

  data_mat <- matrix(rnorm(n_obs * n_traits), nrow = n_obs, ncol = n_traits)
  gen_idx <- rep(1:n_gen, each = n_rep)
  rep_idx <- rep(1:n_rep, times = n_gen)

  # RCBD should have NA for SPD-specific fields
  result_rcbd <- suppressWarnings(
    selection.index:::.calculate_anova(
      data_mat = data_mat,
      gen_idx = gen_idx,
      rep_idx = rep_idx,
      design_type = 1L
    )
  )

  expect_true(all(is.na(result_rcbd$EMS_MAIN)))
  expect_true(is.na(result_rcbd$DFE_MAIN))
  expect_true(is.na(result_rcbd$n_main))
})

test_that(".calculate_anova returns correct count fields", {
  set.seed(666)
  n_gen <- 7
  n_rep <- 4
  n_traits <- 3
  n_obs <- n_gen * n_rep

  data_mat <- matrix(rnorm(n_obs * n_traits), nrow = n_obs, ncol = n_traits)
  gen_idx <- rep(1:n_gen, each = n_rep)
  rep_idx <- rep(1:n_rep, times = n_gen)

  result <- suppressWarnings(
    selection.index:::.calculate_anova(
      data_mat = data_mat,
      gen_idx = gen_idx,
      rep_idx = rep_idx,
      design_type = 1L
    )
  )

  expect_equal(result$n_gen, n_gen)
  expect_equal(result$n_rep, n_rep)
})

test_that(".calculate_anova handles unbalanced data gracefully", {
  set.seed(777)
  # Create slightly unbalanced data (some genotypes have fewer reps)
  gen_idx <- c(rep(1:5, each = 3), rep(6:10, each = 2))
  rep_idx <- c(rep(1:3, times = 5), rep(1:2, times = 5))
  n_obs <- length(gen_idx)
  n_traits <- 2

  data_mat <- matrix(rnorm(n_obs * n_traits), nrow = n_obs, ncol = n_traits)

  # Should still compute without error
  result <- suppressWarnings(
    selection.index:::.calculate_anova(
      data_mat = data_mat,
      gen_idx = gen_idx,
      rep_idx = rep_idx,
      design_type = 1L
    )
  )

  expect_type(result, "list")
  expect_true(all(is.finite(result$GMS)))
  expect_true(all(is.finite(result$EMS)))
})