Add 12 test files for LD utility functions, coverage 55% -> ~70%

Tests for LD_reference_options, UKB_find_ld_prefix,
check_LD_reference_1kg, check_population_1kg, clean_UKB_tmps,
fill_NA, get_locus_vcf_folder, get_rds_path, is_sparse_matrix,
snpstats_ensure_nonduplicates, to_sparse, message_parallel.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>

Author: bschilder

tests/testthat/test-LD_reference_options.R

@@ -0,0 +1,91 @@
+test_that("LD_reference_options returns all options when NULL", {
+    opts <- echoLD:::LD_reference_options(LD_reference = NULL)
+
+    testthat::expect_type(opts, "list")
+    testthat::expect_true("ukb" %in% names(opts))
+    testthat::expect_true("1kg" %in% names(opts))
+    testthat::expect_true("vcf" %in% names(opts))
+    testthat::expect_true("matrix" %in% names(opts))
+})
+
+test_that("LD_reference_options identifies UKB", {
+    result <- echoLD:::LD_reference_options(
+        LD_reference = "UKB",
+        verbose = FALSE
+    )
+    testthat::expect_equal(result, "ukb")
+})
+
+test_that("LD_reference_options identifies 1KG references", {
+    r1 <- echoLD:::LD_reference_options(
+        LD_reference = "1KGphase1",
+        verbose = FALSE
+    )
+    r3 <- echoLD:::LD_reference_options(
+        LD_reference = "1KGphase3",
+        verbose = FALSE
+    )
+    testthat::expect_equal(r1, "1kg")
+    testthat::expect_equal(r3, "1kg")
+})
+
+test_that("LD_reference_options identifies VCF files", {
+    for (ext in c(".vcf", ".vcf.gz", ".vcf.bgz")) {
+        result <- echoLD:::LD_reference_options(
+            LD_reference = paste0("/path/to/file", ext),
+            verbose = FALSE
+        )
+        testthat::expect_equal(result, "vcf",
+                               info = paste("Failed for extension:", ext))
+    }
+})
+
+test_that("LD_reference_options identifies matrix files", {
+    for (ext in c(".rds", ".rda", ".csv", ".tsv", ".txt")) {
+        result <- echoLD:::LD_reference_options(
+            LD_reference = paste0("/path/to/file", ext),
+            verbose = FALSE
+        )
+        testthat::expect_equal(result, "matrix",
+                               info = paste("Failed for extension:", ext))
+    }
+})
+
+test_that("LD_reference_options with as_subgroups returns subgroups", {
+    opts <- echoLD:::LD_reference_options(
+        LD_reference = NULL,
+        as_subgroups = TRUE
+    )
+    testthat::expect_true("r" %in% names(opts))
+    testthat::expect_true("table" %in% names(opts))
+    testthat::expect_true("Matrix Market" %in% names(opts))
+    # "matrix" should be removed when as_subgroups is TRUE
+    testthat::expect_false("matrix" %in% names(opts))
+})
+
+test_that("LD_reference_options subgroup identifies R files", {
+    result <- echoLD:::LD_reference_options(
+        LD_reference = "/path/to/file.rds",
+        as_subgroups = TRUE,
+        verbose = FALSE
+    )
+    testthat::expect_equal(result, "r")
+})
+
+test_that("LD_reference_options subgroup identifies table files", {
+    result <- echoLD:::LD_reference_options(
+        LD_reference = "/path/to/file.csv",
+        as_subgroups = TRUE,
+        verbose = FALSE
+    )
+    testthat::expect_equal(result, "table")
+})
+
+test_that("LD_reference_options subgroup identifies Matrix Market files", {
+    result <- echoLD:::LD_reference_options(
+        LD_reference = "/path/to/file.mtx",
+        as_subgroups = TRUE,
+        verbose = FALSE
+    )
+    testthat::expect_equal(result, "Matrix Market")
+})

tests/testthat/test-UKB_find_ld_prefix.R

