Chr name fixes

R/AllClasses.R

@@ -20,10 +20,10 @@ NULL
 # -----------------------------------------------------------------------------
 # Shared parent of the QTL and GWAS summary statistics collections.
 # Concrete subclasses (QtlSumStats, GwasSumStats) inherit from DFrame and
-# share the ldSketch / genome / qcInfo slots. Class-specific accessors
-# (getZ / getN / getMaf / nSnps / subsetChr / getVarY / getSumStats)
-# stay on the concrete subclass because they rely on the tuple shape
-# (3-tuple for QtlSumStats, 1-tuple for GwasSumStats).
+# share the ldSketch / genome / qcInfo slots. getZ / getN / getMaf / nSnps are
+# defined once on SumStatsBase (they only delegate to getSumStats); subsetChr /
+# getVarY / getSumStats / getSumstatDf stay on the concrete subclass because
+# they rely on the tuple shape (3-tuple QtlSumStats, 1-tuple GwasSumStats).
 # =============================================================================
 
 #' @title Summary Statistics Base Class
@@ -88,6 +88,28 @@ setMethod("getLdSketch", "SumStatsBase", function(x, ...) x@ldSketch)
 setMethod("getStudy", "SumStatsBase",
           function(x) unique(as.character(x$study)))
 
+# getZ / getN / getMaf / nSnps delegate purely to getSumStats (which the
+# concrete subclass dispatches with its own tuple shape), so they live once on
+# the base and forward `...` through.
+#' @rdname getZ
+#' @export
+setMethod("getZ", "SumStatsBase", function(x, ...) mcols(getSumStats(x, ...))$Z)
+
+#' @rdname getN
+#' @export
+setMethod("getN", "SumStatsBase", function(x, ...) mcols(getSumStats(x, ...))$N)
+
+#' @rdname getMaf
+#' @export
+setMethod("getMaf", "SumStatsBase", function(x, ...) {
+  mc <- mcols(getSumStats(x, ...))
+  if ("MAF" %in% colnames(mc)) mc$MAF else NULL
+})
+
+#' @rdname nSnps
+#' @export
+setMethod("nSnps", "SumStatsBase", function(x, ...) length(getSumStats(x, ...)))
+
 # =============================================================================
 # FineMappingResultBase
 # -----------------------------------------------------------------------------
@@ -145,3 +167,60 @@ setMethod("adjustPips", "FineMappingResultBase",
     x@listData$entry <- entries
     x
   })
+
+# Select the single FineMappingEntry addressed by a (tuple / region) key. Each
+# concrete subclass implements this with its own row selector; the delegating
+# accessors below then live once on the base and route through it.
+setGeneric(".fmrSelectEntry", function(x, ...) standardGeneric(".fmrSelectEntry"))
+
+#' @rdname getCs
+#' @export
+setMethod("getCs", "FineMappingResultBase",
+  function(x, study = NULL, context = NULL, trait = NULL, method = NULL,
+           region = NULL, coverage = 0.95, ...) {
+    getCs(.fmrSelectEntry(x, study = study, context = context, trait = trait,
+                          method = method, region = region),
+          coverage = coverage)
+  })
+
+#' @rdname getTopLoci
+#' @export
+setMethod("getTopLoci", "FineMappingResultBase",
+  function(x, type = c("data.frame", "GRanges"), signalCutoff = 0.025,
+           study = NULL, context = NULL, trait = NULL, method = NULL,
+           region = NULL, ...) {
+    getTopLoci(.fmrSelectEntry(x, study = study, context = context,
+                               trait = trait, method = method, region = region),
+               type = match.arg(type), signalCutoff = signalCutoff)
+  })
+
+#' @rdname getMarginalEffects
+#' @export
+setMethod("getMarginalEffects", "FineMappingResultBase",
+  function(x, maxPval = NULL,
+           study = NULL, context = NULL, trait = NULL, method = NULL,
+           region = NULL, ...) {
+    getMarginalEffects(.fmrSelectEntry(x, study = study, context = context,
+                                       trait = trait, method = method,
+                                       region = region), maxPval = maxPval)
+  })
+
+#' @rdname getSusieFit
+#' @export
+setMethod("getSusieFit", "FineMappingResultBase",
+  function(x, study = NULL, context = NULL, trait = NULL, method = NULL,
+           region = NULL, ...) {
+    getSusieFit(.fmrSelectEntry(x, study = study, context = context,
+                                trait = trait, method = method,
+                                region = region))
+  })
+
+#' @rdname getVariantIds
+#' @export
+setMethod("getVariantIds", "FineMappingResultBase",
+  function(x, study = NULL, context = NULL, trait = NULL, method = NULL,
+           region = NULL, ...) {
+    getVariantIds(.fmrSelectEntry(x, study = study, context = context,
+                                  trait = trait, method = method,
+                                  region = region))
+  })

