add loader functions and update vignettes

.github/recipe/recipe.yaml

@@ -84,6 +84,7 @@ requirements:
     - r-vctrs
     - r-vroom
     - r-xgboost
+    - r-yaml
   run:
     - bioconductor-biocparallel
     - bioconductor-genomicranges
@@ -145,6 +146,7 @@ requirements:
     - r-vctrs
     - r-vroom
     - r-xgboost
+    - r-yaml
 
 tests:
   - script:

DESCRIPTION

@@ -39,7 +39,8 @@ Imports:
     tictoc,
     tidyr,
     vctrs,
-    vroom
+    vroom,
+    yaml
 Suggests:
     aSPU,
     arrow,
@@ -124,19 +125,20 @@ Collate:
     'jointEngine.R'
     'jointSpecification.R'
     'ld.R'
+    'sumstatsQc.R'
+    'variantId.R'
+    'qtlSumStats.R'
+    'manifestLoaders.R'
     'mashPipeline.R'
     'mashWrapper.R'
     'pvalCombine.R'
     'qtlEnrichmentPipeline.R'
-    'qtlSumStats.R'
     'regularizedRegressionWrappers.R'
     'relatednessQc.R'
     'sldscPostprocessingPipeline.R'
     'sldscWrapper.R'
-    'sumstatsQc.R'
     'twasWeights.R'
     'twasWeightsPipeline.R'
-    'variantId.R'
     'vcfWriter.R'
 Depends: 
     R (>= 3.5)

NAMESPACE

@@ -82,7 +82,6 @@ export(fitMashContrast)
 export(fitMvsusie)
 export(fitMvsusieRss)
 export(fitSusieInfThenSusieRss)
-export(fixupExampleGenotypePaths)
 export(formatFinemappingOutput)
 export(fsusieGetCs)
 export(fsusieWeights)
@@ -185,11 +184,15 @@ export(ldMismatchQc)
 export(ldPruneByCorrelation)
 export(learnTwasWeights)
 export(loadGenotypeRegion)
+export(loadGwasSumStatsFromManifest)
 export(loadLdMatrix)
 export(loadLdSketch)
+export(loadMultiStudyQtlDatasetFromManifest)
 export(loadMultitaskRegionalData)
 export(loadMultitraitRSumstat)
 export(loadMultitraitTensorqtlSumstat)
+export(loadQtlDatasetFromManifest)
+export(loadQtlSumStatsFromManifest)
 export(loadRegionalAssociationData)
 export(loadRegionalFunctionalData)
 export(loadRegionalMultivariateData)

R/GenotypeHandle.R

@@ -424,6 +424,34 @@ setMethod("getFormat", "GenotypeHandle", function(x) x@format)
 #' @export
 setMethod("getPath", "GenotypeHandle", function(x) x@path)
 
+# Resolve a portable bundled-resource reference of the form
+# "pecotmr://extdata/<stem>" to a concrete filesystem path via
+# `system.file()`; any ordinary path is returned unchanged. This lets the
+# packaged example objects (which cannot bake an install-specific absolute
+# path into their serialized GenotypeHandle) carry a portable reference that
+# resolves at extraction time, on whatever machine the package is installed.
+.resolveGenotypeResourcePath <- function(path) {
+  if (length(path) != 1L || is.na(path)) return(path)
+  m <- regmatches(path, regexec("^pecotmr://extdata/(.+)$", path))[[1L]]
+  if (length(m) != 2L) return(path)
+  stem <- m[[2L]]
+  bed <- system.file("extdata", paste0(stem, ".bed"), package = "pecotmr")
+  if (nzchar(bed)) return(sub("\\.bed$", "", bed))
+  resolved <- system.file("extdata", stem, package = "pecotmr")
+  if (!nzchar(resolved))
+    stop("cannot resolve bundled genotype resource '", stem,
+         "' under inst/extdata/ (package 'pecotmr').")
+  resolved
+}
+
+# The concrete filesystem path/stem to open for a handle's data. Resolves a
+# bundled-resource reference; ordinary paths pass through. Used by the block
+# extractors and LD-panel keying, so `getPath()` keeps returning the stored
+# (portable) value for display/provenance while file access resolves it.
+.genotypeReadPath <- function(handle) {
+  .resolveGenotypeResourcePath(getPath(handle))
+}
+
 #' @rdname getSampleIds
 #' @export
 setMethod("getSampleIds", "GenotypeHandle", function(x) x@sampleIds)

R/ctwasPipeline.R