@@ -0,0 +1,42 @@
+test_that("UKB_find_ld_prefix returns correct file name", {
+    result <- echoLD:::UKB_find_ld_prefix(
+        chrom = 10,
+        min_pos = 135000001,
+        verbose = FALSE
+    )
+    testthat::expect_true(grepl("^chr10_", result))
+    testthat::expect_true(grepl("_\\d+$", result))
+})
+
+test_that("UKB_find_ld_prefix handles chromosome 1 start", {
+    result <- echoLD:::UKB_find_ld_prefix(
+        chrom = 1,
+        min_pos = 500000,
+        verbose = FALSE
+    )
+    testthat::expect_equal(result, "chr1_1_3000001")
+})
+
+test_that("UKB_find_ld_prefix handles different chromosomes", {
+    r1 <- echoLD:::UKB_find_ld_prefix(chrom = 1, min_pos = 5000000,
+                                       verbose = FALSE)
+    r22 <- echoLD:::UKB_find_ld_prefix(chrom = 22, min_pos = 5000000,
+                                        verbose = FALSE)
+    testthat::expect_true(grepl("^chr1_", r1))
+    testthat::expect_true(grepl("^chr22_", r22))
+    # Same position should give same window offset
+    testthat::expect_equal(
+        gsub("chr\\d+_", "", r1),
+        gsub("chr\\d+_", "", r22)
+    )
+})
+
+test_that("UKB_find_ld_prefix 3Mb windows are correct", {
+    # Position at exactly 2,000,001 should be in the 2M-5M window
+    result <- echoLD:::UKB_find_ld_prefix(
+        chrom = 5,
+        min_pos = 2000001,
+        verbose = FALSE
+    )
+    testthat::expect_equal(result, "chr5_2000001_5000001")
+})

tests/testthat/test-check_LD_reference_1kg.R

@@ -0,0 +1,37 @@
+test_that("check_LD_reference_1kg accepts valid references", {
+    testthat::expect_equal(
+        echoLD:::check_LD_reference_1kg("1kgphase1"),
+        "1kgphase1"
+    )
+    testthat::expect_equal(
+        echoLD:::check_LD_reference_1kg("1kgphase3"),
+        "1kgphase3"
+    )
+})
+
+test_that("check_LD_reference_1kg lowercases input", {
+    testthat::expect_equal(
+        echoLD:::check_LD_reference_1kg("1KGphase1"),
+        "1kgphase1"
+    )
+    testthat::expect_equal(
+        echoLD:::check_LD_reference_1kg("1KGphase3"),
+        "1kgphase3"
+    )
+})
+
+test_that("check_LD_reference_1kg uses first element of vector", {
+    testthat::expect_equal(
+        echoLD:::check_LD_reference_1kg(c("1KGphase3", "1KGphase1")),
+        "1kgphase3"
+    )
+})
+
+test_that("check_LD_reference_1kg rejects invalid references", {
+    testthat::expect_error(
+        echoLD:::check_LD_reference_1kg("UKB")
+    )
+    testthat::expect_error(
+        echoLD:::check_LD_reference_1kg("invalid")
+    )
+})

tests/testthat/test-check_population_1kg.R

