tests/testthat/test-simulation.R

In AdmixPoly: Global and Local Admixture Inference in Polyploids

# =========================================================================
# 1. Structural Sanity Tests (The Happy Path)
# =========================================================================
test_that("SimulatePop yields correct dimensions with default options", {
  # Keep test parameters tiny for speed
  N_test <- 5L
  M_test <- 12L
  K_test <- 2L
  C_test <- 3L
  
  res <- SimulatePop(K = K_test, N = N_test, M = M_test, C = C_test, Seed = 42L, NbThreads = 1)
  
  # Structural Checks
  expect_type(res, "list")
  expect_named(res, c("Geno", "Ancestry", "Prop", "Freq", "GeneticMap"))
  
  # Check Output Matrix / List Dimensional Consistency
  expect_length(res$Geno, M_test)
  expect_length(res$Ancestry, N_test)
  expect_length(res$Freq, M_test)
  expect_equal(dim(res$Prop), c(N_test, K_test))
  expect_equal(nrow(res$GeneticMap), M_test)
  
  # Check item metadata bindings
  expect_equal(unname(rownames(res$Prop)), paste0("Ind", 1:N_test))
  expect_equal(unname(colnames(res$Prop)), paste0("K", 1:K_test))
})

# =========================================================================
# 2. Input Overrides (Testing Your 'If Informed' Blocks)
# =========================================================================
test_that("SimulatePop respects user-supplied matrices and dataframes", {
  
  # Scenario A: User provides an explicit Prop matrix
  custom_prop <- matrix(c(0.8, 0.2, 0.3, 0.7), nrow = 2, ncol = 2)
  rownames(custom_prop) <- c("CustomInd1", "CustomInd2")
  colnames(custom_prop) <- c("Anc1", "Anc2")
  
  res_prop <- SimulatePop(Prop = custom_prop, M = 10L, C = 2L, NbThreads = 1)
  expect_equal(rownames(res_prop$Prop), c("CustomInd1", "CustomInd2"))
  expect_equal(colnames(res_prop$Prop), c("Anc1", "Anc2"))

  # Scenario B: User provides an explicit Freq list
  custom_freq <- list(rs1=matrix(c(0.8, 0.2, 0.3, 0.7), nrow = 2, ncol = 2,
                                 dimnames = list(c("Anc1", "Anc2"),c("A", "T"))),
                      rs2=matrix(c(0.5, 0.3, 0.2, 0.3, 0.3, 0.4), nrow = 2, ncol = 3,
                                 dimnames = list(c("Anc1", "Anc2"),c("G", "T", "C"))))

  res_freq <- SimulatePop(Freq = custom_freq, N = 3L, C = 1L, NbThreads = 1)
  expect_equal(names(res_freq$Freq), c("rs1", "rs2"))
  expect_equal(rownames(res_freq$Freq$rs1), c("Anc1", "Anc2"))
  expect_equal(colnames(res_freq$Freq$rs1), c("A", "T"))
  
  # Scenario C: User provides a custom GeneticMap
  custom_map <- data.frame(
    Marker = c("rs1", "rs2", "rs3", "rs4"),
    Chromosome = c("ChrA", "ChrA", "ChrB", "ChrB"),
    Distance = c(0, 50, 0, 100)
  )
  
  res_map <- SimulatePop(GeneticMap = custom_map, N = 3L, K = 2L, NbThreads = 1)
  expect_equal(nrow(res_map$GeneticMap), 4)
  expect_equal(unique(res_map$GeneticMap$Chromosome), c("ChrA", "ChrB"))
  expect_equal(res_map$GeneticMap$Marker, c("rs1", "rs2", "rs3", "rs4"))
})

# =========================================================================
# 3. Sequencing Depth Branches (Testing Optional Output Appendix)
# =========================================================================
test_that("Sequencing read depth additions trigger correctly", {
  N_test <- 4L
  M_test <- 10L
  D_test <- 10L
  
  # Scalar Depth
  res_scalar <- SimulatePop(N = N_test, M = M_test, Depth = D_test, NbThreads = 1)
  expect_true("AlleleDepth" %in% names(res_scalar))
  expect_length(res_scalar$AlleleDepth, M_test)
  expect_true(all(sapply(res_scalar$AlleleDepth,rowSums)==D_test))
  
  # Matrix Depth
  depth_mat <- matrix(rep(seq(D_test,D_test*5,10),8), nrow = N_test, ncol = M_test)
  res_matrix <- SimulatePop(N = N_test, M = M_test, Depth = depth_mat, NbThreads = 1)
  expect_true("AlleleDepth" %in% names(res_matrix))
  expect_true(all(sapply(res_matrix$AlleleDepth,rowSums)==seq(D_test,D_test*5,10)))
  
})

