tests/testthat/test-read-hpa.R

In AdmixPoly: Global and Local Admixture Inference in Polyploids

# =========================================================================
# Shared Mock HPA File Factory Generator
# =========================================================================
write_mock_hpa <- function(missing_marker = FALSE) {
  # Reconstruct structural HPA layout variant generated by HaploCharmer
  hpa_headers <- c(
    "#HAPLOTYPE\tCHROM\tSTART\tEND\tSEQUENCE\tFORMAT\tInd1\tInd2",
    # Phase Set Block 1 (Chr1) - Haplotype 1
    paste0("Chr1_1000_1004_hap1\tChr1\t1000\t1004\tATCG\tGT:DP:AD\t",
           if(missing_marker) ".:.:." else "1:20:15", "\t0:30:0"),
    # Phase Set Block 1 (Chr1) - Haplotype 2
    paste0("Chr1_1000_1004_hap2\tChr1\t1000\t1004\tGGGG\tGT:DP:AD\t",
           if(missing_marker) ".:.:." else "1:20:5", "\t1:30:30"),
    # Phase Set Block 2 (Chr1) - Haplotype 1
    "Chr1_2000_2004_hap1\tChr1\t2000\t2004\tATAT\tGT:DP:AD\t1:20:15\t0:30:0",
    # Phase Set Block 2 (Chr1) - Haplotype 2
    "Chr1_2000_2004_hap2\tChr1\t2000\t2004\tGTGT\tGT:DP:AD\t1:20:5\t1:30:30",
    # Phase Set Block 3 (Chr2) 
    "Chr2_1000_1004_hap1\tChr2\t1000\t1004\tCCCC\tGT:DP:AD\t1:30:25\t0:10:0",
    # Phase Set Block 3 (Chr2) 
    "Chr2_1000_1004_hap2\tChr2\t1000\t1004\tCTCC\tGT:DP:AD\t1:30:5\t0:10:0",
    # Phase Set Block 3 (Chr2) 
    "Chr2_1000_1004_hap3\tChr2\t1000\t1004\tCCTC\tGT:DP:AD\t0:30:0\t1:10:10",
    # Phase Set Block 4 (Chr2) 
    "Chr2_5000_5004_hap1\tChr2\t5000\t5004\tCCAA\tGT:DP:AD\t1:15:15\t1:40:40"
  )
  
  tmp_file <- tempfile(fileext = ".hpa")
  writeLines(hpa_headers, tmp_file)
  return(tmp_file)
}

# =========================================================================
# 1. Structural Sanity & Layout Transformations
# =========================================================================
test_that("ReadHPA cleanly parses haplotype formats and resolves phase structures", {
  hpa_path <- write_mock_hpa(missing_marker = FALSE)
  on.exit(unlink(hpa_path))
  
  res <- ReadHPA(File = hpa_path, MaxMarkerMissing = 1.0, MaxIndMissing = 1.0, Verbose = FALSE, NbThreads = 1)
  
  # Assert matching component structures
  expect_type(res, "list")
  expect_named(res, c("Geno", "MarkerInfo", "GeneticMap"))
  
  # Verify formatting strings transformations inside separate blocks
  expect_true("PS" %in% colnames(res$MarkerInfo))
  expect_equal(res$MarkerInfo$PS[1], "Chr1_1000_1004")
})

# =========================================================================
# 2. Dynamic Missing Variant Aggregation
# =========================================================================
test_that("ReadHPA filters missing haplotype elements without breaking internal matrices arrays", {
  hpa_path <- write_mock_hpa(missing_marker = TRUE)
  on.exit(unlink(hpa_path))

  res <- ReadHPA(File = hpa_path, MaxMarkerMissing = 0.10, MaxIndMissing = 1.0, Verbose = FALSE, NbThreads = 1)

  # Validate that metadata trackers drop filtered records concurrently
  expect_equal(length(res$Geno), 2)
  expect_false("Chr1_1000_1004" %in% res$MarkerInfo$PS)
  expect_false("Chr2_5000_5004" %in% res$MarkerInfo$PS)
  
})

# =========================================================================
# 3. Singleton Grouping Distance Invariance (The NaN Trap Verification)
# =========================================================================
test_that("Genetic Map translation runs seamlessly over single-block chromosomes", {
  hpa_path <- write_mock_hpa(missing_marker = FALSE)
  on.exit(unlink(hpa_path))

  res <- ReadHPA(File = hpa_path, MaxMarkerMissing = 1.0, MaxIndMissing = 1.0, Verbose = FALSE, NbThreads = 1)

  # Isolate standalone Chromosome 2 distance values
  chr2_record <- res$GeneticMap[res$GeneticMap$Chromosome == "Chr2", ]

  # Distance calculations must resolve to 0 instead of returning NaN values
  expect_equal(nrow(chr2_record), 1)
  expect_false(is.nan(chr2_record$Distance))
  expect_equal(chr2_record$Distance, 0)
})

# =========================================================================
# 4. Error Checking Assertions & Console Suppression
# =========================================================================
test_that("ReadHPA enforces target field checks and keeps execution quiet", {
  # Test invalid file paths intercept handles cleanly
  expect_error(ReadHPA(File = "empty_void.hpa", Verbose = FALSE), regexp = "No file was found")

  hpa_path <- write_mock_hpa(missing_marker = FALSE)
  on.exit(unlink(hpa_path))

  # Test invalid FORMAT variable validation
  expect_error(
    ReadHPA(File = hpa_path, TotalDepthField = "TD", Verbose = FALSE),
    regexp = "was not found in FORMAT field"
  )

  # Verify zero leaking output streams when verbose option flag matches FALSE
  expect_silent(ReadHPA(File = hpa_path, Verbose = FALSE))
})