@@ -0,0 +1,59 @@
+test_that("check_population_1kg translates synonymous populations for phase3", {
+    testthat::expect_equal(
+        echoLD:::check_population_1kg("AFA", "1KGphase3"),
+        "AFR"
+    )
+    testthat::expect_equal(
+        echoLD:::check_population_1kg("HIS", "1KGphase3"),
+        "AMR"
+    )
+    testthat::expect_equal(
+        echoLD:::check_population_1kg("CAU", "1KGphase3"),
+        "EUR"
+    )
+})
+
+test_that("check_population_1kg passes through valid populations for phase3", {
+    for (pop in c("AFR", "AMR", "EAS", "EUR", "SAS")) {
+        testthat::expect_equal(
+            echoLD:::check_population_1kg(pop, "1KGphase3"),
+            pop,
+            info = paste("Failed for population:", pop)
+        )
+    }
+})
+
+test_that("check_population_1kg translates synonymous populations for phase1", {
+    testthat::expect_equal(
+        echoLD:::check_population_1kg("AFA", "1KGphase1"),
+        "AFR"
+    )
+    testthat::expect_equal(
+        echoLD:::check_population_1kg("EAS", "1KGphase1"),
+        "ASN"
+    )
+    testthat::expect_equal(
+        echoLD:::check_population_1kg("CAU", "1KGphase1"),
+        "EUR"
+    )
+})
+
+test_that("check_population_1kg handles case insensitivity", {
+    testthat::expect_equal(
+        echoLD:::check_population_1kg("eur", "1KGphase3"),
+        "EUR"
+    )
+    testthat::expect_equal(
+        echoLD:::check_population_1kg("afr", "1KGphase1"),
+        "AFR"
+    )
+})
+
+test_that("check_population_1kg errors on invalid population", {
+    testthat::expect_error(
+        echoLD:::check_population_1kg("INVALID", "1KGphase3")
+    )
+    testthat::expect_error(
+        echoLD:::check_population_1kg("INVALID", "1KGphase1")
+    )
+})

tests/testthat/test-clean_UKB_tmps.R

@@ -0,0 +1,40 @@
+test_that("clean_UKB_tmps removes .gz and .npz files", {
+    base_path <- file.path(tempdir(), "test_clean_ukb_base")
+    gz_file <- paste0(base_path, ".gz")
+    npz_file <- paste0(base_path, ".npz")
+
+    # Create temp files
+    writeLines("test", gz_file)
+    writeLines("test", npz_file)
+
+    testthat::expect_true(file.exists(gz_file))
+    testthat::expect_true(file.exists(npz_file))
+
+    echoLD:::clean_UKB_tmps(URL = base_path, verbose = FALSE)
+
+    testthat::expect_false(file.exists(gz_file))
+    testthat::expect_false(file.exists(npz_file))
+})
+
+test_that("clean_UKB_tmps handles non-existent files gracefully", {
+    base_path <- file.path(tempdir(), "nonexistent_file_12345")
+
+    # Should not error when files don't exist
+    testthat::expect_no_error(
+        echoLD:::clean_UKB_tmps(URL = base_path, verbose = FALSE)
+    )
+})
+
+test_that("clean_UKB_tmps removes only existing files", {
+    base_path <- file.path(tempdir(), "test_clean_partial")
+    gz_file <- paste0(base_path, ".gz")
+    npz_file <- paste0(base_path, ".npz")
+
+    # Only create .gz, not .npz
+    writeLines("test", gz_file)
+
+    echoLD:::clean_UKB_tmps(URL = base_path, verbose = FALSE)
+
+    testthat::expect_false(file.exists(gz_file))
+    testthat::expect_false(file.exists(npz_file))
+})

tests/testthat/test-compute_LD_blocks.R

@@ -0,0 +1,51 @@
+test_that("compute_LD_blocks works with sparse LD matrix", {
+    testthat::skip_if_not_installed("adjclust")
+
+    # Use BST1 LD matrix (already available via echodata)
+    ld_mat <- echodata::BST1_LD_matrix
+    # Ensure r2 (non-negative) for adjclust
+    ld_mat_r2 <- ld_mat^2
+    sparse_mat <- echoLD::to_sparse(X = ld_mat_r2, verbose = FALSE)
+
+    result <- echoLD:::compute_LD_blocks(
+        x = sparse_mat,
+        pct = 0.15,
+        verbose = FALSE
+    )
+
+    testthat::expect_type(result, "list")
+    testthat::expect_true("fit" %in% names(result))
+    testthat::expect_true("clusters" %in% names(result))
+    testthat::expect_true(length(unique(result$clusters)) >= 1)
+    testthat::expect_equal(length(result$clusters), nrow(ld_mat))
+})
+
+test_that("get_LD_blocks assigns LDblock column", {
+    testthat::skip_if_not_installed("adjclust")
+
+    ld_mat <- echodata::BST1_LD_matrix
+    # Use r2 for adjclust
+    ld_mat_r2 <- ld_mat^2
+    sparse_mat <- echoLD::to_sparse(X = ld_mat_r2, verbose = FALSE)
+
+    # Create matching query_dat with SNPs from the LD matrix
+    query_dat <- data.table::data.table(
+        SNP = rownames(ld_mat),
+        CHR = 4,
+        POS = seq_len(nrow(ld_mat)) * 1000,
+        P = runif(nrow(ld_mat)),
+        leadSNP = c(TRUE, rep(FALSE, nrow(ld_mat) - 1))
+    )
+
+    result <- echoLD::get_LD_blocks(
+        query_dat = query_dat,
+        ss = sparse_mat,
+        pct = 0.15,
+        verbose = FALSE
+    )
+
+    testthat::expect_type(result, "list")
+    testthat::expect_true("query_dat" %in% names(result))
+    testthat::expect_true("LD_r2" %in% names(result))
+    testthat::expect_true("LDblock" %in% colnames(result$query_dat))
+})