# =========================================================================
# 4. Input Constraints and Error Raising (Stopifnot Check Verification)
# =========================================================================
test_that("SimulatePop throws clean errors when input restrictions are crossed", {
  
  # Invalid number of ancestral groups (K < 2)
  expect_error(SimulatePop(K = 1L), regexp = "K must be an integer superior or equal to 2")
  
  # Invalid number of individuals (N < 2)
  expect_error(SimulatePop(N = 1L), regexp = "N must be an integer superior or equal to 2")
  
  # Invalid ploidy (P < 1)
  expect_error(SimulatePop(P = 0L), regexp = "P must be positive integers, either as single value or as a vector")
  
  # Invalid number of chromosomes (C < 1)
  expect_error(SimulatePop(C = 0L), regexp = "C must be a positive integer")
  
  # Invalid number of alleles (L < 2)
  expect_error(SimulatePop(L = 1L), regexp = "L must be integers superior or equal to 2, either as single value or as a vector")
  
  # Invalid Number of markers relative to chromosome number (M < 2*C)
  expect_error(SimulatePop(M = 9L, C = 5L), regexp = "M must be an integer superior or equal to 2C")
  
  # Out of bounds SmoothParam
  expect_error(SimulatePop(SmoothParam = 0), regexp = "SmoothParam must be a positive numeric value")
  
  # Out of bounds AlphaProp
  expect_error(SimulatePop(AlphaProp = 0), regexp = "AlphaProp must be a positive numeric value")
  
  # Out of bounds AlphaFreq
  expect_error(SimulatePop(AlphaFreq = 0), regexp = "AlphaFreq must be a positive numeric value")
  
  # Out of bounds Error Rate boundaries
  expect_error(SimulatePop(SeqError = 1.05), regexp = "SeqError must be a positive numeric value")
  expect_error(SimulatePop(SeqError = -0.01), regexp = "SeqError must be a positive numeric value")
  
  # Ill-formed user data structures
  bad_map <- data.frame(BadCol1 = 1, BadCol2 = 2)
  expect_error(SimulatePop(GeneticMap = bad_map), regexp = "When informed, GeneticMap must be a dataframe")
  
  # Mismatched Matrix constraints
  custom_prop <- matrix(0.5, nrow = 3, ncol = 3)
  # Mocking Freq map where columns don't equal dimensions of Prop matrix
  bad_freq <- list(matrix(0.5, nrow = 5, ncol = 2),matrix(0.5, nrow = 5, ncol = 2)) 
  expect_error(SimulatePop(Prop = custom_prop, Freq = bad_freq, C=1L), regexp = "same number of rows as Prop")
  
  # Mismatched Depth Dimensions
  bad_depth_mat <- matrix(10L, nrow = 2, ncol = 2) # Supposed to be N x M
  expect_error(SimulatePop(N = 5, M = 10, Depth = bad_depth_mat), regexp = "matrix of size N x M")
})

# =========================================================================
# 5. Reproducibility Assurance (Deterministic Seeds)
# =========================================================================
test_that("Simulation instances remain stable under static seed injections", {
  # Run identical setups with matching seeds
  sim1 <- SimulatePop(K = 2L, N = 5L, M = 10L, Seed = 777L, NbThreads = 1)
  sim2 <- SimulatePop(K = 2L, N = 5L, M = 10L, Seed = 777L, NbThreads = 1)
  
  expect_equal(sim1$Prop, sim2$Prop)
  expect_equal(sim1$Geno, sim2$Geno)
  
  # Verify a modified seed alters outputs
  sim_different <- SimulatePop(K = 2L, N = 5L, M = 10L, Seed = 888L, NbThreads = 1)
  expect_false(identical(sim1$Prop, sim_different$Prop))
})