@@ -1242,7 +1242,7 @@ mergeCtwasBoundaryRegions <- function(finemapResult,
 # @noRd
 .ctwasLdPanelKey <- function(handle) {
   fmt <- getFormat(handle)
-  stem <- getPath(handle)
+  stem <- .genotypeReadPath(handle)
   candidates <- switch(fmt,
     "plink2" = c(paste0(stem, ".pgen")),
     "plink1" = c(paste0(stem, ".bed")),

R/exampleData.R

@@ -288,59 +288,6 @@ NULL
 NULL
 
 
-#' @title Resolve bundled-example GenotypeHandle paths
-#'
-#' @description The bundled S4 example objects (\code{qtl_dataset_example},
-#' \code{qtl_sumstats_example}, \code{qtl_sumstats_multicontext_example},
-#' \code{gwas_sumstats_s4_example}, \code{multi_study_qtl_dataset_example})
-#' store a relative-style path to the bundled
-#' \code{inst/extdata/toy_canonical} PLINK1 reference.
-#' Call this helper once at the top of a vignette to re-point each
-#' contained \code{GenotypeHandle} at the installed path resolved via
-#' \code{system.file()}.
-#'
-#' @param x A bundled \code{QtlDataset}, \code{MultiStudyQtlDataset},
-#'   \code{QtlSumStats}, or \code{GwasSumStats} example object.
-#' @return The same object with \code{GenotypeHandle@@path} rewritten
-#'   to the resolved install path.
-#' @export
-fixupExampleGenotypePaths <- function(x) {
-  resolve <- function(handle) {
-    bn <- basename(handle@path)
-    # PLINK1 / PLINK2 are stems (no extension); resolve via the .bed
-    # (or .pgen) sidecar and strip the extension back off.
-    bedPath <- system.file("extdata", paste0(bn, ".bed"),
-                            package = "pecotmr")
-    if (nzchar(bedPath)) {
-      handle@path <- sub("\\.bed$", "", bedPath)
-      return(handle)
-    }
-    new <- system.file("extdata", bn, package = "pecotmr")
-    if (!nzchar(new))
-      stop("fixupExampleGenotypePaths: cannot resolve '", bn,
-           "' under inst/extdata/")
-    handle@path <- new
-    handle
-  }
-  if (methods::is(x, "QtlDataset")) {
-    x@genotypes <- resolve(x@genotypes)
-  } else if (methods::is(x, "MultiStudyQtlDataset")) {
-    for (nm in names(x@qtlDatasets))
-      x@qtlDatasets[[nm]]@genotypes <-
-        resolve(x@qtlDatasets[[nm]]@genotypes)
-    if (!is.null(x@sumStats))
-      x@sumStats@ldSketch <- resolve(x@sumStats@ldSketch)
-  } else if (methods::is(x, "QtlSumStats") ||
-             methods::is(x, "GwasSumStats")) {
-    x@ldSketch <- resolve(x@ldSketch)
-  } else {
-    stop("fixupExampleGenotypePaths: unsupported class '",
-         class(x)[[1L]], "'.")
-  }
-  x
-}
-
-
 #' @name multi_study_qtl_dataset_example
 #'
 #' @title Example MultiStudyQtlDataset (S4)

R/genotypeIo.R

@@ -323,7 +323,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) {
 
 #' @keywords internal
 .extractBlockGds <- function(handle, snpIdx) {
-  .withGds(getPath(handle), allow.fork = TRUE, fn = function(gds) {
+  .withGds(.genotypeReadPath(handle), allow.fork = TRUE, fn = function(gds) {
     snpIds <- getSnpInfo(handle)$SNP[snpIdx]
     # Use snpgdsGetGeno for proper non-contiguous SNP selection
     geno <- SNPRelate::snpgdsGetGeno(gds, snp.id = snpIds,
@@ -345,7 +345,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) {
   )
   param <- VariantAnnotation::ScanVcfParam(which = gr, fixed = NA,
                                             info = NA, geno = "GT")
-  vcf <- VariantAnnotation::readVcf(getPath(handle), genome = "", param = param)
+  vcf <- VariantAnnotation::readVcf(.genotypeReadPath(handle), genome = "", param = param)
   gt <- VariantAnnotation::geno(vcf)$GT
 
   # Convert GT strings to ALT dosage (A1 dosage)
@@ -365,7 +365,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) {
 #' @keywords internal
 .extractBlockPlink1 <- function(handle, snpIdx) {
   snpIds <- getSnpInfo(handle)$SNP[snpIdx]
-  pathStem <- getPath(handle)
+  pathStem <- .genotypeReadPath(handle)
   plinkData <- snpStats::read.plink(
     bed = paste0(pathStem, ".bed"),
     bim = paste0(pathStem, ".bim"),
@@ -386,7 +386,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) {
   # become stale), so we re-open from getPath() on the fly if the cached
   # pointer errors out. Opening is cheap relative to dosage extraction.
   ptr <- getPgenPtr(handle)
-  paths <- resolvePlink2Paths(getPath(handle))
+  paths <- resolvePlink2Paths(.genotypeReadPath(handle))
   # A sharded handle routes through a transient view with pgenPtr = NULL (one
   # pgen per chromosome), and a deserialized pointer is stale; open a fresh
   # pgen up front in those cases rather than provoking a caught read error.
@@ -461,7 +461,7 @@ computeBlockLdCor <- function(handle, snpIdx, backend = "internal",
 
 #' @keywords internal
 .computeBlockLdGds <- function(handle, snpIdx) {
-  .withGds(getPath(handle), allow.fork = TRUE, fn = function(gds) {
+  .withGds(.genotypeReadPath(handle), allow.fork = TRUE, fn = function(gds) {
     snpIds <- getSnpInfo(handle)$SNP[snpIdx]
     ldMat <- SNPRelate::snpgdsLDMat(
       gds, snp.id = snpIds, method = "corr",
@@ -1052,7 +1052,7 @@ loadGenotypeRegion <- function(genotype, region = NULL, keepIndel = TRUE,
 
   # --- Attach allele frequency from .afreq sidecar (plink2 only) ---
   if (getFormat(handle) == "plink2") {
-    afreq <- readAfreq(getPath(handle))
+    afreq <- readAfreq(.genotypeReadPath(handle))
     if (!is.null(afreq)) {
       afreqCols <- intersect(c("id", "alt_freq", "obs_ct"), colnames(afreq))
       variantInfo <- merge(variantInfo, afreq[, afreqCols, drop = FALSE],