tests/testthat/test-fill_NA.R

@@ -0,0 +1,70 @@
+test_that("fill_NA replaces NAs with 0", {
+    mat <- matrix(
+        c(1, NA, 0.5, NA, 1, 0.3, 0.5, 0.3, 1),
+        nrow = 3,
+        dimnames = list(c("rs1", "rs2", "rs3"), c("rs1", "rs2", "rs3"))
+    )
+
+    result <- echoLD:::fill_NA(mat, fillNA = 0, verbose = FALSE)
+
+    testthat::expect_false(any(is.na(result)))
+    testthat::expect_equal(result["rs1", "rs2"], 0)
+    testthat::expect_equal(result["rs1", "rs1"], 1)
+})
+
+test_that("fill_NA removes rows/cols named '.'", {
+    mat <- matrix(
+        1,
+        nrow = 3, ncol = 3,
+        dimnames = list(c("rs1", ".", "rs3"), c("rs1", ".", "rs3"))
+    )
+
+    result <- echoLD:::fill_NA(mat, verbose = FALSE)
+
+    testthat::expect_false("." %in% rownames(result))
+    testthat::expect_false("." %in% colnames(result))
+    testthat::expect_equal(nrow(result), 2)
+    testthat::expect_equal(ncol(result), 2)
+})
+
+test_that("fill_NA handles matrix with unique rownames correctly", {
+    # fill_NA converts to data.frame internally, which makes rownames unique.
+    # Verify that deduplicated results are returned properly.
+    mat <- matrix(
+        c(1, 0.5, 0.5, 0.5, 1, 0.5, 0.5, 0.5, 1),
+        nrow = 3,
+        dimnames = list(c("rs1", "rs2", "rs3"), c("rs1", "rs2", "rs3"))
+    )
+
+    result <- echoLD:::fill_NA(mat, verbose = FALSE)
+
+    testthat::expect_equal(nrow(result), 3)
+    testthat::expect_equal(ncol(result), 3)
+    testthat::expect_false(any(duplicated(rownames(result))))
+    testthat::expect_false(any(duplicated(colnames(result))))
+})
+
+test_that("fill_NA with NULL fillNA skips NA replacement", {
+    mat <- matrix(
+        c(1, NA, NA, 1),
+        nrow = 2,
+        dimnames = list(c("rs1", "rs2"), c("rs1", "rs2"))
+    )
+
+    result <- echoLD:::fill_NA(mat, fillNA = NULL, verbose = FALSE)
+
+    testthat::expect_true(any(is.na(result)))
+})
+
+test_that("fill_NA preserves values when no NAs present", {
+    mat <- matrix(
+        c(1, 0.3, 0.3, 1),
+        nrow = 2,
+        dimnames = list(c("rs1", "rs2"), c("rs1", "rs2"))
+    )
+
+    result <- echoLD:::fill_NA(mat, fillNA = 0, verbose = FALSE)
+
+    testthat::expect_equal(result["rs1", "rs2"], 0.3)
+    testthat::expect_equal(result["rs1", "rs1"], 1)
+})