R/FineMappingEntry.R

@@ -190,11 +190,16 @@ setMethod("getCs", "FineMappingEntry",
 setMethod("adjustPips", "FineMappingEntry",
   function(x, keepVariants, ...) {
     keepVariants <- as.character(keepVariants)
-    common <- intersect(x@variantIds, keepVariants)
-    if (!length(common))
+    # Match the entry's variants to `keepVariants` by (chrom, pos, allele) so a
+    # chr-prefix / separator difference does not read as no-overlap. PIP / LBF
+    # are coding-invariant, so this is pure identity (no sign). keepIdx is kept
+    # in the entry's variant order so the fit-matrix subsetting is unchanged.
+    m <- matchVariants(x@variantIds, keepVariants)
+    if (!length(m$idxA))
       stop("adjustPips: intersection of entry variants with `keepVariants` ",
            "is empty.")
-    keepIdx <- match(common, x@variantIds)
+    keepIdx <- sort(m$idxA)
+    common  <- x@variantIds[keepIdx]
     fit <- x@susieFit
     if (is.null(fit$lbf_variable))
       stop("adjustPips: entry's susieFit has no `lbf_variable` matrix; ",

R/GenotypeHandle.R

@@ -285,10 +285,9 @@ GenotypeHandle <- function(path = NULL,
 # One-file-per-chromosome (sharded) handle support
 # ---------------------------------------------------------------------------
 
-# Canonicalize a chromosome label to a bare token (strip a leading "chr").
-# Used as the routing key in @chromPaths and when matching @snpInfo$CHR.
-#' @keywords internal
-.canonChr <- function(x) sub("^chr", "", as.character(x), ignore.case = TRUE)
+# Chromosome labels are canonicalized via canonChrom() (variantId.R) -- the
+# single chromosome normalizer used for @chromPaths routing keys and for
+# @snpInfo$CHR lookups, so both sides stay consistent (and X/Y/MT survive).
 
 # Per-chromosome shard map, tolerant of GenotypeHandle objects deserialized
 # from before the `chromPaths` slot existed (e.g. an RDS saved by an older
@@ -389,7 +388,7 @@ GenotypeHandle <- function(path = NULL,
 
   chromPaths <- character(0)
   for (i in seq_along(shards)) {
-    chs <- unique(.canonChr(shards[[i]]@snpInfo$CHR))
+    chs <- unique(canonChrom(shards[[i]]@snpInfo$CHR))
     for (ch in chs) {
       if (ch %in% names(chromPaths))
         stop("GenotypeHandle(genoMeta): chromosome '", ch, "' appears in ",

R/GwasFineMappingResult.R

@@ -161,54 +161,13 @@ setMethod("getPip", "GwasFineMappingResult",
     getPip(x$entry[[idx]])
   })
 
-#' @rdname getCs
-#' @export
-setMethod("getCs", "GwasFineMappingResult",
+# Row selector for the base delegating accessors (getCs / getTopLoci /
+# getMarginalEffects / getSusieFit / getVariantIds live on
+# FineMappingResultBase, AllClasses.R). The Gwas selector threads `region`.
+setMethod(".fmrSelectEntry", "GwasFineMappingResult",
   function(x, study = NULL, context = NULL, trait = NULL, method = NULL,
-           region = NULL, ...) {
-    idx <- .tupleSelectRowGwasFmr(x, study, method, region)
-    getCs(x$entry[[idx]])
-  })
-
-#' @rdname getTopLoci
-#' @export
-setMethod("getTopLoci", "GwasFineMappingResult",
-  function(x, type = c("data.frame", "GRanges"),
-           signalCutoff = 0.025,
-           study = NULL, context = NULL, trait = NULL, method = NULL,
-           region = NULL, ...) {
-    idx <- .tupleSelectRowGwasFmr(x, study, method, region)
-    getTopLoci(x$entry[[idx]], type = match.arg(type),
-               signalCutoff = signalCutoff)
-  })
-
-#' @rdname getMarginalEffects
-#' @export
-setMethod("getMarginalEffects", "GwasFineMappingResult",
-  function(x, maxPval = NULL,
-           study = NULL, context = NULL, trait = NULL, method = NULL,
-           region = NULL, ...) {
-    idx <- .tupleSelectRowGwasFmr(x, study, method, region)
-    getMarginalEffects(x$entry[[idx]], maxPval = maxPval)
-  })
-
-#' @rdname getSusieFit
-#' @export
-setMethod("getSusieFit", "GwasFineMappingResult",
-  function(x, study = NULL, context = NULL, trait = NULL, method = NULL,
-           region = NULL, ...) {
-    idx <- .tupleSelectRowGwasFmr(x, study, method, region)
-    getSusieFit(x$entry[[idx]])
-  })
-
-#' @rdname getVariantIds
-#' @export
-setMethod("getVariantIds", "GwasFineMappingResult",
-  function(x, study = NULL, context = NULL, trait = NULL, method = NULL,
-           region = NULL, ...) {
-    idx <- .tupleSelectRowGwasFmr(x, study, method, region)
-    getVariantIds(x$entry[[idx]])
-  })
+           region = NULL, ...)
+    x$entry[[.tupleSelectRowGwasFmr(x, study, method, region)]])
 
 
 #' @export

R/LdData.R

@@ -160,9 +160,7 @@ setMethod("getCorrelation", "LdData", function(x) {
            "Construct LdData with mixtureWeights = <numeric vector> ",
            "when supplying a list of GenotypeHandles.")
     perPanel <- lapply(x@genotypeHandle, function(h) {
-      geno <- extractBlockGenotypes(h, x@snpIdx)
-      X <- t(assay(geno, "dosage"))
-      computeLd(X, method = "sample")
+      computeLd(.dosageMatrix(h, x@snpIdx), method = "sample")
     })
     dims <- vapply(perPanel, function(R) nrow(R), integer(1))
     if (length(unique(dims)) != 1L)
@@ -175,9 +173,7 @@ setMethod("getCorrelation", "LdData", function(x) {
     dimnames(R) <- dimnames(perPanel[[1L]])
     return(R)
   }
-  geno <- extractBlockGenotypes(x@genotypeHandle, x@snpIdx)
-  X <- t(assay(geno, "dosage"))
-  computeLd(X, method = "sample")
+  computeLd(.dosageMatrix(x@genotypeHandle, x@snpIdx), method = "sample")
 })
 
 #' @rdname getGenotypes
@@ -186,13 +182,9 @@ setMethod("getGenotypes", "LdData", function(x, ...) {
   if (is.null(x@genotypeHandle)) return(NULL)
   if (is.matrix(x@genotypeHandle)) return(x@genotypeHandle)
   if (is.list(x@genotypeHandle)) {
-    lapply(x@genotypeHandle, function(h) {
-      geno <- extractBlockGenotypes(h, x@snpIdx)
-      t(assay(geno, "dosage"))
-    })
+    lapply(x@genotypeHandle, function(h) .dosageMatrix(h, x@snpIdx))
   } else {
-    geno <- extractBlockGenotypes(x@genotypeHandle, x@snpIdx)
-    t(assay(geno, "dosage"))
+    .dosageMatrix(x@genotypeHandle, x@snpIdx)
   }
 })
 

R/MultiStudyQtlDataset.R

@@ -90,8 +90,8 @@ setClass("MultiStudyQtlDataset",
         shared <- intersect(names(a), names(b))
         for (tid in shared) {
           if (!isTRUE(all.equal(
-                as.character(GenomicRanges::seqnames(a[[tid]])),
-                as.character(GenomicRanges::seqnames(b[[tid]])))) ||
+                canonChrom(GenomicRanges::seqnames(a[[tid]])),
+                canonChrom(GenomicRanges::seqnames(b[[tid]])))) ||
               GenomicRanges::start(a[[tid]]) != GenomicRanges::start(b[[tid]]) ||
               GenomicRanges::end(a[[tid]]) != GenomicRanges::end(b[[tid]])) {
             errors <- c(errors, sprintf(

R/QtlDataset.R

@@ -78,8 +78,8 @@ setClass("QtlDataset",
             traitToRange[[tid]] <- this
           } else {
             if (!isTRUE(all.equal(
-                  as.character(GenomicRanges::seqnames(prev)),
-                  as.character(GenomicRanges::seqnames(this))
+                  canonChrom(GenomicRanges::seqnames(prev)),
+                  canonChrom(GenomicRanges::seqnames(this))
                 )) ||
                 GenomicRanges::start(prev) != GenomicRanges::start(this) ||
                 GenomicRanges::end(prev) != GenomicRanges::end(this)) {
@@ -267,10 +267,9 @@ setMethod("getScaleResiduals", "QtlDataset", function(x) x@scaleResiduals)
     return(seq_len(nrow(handle@snpInfo)))
   }
   snpInfo <- handle@snpInfo
-  siChr <- sub("^chr", "", as.character(snpInfo$CHR), ignore.case = TRUE)
+  siChr <- canonChrom(snpInfo$CHR)
   bp <- as.integer(snpInfo$BP)
-  rChr   <- sub("^chr", "", as.character(GenomicRanges::seqnames(region)),
-               ignore.case = TRUE)
+  rChr   <- canonChrom(GenomicRanges::seqnames(region))
   rStart <- GenomicRanges::start(region)
   rEnd   <- GenomicRanges::end(region)
   idx <- integer(0)
@@ -323,7 +322,11 @@ setMethod("getScaleResiduals", "QtlDataset", function(x) x@scaleResiduals)
   # extract dosage we will immediately drop.
   if (length(x@keepVariants) > 0L) {
     snpAll <- as.character(x@genotypes@snpInfo$SNP[snpIdx])
-    keepMask <- snpAll %in% x@keepVariants
+    # Match by (chrom, pos, allele) so user-supplied keepVariants reconcile with
+    # the genotype handle's ids across chr-prefix / separator differences.
+    km <- matchVariants(snpAll, as.character(x@keepVariants))
+    keepMask <- logical(length(snpAll))
+    keepMask[km$idxA] <- TRUE
     snpIdx <- snpIdx[keepMask]
     if (length(snpIdx) == 0L) {
       return(list(
@@ -358,10 +361,8 @@ setMethod("getScaleResiduals", "QtlDataset", function(x) x@scaleResiduals)
     }
   }
 
-  block <- extractBlockGenotypes(x@genotypes, snpIdx, meanImpute = FALSE)
-  # `block` is variants x samples (Bioc convention); transpose to
-  # samples x variants for analysis-style operations.
-  dosage <- t(SummarizedExperiment::assay(block, "dosage"))
+  # samples x variants dosage for analysis-style operations.
+  dosage <- .dosageMatrix(x@genotypes, snpIdx, meanImpute = FALSE)
 
   # Resolve the requested sample set: keepSamples (panel-level) intersected
   # with the per-call samples arg, then intersected with the panel sample IDs.

R/QtlFineMappingResult.R

@@ -156,14 +156,12 @@ setMethod("getPip", "QtlFineMappingResult",
     pip
   })
 
-#' @rdname getCs
-#' @export
-setMethod("getCs", "QtlFineMappingResult",
-  function(x, study = NULL, context = NULL, trait = NULL, method = NULL,
-           coverage = 0.95, ...) {
-    entry <- getFineMappingResult(x, study, context, trait, method)
-    getCs(entry, coverage = coverage)
-  })
+# Row selector for the base delegating accessors (getCs / getTopLoci /
+# getMarginalEffects / getSusieFit / getVariantIds now live on
+# FineMappingResultBase, AllClasses.R).
+setMethod(".fmrSelectEntry", "QtlFineMappingResult",
+  function(x, study = NULL, context = NULL, trait = NULL, method = NULL, ...)
+    getFineMappingResult(x, study, context, trait, method))
 
 #' @rdname getCvResult
 #' @export
@@ -173,43 +171,8 @@ setMethod("getCvResult", "QtlFineMappingResult",
     getCvResult(entry)
   })
 
-#' @rdname getTopLoci
-#' @export
-setMethod("getTopLoci", "QtlFineMappingResult",
-  function(x, type = c("data.frame", "GRanges"),
-           signalCutoff = 0.025,
-           study = NULL, context = NULL, trait = NULL, method = NULL,
-           ...) {
-    entry <- getFineMappingResult(x, study, context, trait, method)
-    getTopLoci(entry, type = match.arg(type), signalCutoff = signalCutoff)
-  })
-
-#' @rdname getMarginalEffects
-#' @export
-setMethod("getMarginalEffects", "QtlFineMappingResult",
-  function(x, maxPval = NULL,
-           study = NULL, context = NULL, trait = NULL, method = NULL, ...) {
-    entry <- getFineMappingResult(x, study, context, trait, method)
-    getMarginalEffects(entry, maxPval = maxPval)
-  })
-
-#' @rdname getSusieFit
-#' @export
-setMethod("getSusieFit", "QtlFineMappingResult",
-  function(x, study = NULL, context = NULL, trait = NULL, method = NULL,
-           ...) {
-    entry <- getFineMappingResult(x, study, context, trait, method)
-    getSusieFit(entry)
-  })
-
-#' @rdname getVariantIds
-#' @export
-setMethod("getVariantIds", "QtlFineMappingResult",
-  function(x, study = NULL, context = NULL, trait = NULL, method = NULL,
-           ...) {
-    entry <- getFineMappingResult(x, study, context, trait, method)
-    getVariantIds(entry)
-  })
+# getTopLoci / getMarginalEffects / getSusieFit / getVariantIds are defined once
+# on FineMappingResultBase (AllClasses.R), routing through .fmrSelectEntry.
 
 #' @rdname getContexts
 #' @export