Store the LD-sketch sample axis once and drop it on emptied sketches

R/GenotypeHandle.R

@@ -812,7 +812,14 @@ setClass(
 setMethod("dim", "GhSeed", function(x) x@dm)
 
 #' @rdname GhSeed-class
-setMethod("dimnames", "GhSeed", function(x) x@dn)
+setMethod("dimnames", "GhSeed", function(x) {
+    # The sample axis is derived from the handle, not stored a second time.
+    # handle@sampleIds is the single copy; storing dn[[2]] as well would
+    # duplicate ~10k anonymous projection-dimension names in every serialised
+    # sketch (see genotypeDelayedArray()). getSampleIds() is character(0) on an
+    # emptied handle, so this stays consistent with dm = c(nVar, 0).
+    list(x@dn[[1L]], as.character(getSampleIds(x@handle)))
+})
 
 # The handle a seed reads through. Internal accessor: GhSeed is not exported,
 # so this adds no public surface, and it keeps the `@` next to the class.
@@ -866,9 +873,12 @@ genotypeDelayedArray <- function(handle) {
         "GhSeed",
         handle = handle,
         dm = c(nrow(si), as.integer(getNSamples(handle))),
+        # Only the variant axis is stored; the sample axis is derived from the
+        # handle in the dimnames() method above, so the ~10k sample ids are not
+        # duplicated between dn[[2]] and handle@sampleIds.
         dn = list(
             normalizeVariantId(as.character(si$SNP)),
-            as.character(getSampleIds(handle))
+            NULL
         )
     )
     DelayedArray::DelayedArray(seed)

R/genotypeIo.R

@@ -102,11 +102,14 @@ setMethod(
     if (is.null(handle)) {
         return(NULL)
     }
-    si <- getSnpInfo(handle)
-    if (nrow(si) == 0L) {
-        return(handle)
-    }
-    handle@snpInfo <- slice(si, integer(0))
+    # Empty both axes. An emptied sketch references no LD, so its sample axis is
+    # dead weight (~10k anonymous names, the bulk of a skipped-region file).
+    # nSamples must go to 0 alongside sampleIds, or dm (variants x nSamples)
+    # would disagree with the now-empty derived sample dimnames. Reached only via
+    # .emptySketch (the empty / PIP-skip path), never on a surviving region.
+    handle@snpInfo <- slice(getSnpInfo(handle), integer(0))
+    handle@sampleIds <- character(0)
+    handle@nSamples <- 0L
     handle
 }
 

tests/testthat/test_genotypeHandle.R

@@ -814,6 +814,41 @@ test_that("the seed answers an empty extraction on either axis", {
     )
 })
 
+test_that("genotypeDelayedArray stores the sample axis once, derives it on read", {
+    # The sample ids are an anonymous projection dimension and would otherwise be
+    # duplicated between GhSeed@dn[[2]] and handle@sampleIds. The seed stores only
+    # the variant axis; dimnames() derives the sample axis from the handle.
+    data(qtlDatasetExample, envir = environment())
+    gh <- getGenotypeHandle(qtlDatasetExample)
+    seed <- genotypeDelayedArray(gh)@seed
+    expect_null(seed@dn[[2L]]) # not stored
+    expect_identical(dimnames(seed)[[2L]], as.character(getSampleIds(gh))) # derived
+    expect_identical(dimnames(seed)[[1L]], seed@dn[[1L]]) # variant axis stored
+    expect_equal(dim(seed)[[2L]], length(dimnames(seed)[[2L]])) # dm consistent
+})
+
+test_that(".emptyGenotypeHandle empties the sample axis as well as the variants", {
+    data(qtlDatasetExample, envir = environment())
+    gh <- getGenotypeHandle(qtlDatasetExample)
+    e <- pecotmr:::.emptyGenotypeHandle(gh)
+    expect_equal(nrow(getSnpInfo(e)), 0L)
+    expect_equal(length(getSampleIds(e)), 0L)
+    expect_equal(getNSamples(e), 0L)
+    # the rebuilt seed is a consistent 0 x 0 (no 0 x nSamples mismatch)
+    seed <- genotypeDelayedArray(e)@seed
+    expect_equal(dim(seed), c(0L, 0L))
+    expect_equal(lengths(dimnames(seed)), c(0L, 0L))
+})
+
+test_that(".emptySketch drops the sample axis on an RSE sketch", {
+    data(qtlDatasetExample, envir = environment())
+    gh <- getGenotypeHandle(qtlDatasetExample)
+    empty <- pecotmr:::.emptySketch(pecotmr:::.genotypeExperiment(gh))
+    h <- pecotmr:::.ldSketchHandle(empty)
+    expect_equal(length(getSampleIds(h)), 0L)
+    expect_equal(nrow(getSnpInfo(h)), 0L)
+})
+
 test_that("nothing is read until a block is actually touched", {
     # The point of the seed: a panel can be described without being read.
     data(qtlDatasetExample, envir = environment())

tests/testthat/test_sumstatsQc.R

@@ -7907,11 +7907,19 @@ test_that("both trimmers empty the sketch for zero-variant entries", {
     }
 })
 
-test_that("emptying keeps every other property of the panel", {
+test_that("emptying drops both axes but keeps the panel's identity", {
     h <- .sk_panel()
     e <- .subsetSketchToRange(h, list())
-    expect_equal(ncol(e), ncol(h))
-    expect_equal(colnames(e), colnames(h))
+    # The sample axis is shed along with the variants: an emptied sketch
+    # references no LD, so its anonymous sample names are dead weight (the bulk
+    # of a skipped-region file). What is kept is the panel's identity -- where
+    # it came from -- not its dimensions.
+    expect_equal(nrow(e), 0L)
+    expect_equal(ncol(e), 0L)
+    hh <- .ldSketchHandle(h)
+    eh <- .ldSketchHandle(e)
+    expect_equal(getFormat(eh), getFormat(hh))
+    expect_equal(getPath(eh), getPath(hh))
 })
 
 test_that(".emptySketch drops the seed's variants, not just the rows", {