diff --git a/R/sumstatsQc.R b/R/sumstatsQc.R index 7c9b180b..d564edcb 100644 --- a/R/sumstatsQc.R +++ b/R/sumstatsQc.R @@ -3132,13 +3132,33 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, list(gr = .dfToEntryGranges(df), audit = entryAudit) } +# Return `ldSketch` trimmed to zero variants (empty @snpInfo), preserving every +# other slot (path / format / nSamples / sampleIds / chromPaths). Used when an +# entry set genuinely carries no variants: the object references no LD, so the +# correct retained panel is empty rather than the full genome-wide sketch. Edits +# @snpInfo directly (not .subsetGenotypeHandle) because a zero-variant sketch is +# never read for extraction, so the fileIdx read-safety guard does not apply -- +# this keeps the empty correct even on a legacy sketch with no fileIdx column. +# NULL-safe; a no-op when the sketch is already empty. +# @noRd +.emptySketch <- function(ldSketch) { + if (is.null(ldSketch)) return(NULL) + si <- getSnpInfo(ldSketch) + if (nrow(si) == 0L) return(ldSketch) + ldSketch@snpInfo <- si[integer(0), , drop = FALSE] + rownames(ldSketch@snpInfo) <- NULL + ldSketch +} + # Shrink an LD-sketch GenotypeHandle to the panel variants inside the summary # statistics' per-chromosome position span. `entries` is a list/SimpleList of # per-study (or per-tuple) GRanges. A genome-wide sketch otherwise carries a # full-genome snpInfo; only variants inside [min,max] BP of each represented # chromosome are reachable by harmonization or within-range imputation, so the -# rest is dropped at load time. NULL-safe; a no-op when the span already covers -# the panel. See [[.subsetGenotypeHandle]] for why this is read-safe. +# rest is dropped at load time. With zero variants there is no span to keep, so +# the sketch is emptied (a zero-variant object references no LD). NULL-safe; a +# no-op when the span already covers the panel. See [[.subsetGenotypeHandle]] for +# why this is read-safe. # @noRd .subsetSketchToRange <- function(ldSketch, entries) { if (is.null(ldSketch)) return(NULL) @@ -3148,7 +3168,7 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, as.integer(GenomicRanges::start(gr))), use.names = FALSE) ok <- !is.na(chrom) & !is.na(pos) chrom <- chrom[ok]; pos <- pos[ok] - if (length(pos) == 0L) return(ldSketch) + if (length(pos) == 0L) return(.emptySketch(ldSketch)) lo <- tapply(pos, chrom, min) hi <- tapply(pos, chrom, max) si <- getSnpInfo(ldSketch) @@ -3163,10 +3183,19 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, # Shrink an LD-sketch GenotypeHandle to EXACTLY the variants present across the # QC'd `entries` (imputation may have added variants; QC may have dropped some), # matched by canonical variant id. Applied at the end of summaryStatsQc so the -# retained sketch mirrors the object's final variant set. NULL-safe. +# retained sketch mirrors the object's final variant set. When the entries carry +# zero variants (e.g. a study that early-exited QC) the sketch is emptied rather +# than left full. NULL-safe. # @noRd .subsetSketchToIds <- function(ldSketch, entries) { if (is.null(ldSketch)) return(NULL) + # Genuine variant count (ranges) across entries, independent of the SNP mcol: + # zero ranges means the object references no LD, so the panel is emptied. This + # is distinct from the pathological "ranges present but SNP mcol absent" case + # below, which stays conservative (full sketch) rather than blanking. + nRanges <- sum(vapply(entries, function(gr) + if (is.null(gr)) 0L else length(gr), integer(1))) + if (nRanges == 0L) return(.emptySketch(ldSketch)) ids <- unlist(lapply(entries, function(gr) { if (is.null(gr)) return(character(0)) snp <- S4Vectors::mcols(gr)$SNP diff --git a/tests/testthat/test_sumstatsQc.R b/tests/testthat/test_sumstatsQc.R index 4b9d37d2..c4b25815 100644 --- a/tests/testthat/test_sumstatsQc.R +++ b/tests/testthat/test_sumstatsQc.R @@ -5627,6 +5627,43 @@ test_that(".subsetSketchToIds keeps exactly the entries' variants", { expect_setequal(normalizeVariantId(sub$SNP), normalizeVariantId(si$SNP[sel])) }) +test_that("zero-variant entries empty the sketch (both trimmers), not keep the full panel", { + h <- readGenotypes(test_path("test_data/test_variants"), format = "plink2") + full <- nrow(getSnpInfo(h)) + expect_gt(full, 0L) + # an empty list and a zero-range GRanges both represent zero variants. + for (entries in list(list(), list(GenomicRanges::GRanges()))) { + r <- pecotmr:::.subsetSketchToRange(h, entries) + i <- pecotmr:::.subsetSketchToIds(h, entries) + expect_identical(nrow(getSnpInfo(r)), 0L) + expect_identical(nrow(getSnpInfo(i)), 0L) + expect_identical(getNSamples(r), getNSamples(h)) # other slots preserved + expect_true(validObject(r)) + } +}) + +test_that(".subsetSketchToIds stays conservative when entries have ranges but no SNP mcol", { + h <- readGenotypes(test_path("test_data/test_variants"), format = "plink2") + si <- getSnpInfo(h) + sel <- c(3L, 10L, 40L) + gr <- GenomicRanges::GRanges(paste0("chr", si$CHR[sel]), + IRanges::IRanges(as.integer(si$BP[sel]), width = 1L)) # no SNP mcol + # ranges present (not zero-variant), ids unextractable -> full sketch, not emptied. + expect_identical(nrow(getSnpInfo(pecotmr:::.subsetSketchToIds(h, list(gr)))), + nrow(si)) +}) + +test_that(".emptySketch zeros snpInfo, preserves slots, is NULL-safe and idempotent", { + h <- readGenotypes(test_path("test_data/test_variants"), format = "plink2") + e <- pecotmr:::.emptySketch(h) + expect_identical(nrow(getSnpInfo(e)), 0L) + expect_identical(getNSamples(e), getNSamples(h)) + expect_identical(getFormat(e), getFormat(h)) + expect_true(validObject(e)) + expect_identical(nrow(getSnpInfo(pecotmr:::.emptySketch(e))), 0L) # idempotent + expect_null(pecotmr:::.emptySketch(NULL)) +}) + test_that(".subsetSketchToRange / .subsetSketchToIds are NULL-safe", { expect_null(pecotmr:::.subsetSketchToRange(NULL, list())) expect_null(pecotmr:::.subsetSketchToIds(NULL, list()))