diff --git a/.github/recipe/recipe.yaml b/.github/recipe/recipe.yaml index 99b9fa5f6..bc8891b77 100644 --- a/.github/recipe/recipe.yaml +++ b/.github/recipe/recipe.yaml @@ -24,17 +24,21 @@ requirements: - ${{ compiler('cxx') }} host: - bioconductor-biocparallel + - bioconductor-biocsingular + - bioconductor-gdsarray - bioconductor-genomicranges - bioconductor-iranges - bioconductor-qvalue - bioconductor-s4vectors - bioconductor-snprelate - bioconductor-snpstats - - bioconductor-mungesumstats - bioconductor-multiassayexperiment + - bioconductor-plinkmatrix - bioconductor-rsamtools - bioconductor-rtracklayer + - bioconductor-seqarray - bioconductor-summarizedexperiment + - bioconductor-variantannotation - r-archive - r-arrow - r-aspu @@ -49,6 +53,7 @@ requirements: - r-cpp11 - r-cpp11armadillo - r-ctwas + - r-dbi - r-dplyr - r-flashier - r-fsusier @@ -79,6 +84,7 @@ requirements: - r-rfast - r-rlang - r-robustbase + - r-rsqlite - r-softimpute - r-stringr - r-susier @@ -92,6 +98,8 @@ requirements: - r-yaml run: - bioconductor-biocparallel + - bioconductor-biocsingular + - bioconductor-gdsarray - bioconductor-genomicranges - bioconductor-iranges - bioconductor-qvalue @@ -99,10 +107,12 @@ requirements: - bioconductor-snprelate - bioconductor-snpstats - bioconductor-multiassayexperiment - - bioconductor-mungesumstats + - bioconductor-plinkmatrix - bioconductor-rsamtools - bioconductor-rtracklayer + - bioconductor-seqarray - bioconductor-summarizedexperiment + - bioconductor-variantannotation - r-archive - r-arrow - r-aspu @@ -117,6 +127,7 @@ requirements: - r-cpp11 - r-cpp11armadillo - r-ctwas + - r-dbi - r-dplyr - r-flashier - r-fsusier @@ -147,6 +158,7 @@ requirements: - r-rfast - r-rlang - r-robustbase + - r-rsqlite - r-softimpute - r-stringr - r-susier diff --git a/DESCRIPTION b/DESCRIPTION index c5494b181..fae439ffa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -72,22 +72,26 @@ Suggests: coda, CorShrink, ctwas, + DBI, ebnm, flashier, fsusieR, GBJ, + GDSArray, gdsfmt, glmnet, harmonicmeanp, igraph, knitr, L0Learn, + logging, mashr, mr.mashr, mvsusieR, ncvreg, nnls, pgenlibr, + PlinkMatrix, plinkQC, plyranges, poolr, @@ -97,7 +101,9 @@ Suggests: Rfast, rmarkdown, robustbase, + RSQLite, rtracklayer, + SeqArray, SNPRelate, snpStats, testthat, @@ -119,6 +125,8 @@ VignetteBuilder: knitr Config/roxygen2/version: 8.1.0 Collate: 'AllGenerics.R' + 'GenotypeMixture.R' + 'LdMatrix.R' 'RangedTupleList.R' 'GenotypeHandle.R' 'AllClasses.R' @@ -128,24 +136,24 @@ Collate: 'tupleSelectors.R' 'CtwasResult.R' 'CtwasResultEntry.R' + 'GenotypeDosageSeed.R' 'GwasFineMappingResult.R' + 'MethodOptions.R' + 'MethodParam.R' 'H2Estimate.R' 'JointGroup.R' 'LdBlocks.R' - 'LdData.R' 'LdStatistic.R' 'LdEigen.R' 'LdScore.R' 'MashPrior.R' - 'MethodOptions.R' - 'MethodParam.R' + 'qtlSumStats.R' 'QtlDataset.R' 'MultiStudyQtlDataset.R' 'QtlFineMappingResult.R' 'SldscData.R' 'causalInferencePipeline.R' 'gwasSumStats.R' - 'qtlSumStats.R' 'fineMappingPipeline.R' 'ld.R' 'colocPipeline.R' diff --git a/NAMESPACE b/NAMESPACE index 57b01701e..ba225bc37 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -67,6 +67,7 @@ export(FsusieOptions) export(GbjOmniOptions) export(GbjOptions) export(GenotypeFilterParam) +export(GenotypeMixture) export(GlmnetOptions) export(GwasFineMappingParam) export(GwasFineMappingResult) @@ -74,8 +75,8 @@ export(GwasSumStats) export(KrigingOptions) export(L0learnOptions) export(LassosumOptions) -export(LdData) export(LdEigen) +export(LdMatrix) export(LdPruningOptions) export(LdScore) export(MashComponentParam) @@ -155,7 +156,6 @@ export(bayesLWeights) export(bayesNWeights) export(bayesRWeights) export(blockId) -export(blockMetadata) export(buildLdEigen) export(buildLdScore) export(buildMrmashPriorMatrices) @@ -245,7 +245,6 @@ export(genotypeCovariates) export(genotypes) export(glmnetWeights) export(h2EstimateToSldscTrait) -export(hasGenotypes) export(heritabilityEstimate) export(heritabilityEstimateSe) export(heritabilityIntercept) @@ -263,7 +262,6 @@ export(krigingOutlierQc) export(l0learnRssWeights) export(l0learnWeights) export(lassoWeights) -export(lassosumRss) export(lassosumRssWeights) export(lbf) export(lbfToAlpha) @@ -274,11 +272,10 @@ export(ldMatrixList) export(ldMismatchQc) export(ldPanelNSamples) export(ldPruneByCorrelation) -export(ldSketch) +export(ldReference) export(learnTwasWeights) export(loadGenotypeRegion) export(loadGwasSumStatsFromManifest) -export(loadLdMatrix) export(loadMultiStudyQtlDatasetFromManifest) export(loadQtlDatasetFromManifest) export(loadQtlSumStatsFromManifest) @@ -329,12 +326,10 @@ export(overlapTopLoci) export(panelFilterParam) export(parseRegion) export(parseVariantId) -export(penalizedRss) export(perCsColumns) export(phenotypeCovariates) export(pip) export(postprocessFinemappingFits) -export(prsCs) export(prsCsWeights) export(pval) export(qcDiagnostics) @@ -354,7 +349,6 @@ export(readSldscAnnot) export(readSldscFrq) export(readSldscTrait) export(readTwasWeights) -export(refPanel) export(refVariantInfo) export(regionToDf) export(regionVcp) @@ -369,7 +363,6 @@ export(scaleResiduals) export(scoreFromCs) export(scoreStats) export(screenCtwasRegions) -export(sdpr) export(sdprWeights) export(se) export(secondaryCoverage) @@ -381,7 +374,6 @@ export(sldscPostprocessingPipeline) export(sldscResults) export(sldscSubsetMeta) export(sliceMashData) -export(snpIdx) export(standardizeSldscTrait) export(stratifiedHeritabilityEnrichment) export(studyName) @@ -412,7 +404,6 @@ export(twasZ) export(updateMashModelCov) export(varY) export(variantIds) -export(variantInfo) export(waldTestPval) export(weightStandardized) export(weightsDataType) @@ -436,12 +427,13 @@ exportClasses(FineMappingMethodsParam) exportClasses(FineMappingResultBase) exportClasses(FineMappingRow) exportClasses(GenotypeFilterParam) +exportClasses(GenotypeMixture) exportClasses(GwasFineMappingParam) exportClasses(GwasFineMappingResult) exportClasses(GwasSumStats) exportClasses(H2Estimate) -exportClasses(LdData) exportClasses(LdEigen) +exportClasses(LdMatrix) exportClasses(LdScore) exportClasses(LdStatistic) exportClasses(MashComponentParam) @@ -493,7 +485,6 @@ exportMethods(as.list) exportMethods(baselineAnnotations) exportMethods(bindROWS) exportMethods(blockId) -exportMethods(blockMetadata) exportMethods(coef) exportMethods(colnames) exportMethods(colocBoostOutcomes) @@ -526,7 +517,6 @@ exportMethods(fullFit) exportMethods(genomicRegion) exportMethods(genotypeCovariates) exportMethods(genotypes) -exportMethods(hasGenotypes) exportMethods(heritabilityEstimate) exportMethods(heritabilityEstimateSe) exportMethods(heritabilityIntercept) @@ -541,7 +531,7 @@ exportMethods(ldBlocks) exportMethods(ldMatrix) exportMethods(ldMatrixList) exportMethods(ldPanelNSamples) -exportMethods(ldSketch) +exportMethods(ldReference) exportMethods(length) exportMethods(localH2Blocks) exportMethods(longForm) @@ -568,7 +558,6 @@ exportMethods(qtlAssociationPostprocess) exportMethods(qtlDatasets) exportMethods(readAnnotations) exportMethods(readGenotypes) -exportMethods(refPanel) exportMethods(regionVcp) exportMethods(residualizedGenotypes) exportMethods(residualizedPhenotypes) @@ -580,7 +569,6 @@ exportMethods(se) exportMethods(show) exportMethods(significantQtls) exportMethods(sldscResults) -exportMethods(snpIdx) exportMethods(stratifiedHeritabilityEnrichment) exportMethods(studyName) exportMethods(subsetChr) @@ -596,7 +584,6 @@ exportMethods(twasWeights) exportMethods(twasWeightsPipeline) exportMethods(varY) exportMethods(variantIds) -exportMethods(variantInfo) exportMethods(weightStandardized) exportMethods(weights) exportMethods(weightsDataType) @@ -605,7 +592,9 @@ exportMethods(z) importClassesFrom(GenomicRanges,GRanges) importClassesFrom(MultiAssayExperiment,MultiAssayExperiment) importClassesFrom(S4Vectors,DataFrame) +importClassesFrom(S4Vectors,List) importClassesFrom(S4Vectors,SimpleList) +importClassesFrom(S4Vectors,Vector) importClassesFrom(S4Vectors,character_OR_NULL) importClassesFrom(SummarizedExperiment,RangedSummarizedExperiment) importFrom(BiocGenerics, @@ -613,12 +602,12 @@ importFrom(BiocGenerics, ncol, nrow, path, - weights + weights, + width ) importFrom(BiocParallel, MulticoreParam, bplapply, - bpparam, multicoreWorkers ) importFrom(Biostrings, @@ -635,10 +624,18 @@ importFrom(IRanges, CharacterList, DataFrameList, IRanges, - findOverlaps + findOverlaps, + overlapsAny ) importFrom(MASS,ginv) -importFrom(MultiAssayExperiment,longForm) +importFrom(MultiAssayExperiment, + ExperimentList, + MultiAssayExperiment, + experiments, + longForm, + subsetByAssay, + subsetByRow +) importFrom(Rsamtools, TabixFile, asBcf, @@ -656,8 +653,10 @@ importFrom(S4Vectors, SimpleList, bindROWS, endoapply, + extractROWS, mcols, metadata, + normalizeSingleBracketSubscript, queryHits, subjectHits ) @@ -696,7 +695,6 @@ importFrom(checkmate, checkList, checkMatrix, checkNames, - checkNull, checkNumeric, checkString, checkSubset, @@ -761,6 +759,7 @@ importFrom(purrr, list_rbind, map, map2, + map2_dbl, map2_lgl, map_chr, map_dbl, @@ -768,6 +767,7 @@ importFrom(purrr, map_int, map_lgl, partial, + pmap, possibly, reduce, set_names, @@ -788,19 +788,20 @@ importFrom(rlang, abort, arg_match, arg_match0, + caller_arg, cnd_signal, + eval_bare, + fn_env, + fn_fmls, inform, is_named, try_fetch, warn ) importFrom(stats, - as.dist, coef, complete.cases, cor, - cutree, - hclust, lm, lm.fit, median, @@ -861,15 +862,10 @@ importFrom(tidyr, separate ) importFrom(tidyselect,all_of) -importFrom(tools, - file_ext, - file_path_sans_ext -) +importFrom(tools,file_ext) importFrom(utils, combn, - head, - read.table, - tail + head ) importFrom(vctrs,vec_duplicate_detect) importFrom(vroom,vroom) diff --git a/R/AllClasses.R b/R/AllClasses.R index 153bd0f0f..044f16a68 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -11,71 +11,40 @@ # topologically orders the Collate field for us. # ============================================================================= -#' @include AllGenerics.R GenotypeHandle.R RangedTupleList.R +#' @include AllGenerics.R GenotypeHandle.R RangedTupleList.R LdMatrix.R +#' @include GenotypeMixture.R #' @importFrom methods setClass setMethod new is validObject +#' @importClassesFrom GenomicRanges GRanges +#' @importClassesFrom S4Vectors DataFrame NULL -# The LD reference panel a collection was harmonized against, as the same -# RangedSummarizedExperiment shape QtlDataset uses for its genotypes: variants -# in rowRanges, dosages in a DelayedArray assay that reads lazily through a -# GenotypeHandle. NULL when a collection carries no panel. -# -# A union rather than "ANY": the slot has always been documented as holding a -# panel, and an untyped slot with a typed docstring is the kind of thing that -# is only true until someone puts something else in it. -#' @importClassesFrom SummarizedExperiment RangedSummarizedExperiment -setClassUnion( - "LdSketch_OR_NULL", - c("RangedSummarizedExperiment", "NULL") -) - -# What an LdData can read genotypes from. Four shapes, all real: +# The LD reference a collection was harmonized against -- the one place every +# pipeline reads LD from. It is one of two things: # -# GenotypeHandle a lazy file-backed panel; `snpIdx` selects into its whole -# snpInfo, so the handle must not be pre-narrowed -# list one handle per panel for a mixture reference, averaged by -# `mixtureWeights` -# matrix dosages already extracted and filtered, kept so -# genotypes() answers without reopening the file (see -# .loadLdFromBlocks); `snpIdx` is NULL in this case because -# the matrix is already the subset -# NULL no genotypes -- the object carries a pre-computed R +# RangedSummarizedExperiment a genotype panel, the same shape QtlDataset +# uses for its genotypes: variants in rowRanges, +# dosages in a DelayedArray assay that reads +# lazily through a GenotypeHandle +# GenotypeMixture several such panels, their LD averaged +# LdMatrix a correlation matrix the caller built # -# A panel (RangedSummarizedExperiment) is what callers pass; the constructor -# unwraps it to its handle, so the slot itself never holds one. +# NULL when a collection carries no LD reference. # -# A union rather than "ANY", for the same reason as above: the slot's -# docstring named two of these four shapes and nothing enforced even that. +# A union rather than "ANY": the slot has always been documented as holding +# one of these, and an untyped slot with a typed docstring is the kind of +# thing that is only true until someone puts something else in it. +#' @importClassesFrom SummarizedExperiment RangedSummarizedExperiment setClassUnion( - "LdGenotypeSource", - c("GenotypeHandle", "matrix", "list", "NULL") + "LdReference_OR_NULL", + c("RangedSummarizedExperiment", "GenotypeMixture", "LdMatrix", "NULL") ) -# The rest of LdData's payload, typed for the same reason. Each union is the -# set of shapes the class is actually built with, confirmed by recording slot -# classes at validity across the LD test files (validity runs for every -# object, however it was constructed). -# -# `correlation` is a single matrix, or one matrix per block for -# block-diagonal LD, or NULL when it has to be computed from genotypes. -setClassUnion("LdCorrelation", c("matrix", "list", "NULL")) - -# `snpIdx` selects into the genotype source's snpInfo; NULL when the -# correlation is pre-computed, or when the source is already the subset. The -# constructor coerces to integer, so a caller may pass doubles. -setClassUnion("LdSnpIndex", c("integer", "NULL")) - -# Mixing proportions, one per panel, when `genotypeHandle` is a list. -#' @importClassesFrom GenomicRanges GRanges -#' @importClassesFrom S4Vectors DataFrame -setClassUnion("LdMixtureWeights", c("numeric", "NULL")) - # ============================================================================= # SumStatsBase # ----------------------------------------------------------------------------- # Shared parent of the QTL and GWAS summary statistics collections. # Concrete subclasses (QtlSumStats, GwasSumStats) inherit from -# RangedTupleList and share the ldSketch / qcInfo slots (the genome build +# RangedTupleList and share the ldReference / qcInfo slots (the genome build # lives in seqinfo, not a slot). Each element # is one tuple's per-variant GRanges: x[[i]], formerly x$entry[[i]]. # @@ -89,17 +58,20 @@ setClassUnion("LdMixtureWeights", c("numeric", "NULL")) #' @description Virtual base class for QTL and GWAS summary statistics #' collections. Concrete subclasses (\code{QtlSumStats}, \code{GwasSumStats}) #' inherit from \code{\linkS4class{RangedTupleList}} and share the -#' \code{ldSketch} / \code{qcInfo} slots, and the genome build in +#' \code{ldReference} / \code{qcInfo} slots, and the genome build in #' \code{seqinfo()}. #' #' Each element is the per-variant \code{GRanges} of one tuple, so #' \code{x[[i]]} is that tuple's summary statistics and the identity columns #' live in \code{mcols(x)}. There is no \code{entry} column: what used to be #' \code{x$entry[[i]]} is now simply \code{x[[i]]}. -#' @slot ldSketch The \code{GenotypeHandle} the QC pipeline harmonized against, -#' or \code{NULL}. Optional: LD-free workflows (e.g. mash, which operates -#' across conditions per variant) carry \code{NULL}; pipelines that need LD -#' validate its presence when they consume the collection. +#' @slot ldReference The LD reference the collection was harmonized against +#' and every pipeline reads LD from: a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +#' \code{\link{LdMatrix}}, or \code{NULL}. Optional: LD-free workflows +#' (e.g. mash, which operates across conditions per variant) carry +#' \code{NULL}; pipelines that need LD validate its presence when they +#' consume the collection. #' @slot qcInfo A \code{list} recording which QC steps ran. Empty \code{list()} #' on construction; populated by \code{summaryStatsQc()} with a per-step audit #' record (filter names, drop counts, liftover target, RAISS settings, etc.). @@ -111,7 +83,7 @@ setClass( "SumStatsBase", contains = c("VIRTUAL", "RangedTupleList"), representation( - ldSketch = "LdSketch_OR_NULL", + ldReference = "LdReference_OR_NULL", qcInfo = "list" ) ) @@ -164,8 +136,10 @@ setClass( return(gr) } win <- .asGRegion(ranges) - onWindowChrom <- as.character(seqnames(gr)) %in% + onWindowChrom <- is_in( + as.character(seqnames(gr)), as.character(seqnames(win)) + ) if (!any(onWindowChrom)) { return(gr[0L]) } @@ -246,12 +220,12 @@ setMethod("qcDiagnostics", "SumStatsBase", function(x, entry = 1L) { } }) -#' @rdname ldSketch +#' @rdname ldReference #' @examples #' data(qtlSumStatsExample) -#' ldSketch(qtlSumStatsExample) +#' ldReference(qtlSumStatsExample) #' @export -setMethod("ldSketch", "SumStatsBase", function(x) x@ldSketch) +setMethod("ldReference", "SumStatsBase", function(x) x@ldReference) #' @rdname studyName #' @examples @@ -729,7 +703,7 @@ setMethod( # ----------------------------------------------------------------------------- # Shared parent of the QTL and GWAS fine-mapping result collections. # Concrete subclasses (QtlFineMappingResult, GwasFineMappingResult) carry -# a DFrame of per-fit rows plus a shared ldSketch slot. Downstream +# a DFrame of per-fit rows plus a shared ldReference slot. Downstream # pipelines dispatch on FineMappingResultBase for behaviors that apply to # either flavour, and on the concrete subclass when the tuple shape # matters. @@ -738,19 +712,20 @@ setMethod( #' @title Fine-Mapping Result Base Class #' @description Virtual base class for fine-mapping result collections. Concrete #' subclasses (\code{QtlFineMappingResult}, \code{GwasFineMappingResult}) -#' carry a \code{DFrame} of per-fit rows and a shared \code{ldSketch} slot. +#' carry a \code{DFrame} of per-fit rows and a shared \code{ldReference} slot. #' Downstream pipelines should dispatch on \code{FineMappingResultBase} for #' behaviors that apply to either flavour, and on the concrete subclass when #' the tuple shape matters. -#' @slot ldSketch The LD reference \code{GenotypeHandle} the fits were computed -#' against, or \code{NULL} when the fits were derived from individual-level -#' data (no LD reference). Used downstream for cross-pipeline LD-sketch -#' identity validation. +#' @slot ldReference The LD reference the fits were computed against (a +#' genotype panel, a \code{GenotypeMixture} or an \code{LdMatrix}), or +#' \code{NULL} when the fits were derived from individual-level data. Used +#' downstream to check that pipelines combining results share one LD +#' reference. #' @export setClass( "FineMappingResultBase", contains = c("VIRTUAL", "RangedTupleList"), - representation(ldSketch = "LdSketch_OR_NULL") + representation(ldReference = "LdReference_OR_NULL") ) #' @rdname studyName @@ -759,9 +734,9 @@ setMethod("studyName", "FineMappingResultBase", function(x) { unique(as.character(x$study)) }) -#' @rdname ldSketch +#' @rdname ldReference #' @export -setMethod("ldSketch", "FineMappingResultBase", function(x) x@ldSketch) +setMethod("ldReference", "FineMappingResultBase", function(x) x@ldReference) #' @rdname methodNames #' @examples @@ -846,7 +821,7 @@ setMethod( GenomicRanges::GRangesList(map(entries, variants)), value = .withEntryPayload(mcols(x, use.names = FALSE), entries) ) - new(class(x), grl, ldSketch = .asLdSketch(ldSketch(x))) + new(class(x), grl, ldReference = .asLdRef(ldReference(x))) } # TRUE when an entry shares at least one variant with `keepVariants`, matched diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 6721f9499..deb1db412 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -73,7 +73,7 @@ NULL #' ) #' ss <- GwasSumStats(studyName = "trait1", entry = list(gr), #' genome = unique(unname(GenomeInfoDb::genome(ldScoreExample))), -#' ldSketch = panel) +#' ldReference = panel) #' estimateH2(ss, ldScoreExample, method = "sldsc") #' @export setGeneric( @@ -96,7 +96,9 @@ setGeneric( #' @title Compute LD Scores #' @description Compute LD scores from an LD reference, optionally stratified by -#' annotations. +#' annotations. Each r-squared is ldsc's small-sample unbiased estimate, +#' \eqn{r^2 - (1 - r^2)/(n - 2)} for a reference of \eqn{n} samples, as +#' \code{\link{buildLdScore}} stores, so the two agree. #' @param ldRef An \code{LdStatistic} object. #' @param annotations An \code{AnnotationMatrix} object, or NULL. #' @param ... Additional arguments. @@ -114,14 +116,14 @@ setGeneric("computeLdScores", function(ldRef, annotations = NULL, ...) { # ============================================================================= #' @title Read a Genotype Panel -#' @description Read genotype data (VCF, plink1, plink2 or GDS) as a +#' @description Read genotype data (VCF, plink1, plink2, GDS or BGEN) as a #' \code{RangedSummarizedExperiment}: variants in \code{rowRanges}, #' samples in \code{colData}, and dosages in a \code{DelayedArray} assay #' that reads from the file only when something touches it. Nothing is read #' here beyond the variant and sample metadata. #' #' The panel is the same shape a \code{QtlDataset} uses for its genotypes -#' and the same shape a collection carries as its \code{ldSketch}, so the +#' and the same shape a collection carries as its \code{ldReference}, so the #' Bioconductor and tidy surfaces apply throughout: subset it with #' \code{panel[i, j]}, ask \code{rowRanges()} for the variants, #' \code{colnames()} for the samples, and hand it to @@ -135,11 +137,35 @@ setGeneric("computeLdScores", function(ldRef, annotations = NULL, ...) { #' with \code{chroms}), or \code{ldMeta} plus \code{region} to resolve a #' block out of an LD-meta table. Exactly one source may be given. #' @param path Character, path to a single self-describing genotype file -#' (\code{.vcf}, \code{.vcf.gz}, \code{.vcf.bgz}, \code{.bcf} or -#' \code{.gds}). Omit it when naming the panel by one of the keyword -#' sources described above. -#' @param format Character, one of "vcf", "plink1", "plink2", "gds". If NULL, -#' inferred from file extension. +#' (\code{.vcf.gz}, \code{.vcf.bgz}, \code{.gds} or \code{.bgen}). Omit it +#' when naming the panel by one of the keyword sources described above. +#' +#' A VCF must be bgzip-compressed with its tabix index (\code{.tbi}) beside +#' it, through which its records are read a block at a time; a BCF cannot +#' be read. Its dosage is its FORMAT/DS when the header declares one, else +#' the copies of the ALT allele in each GT call, a call with a missing +#' allele being missing. +#' +#' A GDS file is SNPRelate's, whose genotype codes count the first of each +#' SNP's two alleles (A1), or SeqArray's, read like a VCF: its FORMAT/DS +#' when it stores one, else its genotype calls. +#' +#' A BGEN file of any layout (BGEN 1.1, 1.2 or 1.3), phased or unphased +#' and of any ploidy, needs its \code{.bgi} index beside it and its sample +#' ids in the file or in a \code{.sample} file beside it. Its dosage is the +#' expected count of A1, from 0 to the sample's ploidy. +#' +#' A PLINK1 fileset, a \code{.bed} with its \code{.bim} and \code{.fam} +#' beside it, is read through the PlinkMatrix package: its dosage counts +#' each variant's A1 allele, the \code{.bim}'s fifth column, a missing +#' call being missing. Its samples are named by the \code{.fam}'s +#' individual ids. +#' +#' In a VCF, a SeqArray GDS or a BGEN file, A2 is each record's first (REF) +#' allele, and a record with more than one other allele is read, with a +#' warning, as one variant per other allele, each counting its own. +#' @param format Character, one of "vcf", "plink1", "plink2", "gds", "bgen". +#' If NULL, inferred from file extension. #' @param ... The keyword source arguments described above, plus any further #' arguments forwarded to the format-specific reader. #' @param plink1Prefix,plink2Prefix Character. Stem of a plink1 @@ -151,7 +177,8 @@ setGeneric("computeLdScores", function(ldRef, annotations = NULL, ...) { #' plink2 triplet, when they do not share a stem. #' @param genoMeta One-file-per-chromosome specification: a path to a #' \code{#chr,path} meta file, or a named character vector (names = -#' chromosomes, values = payload paths / prefixes). +#' chromosomes, values = payload paths / prefixes). Every file must be of +#' one format and hold the same samples in the same order. #' @param chroms Optional character vector of chromosomes. Only the #' \code{genoMeta} shards whose chromosome is listed are read; chromosome #' labels are compared canonically. Meaningful only with \code{genoMeta}. @@ -162,7 +189,8 @@ setGeneric("computeLdScores", function(ldRef, annotations = NULL, ...) { #' \code{"chr:start-end"} string, or a one-row data.frame with #' \code{chrom}, \code{start}, \code{end}. #' @param vcfArgs Optional named list of arguments forwarded to -#' \code{VariantAnnotation::readVcf} when the source is a VCF. +#' \code{VariantAnnotation::readVcf} when a VCF's records are read (its +#' genotypes are read a block at a time, as they are needed). #' @return A \code{RangedSummarizedExperiment} of variants x samples. #' @seealso \code{\link{computeLd}} #' @examples @@ -272,8 +300,9 @@ setGeneric("z", function(x, ...) standardGeneric("z")) #' @title Get Sample Sizes #' @description Extract sample sizes: the per-variant sample-size vector of a #' \code{GwasSumStats} or \code{QtlSumStats} entry, selected by its identity -#' tuple, or the number of samples carried by a \code{GenotypeHandle}. -#' @param x A \code{GwasSumStats}, \code{QtlSumStats} or +#' tuple, the number of samples carried by a \code{GenotypeHandle}, or the +#' panel size an \code{\link{LdMatrix}} records. +#' @param x A \code{GwasSumStats}, \code{QtlSumStats}, \code{LdMatrix} or #' \code{GenotypeHandle} object. #' @param ... Class-specific selection arguments. #' @param studyName Character (length 1) or \code{NULL}. Restrict the selection @@ -287,7 +316,8 @@ setGeneric("z", function(x, ...) standardGeneric("z")) #' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the #' variants overlapping these ranges; \code{NULL} returns everything. #' @return Numeric vector of sample sizes for a summary-statistic entry; -#' integer of length 1 for a \code{GenotypeHandle}. +#' integer of length 1 for a \code{GenotypeHandle} or an \code{LdMatrix} +#' (\code{NA} when the matrix records no size). #' @details The genotype handle is the seed layer behind a panel and is not #' part of the public interface; obtain a panel from #' \code{readGenotypes()} and ask it directly. @@ -435,16 +465,17 @@ setGeneric("nSamples<-", function(x, ..., value) { #' @title Get Effect-Allele Frequencies #' @description Extract the directional effect-allele (A1) frequency vector -#' for a \code{QtlDataset}, or for one entry of a \code{GwasSumStats} / -#' \code{QtlSumStats} collection. Unlike \code{\link{maf}}, the value is -#' \emph{not} folded to the minor allele: it is the frequency of the -#' dosage-counted allele (A1, the effect allele), matching the allele the -#' marginal effect sizes and the fine-mapping \code{af} column report. For -#' a summary-statistic collection this is \code{NULL} when the source +#' for a \code{QtlDataset}, an \code{\link{LdMatrix}}, or one entry of a +#' \code{GwasSumStats} / \code{QtlSumStats} collection. Unlike +#' \code{\link{maf}}, the value is \emph{not} folded to the minor allele: it +#' is the frequency of the dosage-counted allele (A1, the effect allele), +#' matching the allele the marginal effect sizes and the fine-mapping +#' \code{af} column report. For a summary-statistic collection this is +#' \code{NULL} when the source #' carried no frequency column -- see \code{\link{variantColumnReplace}} #' for supplying one afterwards. -#' @param x A \code{QtlDataset}, \code{GwasSumStats} or \code{QtlSumStats} -#' object. +#' @param x A \code{QtlDataset}, \code{LdMatrix}, \code{GwasSumStats} or +#' \code{QtlSumStats} object. #' @param ... Class-specific selection arguments (e.g., \code{traitId}, #' \code{region}, \code{cisWindow}, \code{samples} for \code{QtlDataset}). #' @param traitId Character or \code{NULL}. Molecular trait / feature identifier @@ -777,47 +808,46 @@ setGeneric("qcDiagnostics", function(x, entry = 1L, ...) { standardGeneric("qcDiagnostics") }) -#' @title Get LD Sketch -#' @description Return the genotype panel carrying the LD reference for -#' this collection. Defined on classes that embed an \code{ldSketch} slot: -#' \code{GwasSumStats}, \code{QtlSumStats}, \code{FineMappingResult}, -#' \code{TwasWeights}. Returns \code{NULL} when the slot is unset (e.g. a -#' \code{TwasWeights} fit from individual-level data via \code{QtlDataset}). -#' @param x An S4 object that carries an \code{ldSketch} slot. +#' @title Get LD Reference +#' @description Return the LD reference of this object: a genotype panel +#' (see \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or +#' an \code{\link{LdMatrix}}. Defined on classes that embed an +#' \code{ldReference} slot: \code{GwasSumStats}, \code{QtlSumStats}, +#' \code{FineMappingResultBase}, \code{TwasWeights}, +#' \code{ColocResultBase} and \code{LdStatistic}, whose reference is the +#' panel it reads its blocks' LD from. Returns \code{NULL} when the slot is +#' unset (e.g. a \code{TwasWeights} fit from individual-level data via +#' \code{QtlDataset}, or an \code{LdStatistic} built from \code{LdMatrix} +#' blocks). +#' @param x An S4 object that carries an \code{ldReference} slot. #' @param ... Unused. -#' @return A \code{RangedSummarizedExperiment} genotype panel, or -#' \code{NULL}. +#' @return A \code{RangedSummarizedExperiment} genotype panel, a +#' \code{GenotypeMixture}, an \code{LdMatrix}, or \code{NULL}. #' @export -setGeneric("ldSketch", function(x, ...) standardGeneric("ldSketch")) +setGeneric("ldReference", function(x, ...) standardGeneric("ldReference")) # ============================================================================= -# LdData accessor generics +# LD accessor generics # ============================================================================= #' @title Get LD Correlation Matrix -#' @description Extract the LD correlation matrix from an \code{LdData} object. -#' If only a genotype handle is available, recomputes R from genotypes on the -#' fly. -#' @param x An \code{LdData} object. -#' @return A correlation matrix, or a list of per-block matrices. +#' @description Extract the LD correlation matrix an \code{\link{LdMatrix}} +#' holds, labelled by its variant ids. +#' @param x An \code{LdMatrix}. +#' @return A correlation matrix. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:8] -#' gr <- GenomicRanges::GRanges("22", -#' IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -#' ld <- LdData(correlation = cor(X), variants = gr, -#' blockMetadata = S4Vectors::DataFrame( -#' chrom = "22", start = 1L, end = 1000L)) -#' ldMatrix(ld) +#' ld <- LdMatrix(cor(X), nSamples = nrow(X)) +#' ldMatrix(ld)[1:3, 1:3] #' @export setGeneric("ldMatrix", function(x) standardGeneric("ldMatrix")) #' @title Get Genotype Matrix #' @description Extract a genotype matrix from an object that carries genotype -#' data. For an \code{LdData}, returns the underlying genotype matrix via its -#' handle (or \code{NULL} if no handle is available). For a \code{QtlDataset}, -#' returns the genotype matrix for a selected set of traits or region (see -#' method documentation for the per-class selection arguments). +#' data. For a \code{QtlDataset}, returns the genotype matrix for a selected +#' set of traits or region (see method documentation for the per-class +#' selection arguments). #' @param x The object to extract from. #' @param ... Class-specific selection arguments (e.g., \code{traitId}, #' \code{region}, \code{cisWindow} for \code{QtlDataset}). @@ -837,26 +867,9 @@ setGeneric("ldMatrix", function(x) standardGeneric("ldMatrix")) #' @export setGeneric("genotypes", function(x, ...) standardGeneric("genotypes")) -#' @title Check Genotype Availability -#' @description Check whether an \code{LdData} object has a genotype handle for -#' extracting raw genotypes. -#' @param x An \code{LdData} object. -#' @return Logical. -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:8] -#' gr <- GenomicRanges::GRanges("22", -#' IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -#' ld <- LdData(correlation = cor(X), variants = gr, -#' blockMetadata = S4Vectors::DataFrame( -#' chrom = "22", start = 1L, end = 1000L)) -#' hasGenotypes(ld) -#' @export -setGeneric("hasGenotypes", function(x) standardGeneric("hasGenotypes")) - #' @title Get Variant IDs #' @description Extract variant ID vector from an object that carries one (e.g., -#' \code{LdData}, \code{FineMappingRow}, \code{TwasWeightsRow}) or from +#' \code{LdMatrix}, \code{FineMappingRow}, \code{TwasWeightsRow}) or from #' one entry of a collection class selected by its identity tuple. #' @param x The object. #' @param ... Class-specific selection arguments. @@ -920,17 +933,18 @@ setGeneric("molecularTraits", function(x, ...) { standardGeneric("molecularTraits") }) # ============================================================================= -# FineMappingResult accessor generics +# Fine-mapping result accessor generics # ============================================================================= #' @title Get a Single Fine-Mapping Entry -#' @description Return the \code{FineMappingRow} for one \code{(study, -#' context, trait, method)} row of a \code{FineMappingResult} collection. -#' @param x A \code{FineMappingResult} object. +#' @description Return one row of a \code{QtlFineMappingResult} or +#' \code{GwasFineMappingResult}, selected by its identity, as a single-row +#' collection of the same class. +#' @param x A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}. #' @param studyName,context,trait,method Single character identifiers. All #' required when the collection has more than one row; optional when the #' collection has a single row. -#' @return A \code{FineMappingRow} object. +#' @return A single-row collection of the same class as \code{x}. #' @examples #' data(qtlFineMappingExample) #' fineMappingResult(qtlFineMappingExample, studyName = "study_1", @@ -955,8 +969,8 @@ setGeneric( #' \item The user declined to impute missing variants in a GWAS #' \code{SumStats}, so a downstream fine-mapping result needs #' PIPs restricted to the GWAS-covered intersection. -#' \item Colocalization between a GWAS \code{FineMappingResult} and a -#' QTL \code{FineMappingResult} computed on different variant +#' \item Colocalization between a \code{GwasFineMappingResult} and a +#' \code{QtlFineMappingResult} computed on different variant #' sets -- the GWAS PIPs (or QTL PIPs) get renormalized to the #' common variant set. #' } @@ -972,10 +986,10 @@ setGeneric("adjustPips", function(x, keepVariants, ...) { }) #' @title Get PIP Values -#' @description Extract posterior inclusion probabilities from a single -#' \code{FineMappingRow} or from one entry of a \code{FineMappingResult} -#' (selected by its identity tuple). -#' @param x A \code{FineMappingRow} or \code{FineMappingResult}. +#' @description Extract posterior inclusion probabilities from a +#' \code{QtlFineMappingResult} or \code{GwasFineMappingResult}, narrowed to +#' the entries its identity selectors pick. +#' @param x A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}. #' @param ... Class-specific selection arguments. #' @param studyName Character (length 1) or \code{NULL}. Restrict the selection #' to this study; \code{NULL} matches all studies. @@ -1002,7 +1016,8 @@ setGeneric("pip", function(x, ...) standardGeneric("pip")) #' result. The fit may be the trimmed view (when the pipeline ran with the #' default \code{trim = TRUE}) or the full untrimmed \code{susie()} return #' (when \code{trim = FALSE}). -#' @param x A \code{FineMappingRow} or \code{FineMappingResult}. +#' @param x A \code{FineMappingRow}, \code{QtlFineMappingResult} or +#' \code{GwasFineMappingResult}. #' @param ... Class-specific selection arguments. #' @param studyName Character (length 1) or \code{NULL}. Restrict the selection #' to this study; \code{NULL} matches all studies. @@ -1027,14 +1042,14 @@ setGeneric("susieFit", function(x, ...) standardGeneric("susieFit")) #' \code{\link{fineMappingRow}} on demand from an LD source. The correlation #' is a view over the fit-time LD, which lives on the data object --- a #' \code{QtlDataset}'s genotypes or a \code{QtlSumStats} / \code{GwasSumStats} -#' LD sketch --- and is deliberately never stored on the fit. An +#' LD reference --- and is deliberately never stored on the fit. An #' \code{ldSource} is therefore always required. #' @param x A \code{\link{fineMappingRow}} carrying the fit (credible-set #' membership and PIP) and its variant ids. #' @param ldSource The object supplying the LD: a \code{QtlDataset} #' (individual-level; genotypes via \code{\link{genotypes}}) or a #' \code{QtlSumStats} / \code{GwasSumStats} (summary statistics; LD via -#' \code{\link{ldSketch}}). Any other type is an error. +#' \code{\link{ldReference}}). Any other type is an error. #' @param ... Passed to methods. #' @return A numeric \code{m x m} between-credible-set correlation matrix #' (\code{m} = number of credible sets), or \code{NULL} when the fit has @@ -1070,13 +1085,13 @@ setGeneric("computeCsCorrelation", function(x, ldSource, ...) { #' @title Get Cross-Validation Result #' @description Extract the cross-validation payload stored on a #' \code{FineMappingRow} (or the matching entry of a -#' \code{FineMappingResult}). The payload is a list with components +#' \code{QtlFineMappingResult}). The payload is a list with components #' \code{samplePartition} (a \code{data.frame} of \code{Sample}/\code{Fold} #' assignments), \code{predictions} (a named list of per-method out-of-fold #' prediction matrices), and \code{performance} (a named list of per-method #' metric matrices). \code{NULL} when fine-mapping was run without -#' cross-validation (\code{cvFolds <= 1}). -#' @param x A \code{FineMappingRow} or \code{FineMappingResult}. +#' cross-validation. +#' @param x A \code{FineMappingRow} or \code{QtlFineMappingResult}. #' @param ... Class-specific selection arguments. #' @param studyName Character (length 1) or \code{NULL}. Restrict the selection #' to this study; \code{NULL} matches all studies. @@ -1099,7 +1114,7 @@ setGeneric("cvResult", function(x, ...) standardGeneric("cvResult")) #' columns (\code{variant_id, chrom, pos, A1, A2}), context (\code{N, MAF}), #' and the marginal effect columns (\code{beta, se, z, p}). Populated #' uniformly across the individual-level and RSS paths. -#' @param x A \code{FineMappingRow} or \code{FineMappingResult}. +#' @param x A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}. #' @param maxPval Optional numeric (length 1). When non-\code{NULL}, filter rows #' where \code{p > maxPval}. Default \code{NULL} (no filter). #' @param ... Class-specific selection arguments. @@ -1131,7 +1146,7 @@ setGeneric("marginalEffects", function(x, maxPval = NULL, ...) { #' \code{pip}, and credible-set membership columns (\code{cs_95}, etc.). Rows #' are filtered by PIP by default -- set \code{signalCutoff = 0} to return #' every variant. -#' @param x A \code{FineMappingRow} or \code{FineMappingResult}. +#' @param x A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}. #' @param signalCutoff Numeric (length 1). Drop rows where \code{pip <= #' signalCutoff}. Default \code{0.025}. Use \code{signalCutoff = 0} to keep #' every variant. @@ -1171,7 +1186,7 @@ setGeneric( #' @title Get Credible Sets #' @description Extract credible set assignments at the requested coverage. -#' @param x A \code{FineMappingRow} or \code{FineMappingResult}. +#' @param x A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}. #' @param ... Class-specific selection arguments plus \code{coverage}. #' @param studyName Character (length 1) or \code{NULL}. Restrict the selection #' to this study; \code{NULL} matches all studies. @@ -1204,15 +1219,16 @@ setGeneric("credibleSets", function(x, ...) standardGeneric("credibleSets")) #' single weight-source entry, so cTWAS and #' \code{\link{causalInferencePipeline}} extract weights identically whether #' the source is a \code{TwasWeights} collection (its learned weight vector) -#' or a \code{FineMappingResult} one (its topLoci posterior effect). The -#' selectors pin the single row the weights come from. -#' @param x A \code{TwasWeights} or a \code{FineMappingResult}. +#' or a fine-mapping one (its topLoci posterior effect). The selectors pin +#' the single row the weights come from. +#' @param x A \code{TwasWeights}, \code{QtlFineMappingResult} or +#' \code{GwasFineMappingResult}. #' @param studyName,context,trait,method Optional length-1 selectors pinning one #' row of a collection, as elsewhere; each \code{NULL} (default) leaves that #' part of the tuple unconstrained. Ignored when \code{x} is already a row. #' @param region Character (length 1, \code{"chr:start-end"}) or \code{NULL}. -#' A further selector for a \code{FineMappingResult}, whose rows also carry -#' a region; \code{NULL} (default) leaves it unconstrained. +#' A further selector for a fine-mapping result, whose rows also carry a +#' region; \code{NULL} (default) leaves it unconstrained. #' @param ... Reserved for future use. #' @return A \code{list} with \code{variantIds} (character) and \code{weights} #' (numeric) of equal length; both empty when no usable weights are present. @@ -1345,8 +1361,8 @@ setGeneric("cvFits", function(x, ...) standardGeneric("cvFits")) #' @title Get Method Names #' @description Extract the method name(s) an object was produced with: one #' per entry for a collection, a single name for one estimate. -#' @param x A \code{FineMappingResult}, \code{TwasWeights}, -#' \code{CtwasResult} or \code{H2Estimate} object. +#' @param x A \code{QtlFineMappingResult}, \code{GwasFineMappingResult}, +#' \code{TwasWeights}, \code{CtwasResult} or \code{H2Estimate} object. #' @return Character vector. #' @examples #' data(h2EstimateExample) @@ -1377,9 +1393,6 @@ setGeneric("weightsDataType", function(x, ...) { standardGeneric("weightsDataType") }) -# ============================================================================= -# AlleleQcResult accessor generics -# QcResult accessor generics # ============================================================================= # Published-output generics (VCF/BCF and BED) # ============================================================================= @@ -1397,7 +1410,7 @@ setGeneric("weightsDataType", function(x, ...) { #' \describe{ #' \item{\code{GwasSumStats}}{\code{ES} / \code{SS} / \code{AF} for one #' study.} -#' \item{\code{FineMappingResult}}{the marginal fields (\code{ES}, +#' \item{a fine-mapping result}{the marginal fields (\code{ES}, #' \code{SE}, \code{LP}, \code{SS}, \code{AF}) plus the posterior ones #' (\code{PIP}, \code{LBF}, \code{LFSR}, and a \code{CS}/\code{PUR} pair #' per credible-set coverage present).} @@ -1417,9 +1430,10 @@ setGeneric("weightsDataType", function(x, ...) { #' \code{splitByContext} / \code{splitByTrait} opt out of that and write one #' single-sample file per fit, at a path decorated with the axis value. #' -#' @param x A \code{GwasSumStats}, \code{FineMappingResult} or -#' \code{TwasWeights} object, or a \code{list} of \code{FineMappingResult} -#' / \code{TwasWeights} objects to combine first. +#' @param x A \code{GwasSumStats}, \code{QtlFineMappingResult}, +#' \code{GwasFineMappingResult} or \code{TwasWeights} object, or a +#' \code{list} of fine-mapping results or of \code{TwasWeights} objects to +#' combine first. #' @param outputPath File path for output. Extension determines format: #' \code{.vcf.gz} or \code{.vcf.bgz} for bgzipped VCF, \code{.bcf} for BCF, #' \code{.vcf} for uncompressed VCF. @@ -1459,7 +1473,7 @@ setGeneric("exportToVcf", function(x, outputPath, sampleName = NULL, ...) { #' observation. #' #' A \code{TwasWeights} writes one table, a row per (variant, weight column). -#' A \code{FineMappingResult} offers two, selected with \code{schema}: +#' A fine-mapping result offers two, selected with \code{schema}: #' \describe{ #' \item{\code{"topLoci"}}{(default) the posterior view joined to the #' marginal one, a row per (variant, context).} @@ -1483,12 +1497,12 @@ setGeneric("exportToVcf", function(x, outputPath, sampleName = NULL, ...) { #' \code{twasWeightsPipeline(fitFullData = FALSE)} produces) is refused rather #' than written out empty. #' -#' @param x A \code{FineMappingResult} or \code{TwasWeights} object, or a -#' \code{list} of either, to combine first. +#' @param x A \code{QtlFineMappingResult}, \code{GwasFineMappingResult} or +#' \code{TwasWeights} object, or a \code{list} of them, to combine first. #' @param outputPath Output path. A \code{.gz} / \code{.bgz} extension selects #' bgzip + tabix (via Rsamtools, so no htslib binary is needed); any other #' extension writes a plain table. -#' @param schema \code{FineMappingResult} only: which published schema to +#' @param schema Fine-mapping results only: which published schema to #' write, \code{"topLoci"} (default) or \code{"fsusie"}. #' @param coverage Which credible-set coverage levels to publish, as #' proportions (\code{c(0.95, 0.5)}). \code{NULL} (default) publishes every @@ -1505,9 +1519,9 @@ setGeneric("exportToVcf", function(x, outputPath, sampleName = NULL, ...) { #' written by default; naming one drops the other's columns, leaving a strict #' subset of the full table. #' @param signalCutoff PIP cutoff passed to \code{\link{topLoci}} -#' (\code{FineMappingResult}, \code{"topLoci"} schema only). Default 0.025. +#' (fine-mapping results, \code{"topLoci"} schema only). Default 0.025. #' @param minPurity Optional credible-set purity cutoff passed to -#' \code{\link{topLoci}} (\code{FineMappingResult}, \code{"topLoci"} schema +#' \code{\link{topLoci}} (fine-mapping results, \code{"topLoci"} schema #' only). Default \code{NULL} for no purity filter. #' @param columns Which of the SOURCE view's own variant-level columns to #' append after the published schema. \code{NULL} (default) appends none; @@ -1583,7 +1597,7 @@ setGeneric("traitNames", function(x) standardGeneric("traitNames")) #' @title Get Per-Row Analysis Windows #' @description Return the genomic interval each row was analysed over, as a #' \code{GRanges} with one range per row -- the trait's own region for a -#' \code{TwasWeights}, and for a \code{FineMappingResult} the window the fit +#' \code{TwasWeights}, and for a fine-mapping result the window the fit #' was run over (the requested region, or the trait's cis-window when the fit #' was driven by \code{traitId} + \code{cisWindow}). This is location #' provenance (e.g. for cTWAS LD-block placement). @@ -1642,8 +1656,8 @@ setGeneric("blockId", function(x, ...) standardGeneric("blockId")) #' @description Return the molecular feature's OWN genomic coordinates (the gene #' / peak range; TSS = \code{start()}) for each row of a per-tuple collection, #' as a \code{GRanges} with one range per row. Distinct from -#' \code{\link{genomicRegion}} (the fine-mapping window for a -#' \code{FineMappingResult}): the true trait position cannot be inferred from +#' \code{\link{genomicRegion}} (the window a fine-mapping result was fit +#' over): the true trait position cannot be inferred from #' summary statistics, so it is threaded from the QtlDataset \code{rowRanges} #' or an explicit QtlSumStats trait-position and carried as provenance onto #' \code{QtlFineMappingResult} and \code{TwasWeights}. @@ -1679,7 +1693,7 @@ setGeneric("traitPosition", function(x, ...) { #' around the trait; \code{NULL} uses the dataset default. #' @param samples Character vector or \code{NULL}. Restrict to these sample IDs; #' \code{NULL} uses all samples. -#' @param residualizationArgs What the data is residualized on, built with +#' @param residualizationParam What the data is residualized on, built with #' \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and #' \code{genotypeCovariates} choose the covariate sets, #' \code{residualizePhenotype} / \code{residualizeGenotype} turn each @@ -1711,7 +1725,7 @@ setGeneric("residualizedGenotypes", function(x, ...) { #' @param region Character (length 1, \code{"chr:start-end"}) or \code{NULL}. #' Restrict variants to this region; \code{NULL} uses the full cis window / #' all regions. -#' @param residualizationArgs What the data is residualized on, built with +#' @param residualizationParam What the data is residualized on, built with #' \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and #' \code{genotypeCovariates} choose the covariate sets, #' \code{residualizePhenotype} / \code{residualizeGenotype} turn each @@ -1779,7 +1793,7 @@ setGeneric("scaleResiduals", function(x) { }) # ============================================================================= -# GenotypeHandle / LD-statistic / Annotation / LdData / H2Estimate accessors +# GenotypeHandle / LD-statistic / LdMatrix / Annotation / H2Estimate accessors # ============================================================================= #' @title Get SNP Info @@ -1800,7 +1814,7 @@ setGeneric("snpInfo", function(x) standardGeneric("snpInfo")) #' @title Get Genotype Storage Format #' @description Return the detected genotype storage format. #' @param x A \code{GenotypeHandle}. -#' @return Character (length 1): one of "gds", "vcf", "plink1", "plink2". +#' @return Character (length 1): one of "plink1", "plink2", "bgen". #' @details The genotype handle is the seed layer behind a panel and #' is not part of the public interface; obtain a panel from #' \code{readGenotypes()} and ask it directly. @@ -1829,10 +1843,16 @@ setGeneric("sampleIds", function(x) standardGeneric("sampleIds")) setGeneric("pgenPtr", function(x) standardGeneric("pgenPtr")) #' @title Get Per-Block Eigendecompositions -#' @description Return the per-block eigendecomposition list carried by an -#' \code{LdEigen} object. +#' @description Return the per-block eigendecompositions of an +#' \code{LdEigen}: the stored ones, or, for one built from a genotype +#' panel (which stores none), every block's computed from the panel now. +#' That holds all of them in memory at once, which the estimators avoid by +#' decomposing one block at a time. #' @param x An \code{LdEigen}. -#' @return List of per-block eigen decompositions. +#' @return A list with one element per block, each a list with +#' \code{values}, \code{vectors} and \code{snpIdx}. One computed from a +#' panel also carries \code{nNull}: the number of the block's directions +#' whose eigenvalue is exactly zero, which it does not list. #' @examples #' data(ldEigenExample) #' eigenList(ldEigenExample) @@ -1841,18 +1861,12 @@ setGeneric("eigenList", function(x) standardGeneric("eigenList")) #' @title Get LD Reference Panel Size #' @description Return the reference-panel sample size used to compute an -#' \code{LdStatistic} or carried by an \code{LdData}. -#' @param x An \code{LdStatistic} or \code{LdData}. +#' \code{LdStatistic}. +#' @param x An \code{LdStatistic}. #' @return Integer (length 1). #' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:8] -#' gr <- GenomicRanges::GRanges("22", -#' IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -#' ld <- LdData(correlation = cor(X), variants = gr, -#' blockMetadata = S4Vectors::DataFrame( -#' chrom = "22", start = 1L, end = 1000L)) -#' ldPanelNSamples(ld) +#' data(ldEigenExample) +#' ldPanelNSamples(ldEigenExample) #' @export setGeneric("ldPanelNSamples", function(x) standardGeneric("ldPanelNSamples")) @@ -1868,10 +1882,14 @@ setGeneric("ldPanelNSamples", function(x) standardGeneric("ldPanelNSamples")) setGeneric("inSample", function(x) standardGeneric("inSample")) #' @title Get Per-Block LD Matrix List -#' @description Return the list of per-block LD (R^2) matrices used for the FGLS -#' residual covariance in g-LDSC. +#' @description Return the per-block LD correlation matrices g-LDSC forms its +#' FGLS residual covariance from: the stored ones, or, for an +#' \code{LdScore} built from a genotype panel (which stores none), every +#' block's computed from the panel now. That holds all of them in memory at +#' once, which the estimators avoid by reading one block at a time. #' @param x An \code{LdScore}. -#' @return List of matrices (empty list for S-LDSC). +#' @return A list with one element per block, each a list with \code{R} and +#' \code{snpIdx}; empty for a scores-only \code{LdScore}. #' @examples #' data(ldScoreExample) #' ldMatrixList(ldScoreExample) @@ -1890,13 +1908,13 @@ setGeneric("ldMatrixList", function(x) standardGeneric("ldMatrixList")) setGeneric("ldBlocks", function(x) standardGeneric("ldBlocks")) -#' @title Get GenotypeHandle from LdData -#' @description Return the \code{GenotypeHandle} (or list of handles for mixture -#' panels) carried by an \code{LdData}. -#' @param x An \code{LdData}. -#' @return A \code{GenotypeHandle}, a list of them, or NULL. For a -#' \code{QtlDataset} this is the handle itself; \code{genotypes()} -#' extracts a dosage block from it instead. +#' @title Get GenotypeHandle +#' @description Return the \code{GenotypeHandle} behind a \code{QtlDataset}'s +#' genotype experiment. +#' @param x A \code{QtlDataset}. +#' @return A \code{GenotypeHandle}, or NULL for genotypes read through no +#' handle (a VCF, GDS or PLINK1 file, or held in memory); +#' \code{genotypes()} extracts a dosage block instead. #' @details The genotype handle is the seed layer behind a panel and #' is not part of the public interface; obtain a panel from #' \code{readGenotypes()} and ask it directly. @@ -1906,92 +1924,25 @@ setGeneric("genotypeHandle", function(x) { }) #' @title Get Mixture Weights -#' @description Return the per-panel mixing proportions carried by an -#' \code{LdData} when its \code{genotypeHandle} slot is a list of panels. NULL -#' for single-panel objects. -#' @param x An \code{LdData}. +#' @description Return the weights a mixture's components are combined +#' with: an \code{\link{LdMatrix}} mixture's (\code{NULL} for a single +#' panel's LD), or a \code{\link{GenotypeMixture}}'s, named after its +#' panels. +#' @param x An \code{LdMatrix} or a \code{GenotypeMixture}. #' @return Numeric vector or NULL. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:8] -#' gr <- GenomicRanges::GRanges("22", -#' IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -#' ld <- LdData(correlation = cor(X), variants = gr, -#' blockMetadata = S4Vectors::DataFrame( -#' chrom = "22", start = 1L, end = 1000L)) -#' mixtureWeights(ld) +#' half <- seq_len(nrow(X) / 2) +#' mix <- LdMatrix( +#' list(LdMatrix(cor(X[half, ])), LdMatrix(cor(X[-half, ]))), +#' mixtureWeights = c(0.75, 0.25)) +#' mixtureWeights(mix) #' @export setGeneric("mixtureWeights", function(x) { standardGeneric("mixtureWeights") }) -#' @title Get SNP Indices -#' @description Return the integer indices into the handle's snpInfo carried by -#' an \code{LdData}. -#' @param x An \code{LdData}. -#' @return Integer vector or NULL. -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:8] -#' gr <- GenomicRanges::GRanges("22", -#' IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -#' ld <- LdData(correlation = cor(X), variants = gr, -#' blockMetadata = S4Vectors::DataFrame( -#' chrom = "22", start = 1L, end = 1000L)) -#' snpIdx(ld) -#' @export -setGeneric("snpIdx", function(x) standardGeneric("snpIdx")) - -#' @title Get Variant GRanges -#' @description Return the variant metadata \code{GRanges} of an \code{LdData}. -#' @param x An \code{LdData}. -#' @return A \code{GRanges}. -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:8] -#' gr <- GenomicRanges::GRanges("22", -#' IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -#' ld <- LdData(correlation = cor(X), variants = gr, -#' blockMetadata = S4Vectors::DataFrame( -#' chrom = "22", start = 1L, end = 1000L)) -#' variantInfo(ld) -#' @export -setGeneric("variantInfo", function(x) standardGeneric("variantInfo")) - -#' @title Get Block Metadata -#' @description Return the block metadata (\code{GRanges} or \code{data.frame}) -#' carried by an \code{LdData}. -#' @param x An \code{LdData}. -#' @return A \code{GRanges} or \code{data.frame}. -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:8] -#' gr <- GenomicRanges::GRanges("22", -#' IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -#' ld <- LdData(correlation = cor(X), variants = gr, -#' blockMetadata = S4Vectors::DataFrame( -#' chrom = "22", start = 1L, end = 1000L)) -#' blockMetadata(ld) -#' @export -setGeneric("blockMetadata", function(x) standardGeneric("blockMetadata")) - -#' @title Get Reference Panel (data.frame) -#' @description Flatten the variant \code{GRanges} of an \code{LdData} into a -#' reference-panel data.frame. -#' @param x An \code{LdData}. -#' @return A data.frame. -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:8] -#' gr <- GenomicRanges::GRanges("22", -#' IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -#' ld <- LdData(correlation = cor(X), variants = gr, -#' blockMetadata = S4Vectors::DataFrame( -#' chrom = "22", start = 1L, end = 1000L)) -#' refPanel(ld) -#' @export -setGeneric("refPanel", function(x) standardGeneric("refPanel")) - #' @title Get Per-Block tau Matrix #' @description Return the per-block jackknife tau matrix carried by an #' \code{H2Estimate}. @@ -2283,7 +2234,7 @@ setGeneric("sldscResults", function(x, trait = NULL, ...) { #' the five posterior probabilities, i.e. colocalization is the favoured #' hypothesis rather than merely a probable one. #' @param minAbsCorr Minimum absolute correlation between credible-set members -#' (purity). Requires the object's \code{ldSketch}; when that is absent, +#' (purity). Requires the object's \code{ldReference}; when that is absent, #' purity is reported as \code{NA} and no set is dropped. #' @param ... Additional arguments passed on to methods. #' @return A tibble at the requested granularity. @@ -2403,7 +2354,7 @@ setGeneric("chromPaths", function(x, ...) standardGeneric("chromPaths")) #' Across entries with different effect counts the collection method NA-fills #' the ragged columns. #' -#' @param x A \code{FineMappingRow} or \code{FineMappingResultBase}. +#' @param x A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}. #' @param ... Ignored. #' @return A \code{tibble}: \code{variant_id} + \code{lbf_L1..lbf_LL} (the #' collection method also carries the entry identity columns). @@ -2421,7 +2372,7 @@ setGeneric("lbf", function(x, ...) standardGeneric("lbf")) #' per-variant \code{\link{credibleSets}}. Replaces the legacy #' per-effect `effect.tsv`. #' -#' @param x A \code{FineMappingRow} or \code{FineMappingResultBase}. +#' @param x A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}. #' @param coverage Credible-set coverage to summarise. Default 0.95. #' @param ... Ignored. #' @return A \code{tibble}: \code{cs, effect_id, coverage, n_variants, @@ -2450,7 +2401,7 @@ setGeneric("credibleSetSummary", function(x, ...) { #' them from an untrimmed fit. Returns zero rows when the functional fields #' are absent. #' -#' @param x A \code{FineMappingRow} or \code{FineMappingResultBase}. +#' @param x A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}. #' @param ... Ignored. #' @return A long \code{tibble}: \code{cs, chrom, pos, effect, lower, upper, #' halfwidth} -- \code{halfwidth} being \code{(upper - lower) / 2}, the @@ -2479,7 +2430,7 @@ setGeneric("fsusieCredibleBand", function(x, ...) { #' index-aligned because both describe the same joint group. Returns zero rows #' when the functional fields are absent. #' -#' @param x A \code{FineMappingRow} or \code{FineMappingResultBase}. +#' @param x A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}. #' @param ... Ignored. #' @return A long \code{tibble}: \code{cs, chrom, jointTrait, traitPos, #' effect} (the collection method additionally carries the entry identity @@ -2503,7 +2454,7 @@ setGeneric("fsusieTraitEffects", function(x, ...) { #' (\code{"pos"}/\code{"neg"}; upstream discards it). Uses retained functional #' summaries or an untrimmed fit; empty when those fields are absent. #' -#' @param x A \code{FineMappingRow} or \code{FineMappingResultBase}. +#' @param x A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}. #' @param ... Ignored. #' @return A \code{GRanges} of affected intervals with mcols \code{cs}, #' \code{purity}, \code{direction} (plus entry identity for the collection). diff --git a/R/AnnotationMatrix.R b/R/AnnotationMatrix.R index af272e841..3f066e345 100644 --- a/R/AnnotationMatrix.R +++ b/R/AnnotationMatrix.R @@ -195,9 +195,9 @@ AnnotationMatrix <- function( # Annotations of one tier. A column subset: SummarizedExperiment keeps the # rows, the assay and the per-annotation table aligned, where the previous # implementation rebuilt the object from three separately-subset pieces. -# @noRd # Callers are methods dispatching on AnnotationMatrix, so the class is # already guaranteed here -- no assertClass. +# @noRd .annotTier <- function(x, tier) { x[, SummarizedExperiment::colData(x)$tier == tier] } diff --git a/R/ColocBoostResult.R b/R/ColocBoostResult.R index 181c947c2..3db3f54a9 100644 --- a/R/ColocBoostResult.R +++ b/R/ColocBoostResult.R @@ -23,7 +23,7 @@ # # What the two DO share is the LD panel they were computed against and the # projection surface, so both extend ColocResultBase -- which carries the -# ldSketch slot and its accessor -- and both answer colocPairs() and +# ldReference slot and its accessor -- and both answer colocPairs() and # colocVariants(). # # element the member variants of one CoS @@ -32,7 +32,7 @@ # CharacterList -- native variable arity), purity, cosNpc, # minNpcOutcome, topVariable, topVariableVcp, focalOutcome, # isColocalized -# slots ldSketch, outcomeInfo, regionVcp, computingTime +# slots ldReference, outcomeInfo, regionVcp, computingTime # # Uncolocalized (outcome-specific) sets are elements too, flagged # isColocalized = FALSE, rather than living in a second container: they have @@ -204,7 +204,7 @@ setMethod("show", "ColocBoostResult", function(object) { #' naming the GWAS study for the per-study \code{separate_gwas} runs. #' @param outcomeInfo Data frame mapping outcome \code{name} to \code{study}, #' \code{context}, \code{trait} and \code{dataForm}. -#' @param ldSketch Optional genotype panel (see +#' @param ldReference Optional genotype panel (see #' \code{\link{readGenotypes}}). #' @param computingTime Optional list of per-analysis timings. #' @param includeUncolocalized Keep the outcome-specific (uncolocalized) sets @@ -232,7 +232,7 @@ ColocBoostResult <- function( analysis, gwasStudy = NA_character_, outcomeInfo = NULL, - ldSketch = NULL, + ldReference = NULL, computingTime = list(), includeUncolocalized = TRUE ) { @@ -257,7 +257,7 @@ ColocBoostResult <- function( rows, outcomeInfo = as.data.frame(outcomeInfo), regionVcp = .cbrRegionVcp(results), - ldSketch = .asLdSketch(ldSketch), + ldReference = .asLdRef(ldReference), computingTime = computingTime ) } @@ -430,8 +430,6 @@ ColocBoostResult <- function( if (is.null(v) || length(v) == 0L) NA_real_ else as.numeric(v)[[1L]] } -# @noRd - # `FALSE` means "no focal outcome was set"; anything else is the trait name. # @noRd .cbrFocalOutcome <- function(v) { @@ -471,7 +469,7 @@ ColocBoostResult <- function( rows, outcomeInfo, regionVcp, - ldSketch, + ldReference, computingTime ) { elements <- map(rows, .cbrElementFor) @@ -482,7 +480,7 @@ ColocBoostResult <- function( obj <- new( "ColocBoostResult", grl, - ldSketch = .asLdSketch(ldSketch), + ldReference = .asLdRef(ldReference), outcomeInfo = outcomeInfo, regionVcp = regionVcp, computingTime = computingTime diff --git a/R/ColocResult.R b/R/ColocResult.R index 867e1640b..08188b439 100644 --- a/R/ColocResult.R +++ b/R/ColocResult.R @@ -17,7 +17,7 @@ # inner mcols per-variant: SNP.PP.H4 # outer mcols per-pair: identity tuple, blockId, PP.H0..PP.H4, nSnps, # retained alpha mass (both sides), enrichment / p12Used -# slots ldSketch, for the credible-set view's purity calculation +# slots ldReference, for the credible-set view's purity calculation # # Nothing is filtered at write time (spec 5.3): every testable pair and every # variant is kept, and all narrowing is a view decision. Purity in particular @@ -46,28 +46,29 @@ NULL #' projection surface: both answer \code{\link{colocPairs}} and #' \code{\link{colocVariants}}, so code that only needs "which variants #' colocalized, and how strongly" works against either. -#' @slot ldSketch The LD reference panel the underlying fits were computed -#' against, or \code{NULL}. Shared by both subclasses: coloc and ColocBoost -#' report different statistics, but both are computed against a panel and -#' both are asked for it the same way. +#' @slot ldReference The LD reference the underlying fits were computed +#' against (a genotype panel, a \code{GenotypeMixture} or an +#' \code{LdMatrix}), or \code{NULL}. Shared by both subclasses: coloc and +#' ColocBoost report different statistics, but both are computed against a +#' reference and both are asked for it the same way. #' @export setClass( "ColocResultBase", contains = c("VIRTUAL", "RangedTupleList"), - representation(ldSketch = "LdSketch_OR_NULL"), - prototype(ldSketch = NULL) + representation(ldReference = "LdReference_OR_NULL"), + prototype(ldReference = NULL) ) -#' @rdname ldSketch +#' @rdname ldReference #' @export -setMethod("ldSketch", "ColocResultBase", function(x) x@ldSketch) +setMethod("ldReference", "ColocResultBase", function(x) x@ldReference) #' @title Colocalization Result #' @description A collection of colocalization results, one element per tested #' (QTL credible set, GWAS credible set, block) pair. Build the four views #' with \code{\link{colocPairs}}, \code{\link{colocVariants}}, #' \code{\link{colocCredibleSets}} and \code{\link{colocGenes}}. -#' @details The inherited \code{ldSketch} is what +#' @details The inherited \code{ldReference} is what #' \code{colocCredibleSets()} uses to compute credible-set purity. #' @seealso \code{\link{colocPipeline}} #' @export @@ -197,7 +198,7 @@ setMethod("show", "ColocResult", function(object) { #' columns are \code{NA} for it. #' @param variants A list, parallel to \code{pairs}' rows, of per-pair data #' frames with a \code{variant_id} column and a \code{SNP.PP.H4} column. -#' @param ldSketch Optional genotype panel (see \code{\link{readGenotypes}}) +#' @param ldReference Optional genotype panel (see \code{\link{readGenotypes}}) #' for the LD reference, used by \code{\link{colocCredibleSets}} to #' compute purity. #' @return A \code{ColocResult}. @@ -217,7 +218,7 @@ setMethod("show", "ColocResult", function(object) { #' )) #' ColocResult(pairs, variants) #' @export -ColocResult <- function(pairs, variants, ldSketch = NULL) { +ColocResult <- function(pairs, variants, ldReference = NULL) { pairs <- as.data.frame(pairs, stringsAsFactors = FALSE) if (!is.list(variants) || length(variants) != nrow(pairs)) { msg <- glue( @@ -237,7 +238,7 @@ ColocResult <- function(pairs, variants, ldSketch = NULL) { !!!c(as.list(pairs), list(check.names = FALSE)) ) ) - obj <- new("ColocResult", grl, ldSketch = .asLdSketch(ldSketch)) + obj <- new("ColocResult", grl, ldReference = .asLdRef(ldReference)) validObject(obj) obj } @@ -461,7 +462,7 @@ setMethod( } out <- bind_rows(sets) .crApplyPurityFilter( - mutate(out, purity = .crPuritiesFor(out, ldSketch(x))), + mutate(out, purity = .crPuritiesFor(out, ldReference(x))), minAbsCorr ) } @@ -535,23 +536,23 @@ setMethod( # one LD extraction per set (section 3.7). NA when there is no LD reference to # extract from -- reported honestly rather than defaulted to a passing value. # @noRd -.crPuritiesFor <- function(out, ldSketch) { - if (is.null(ldSketch)) { +.crPuritiesFor <- function(out, ldReference) { + if (is.null(ldReference)) { return(rep(NA_real_, nrow(out))) } - map_dbl(out$csVariants, .crPurityOne, ldSketch = ldSketch) + map_dbl(out$csVariants, .crPurityOne, ldReference = ldReference) } # @noRd #' @importFrom rlang try_fetch -.crPurityOne <- function(ids, ldSketch) { +.crPurityOne <- function(ids, ldReference) { # A singleton set has no pair to correlate, and susie treats it as pure. if (length(ids) < 2L) { return(1) } ld <- try_fetch( - .ldFromSketch( - ldSketch, + .ldFromRef( + ldReference, ids, label = "colocCredibleSets", onMissing = "drop" diff --git a/R/CtwasResult.R b/R/CtwasResult.R index 59bcfdb3c..cbe7b156e 100644 --- a/R/CtwasResult.R +++ b/R/CtwasResult.R @@ -8,7 +8,7 @@ # run, so genes live inside the payload. Optional joint columns (jointStudies, # jointContexts) tag rows born from a multi-study / multi-context cTWAS run and # participate in the uniqueness key, exactly as in the TwasWeights / -# FineMappingResult families. +# FineMappingResultBase families. # ============================================================================= #' @include AllGenerics.R tupleSelectors.R diff --git a/R/GenotypeDosageSeed.R b/R/GenotypeDosageSeed.R new file mode 100644 index 000000000..1cb587989 --- /dev/null +++ b/R/GenotypeDosageSeed.R @@ -0,0 +1,383 @@ +# ============================================================================= +# GenotypeDosageSeed -- a DelayedArray backend over a VCF, GDS or PLINK1 file +# ----------------------------------------------------------------------------- +# A VCF, GDS or PLINK1 panel reads its dosages through this seed, as a PLINK2 +# or BGEN panel reads through a GenotypeHandle's GhSeed. Each row is one +# variant: one ALT allele of one record of the file, so a record with several +# ALT alleles is read as one variant per ALT allele. The seed knows where each +# row's record is in the file and which allele the row counts, and turns what +# the file stores into that allele's dosage. What it reads is its `field`: +# +# vcfGt a VCF's GT calls, through VariantAnnotation +# vcfDs a VCF's FORMAT/DS values, through VariantAnnotation +# snpGdsSnpOrder a SNPRelate GDS's genotype codes, stored SNP by SNP +# snpGdsSampleOrder or sample by sample, through GDSArray +# seqArrayGt a SeqArray GDS's allele indices, through GDSArray +# seqArrayDs a SeqArray GDS's annotation/format/DS, through GDSArray +# plinkBed a PLINK1 .bed's genotype codes, through PlinkMatrix +# +# VCFArray's seed is not built on. It reads a row through every record that +# overlaps the row's range, so in a VCF whose records overlap -- a split +# multi-allelic site, a deletion spanning a SNP -- it returns more rows than +# were asked for and DelayedArray rejects the block. The VCF fields are read +# through VariantAnnotation, as VCFArray reads them, and each record is +# picked out of what its range returns. +# +# Orientation: variants x samples, as for GhSeed. +# ============================================================================= + +#' @include AllGenerics.R +NULL + +#' DelayedArray seed over a VCF, GDS or PLINK1 file +#' +#' Lets the dosages of a VCF, GDS or PLINK1 file back a \code{DelayedArray} +#' that reads the file a block at a time, as \code{GhSeed} does for the +#' formats a \code{GenotypeHandle} reads. +#' +#' @slot backend What the file is read through: a +#' \code{VariantAnnotation::VcfFile}, the \code{GDSArray} seed of the +#' GDS node holding the field, or the stem of a PLINK1 fileset, which +#' \code{PlinkMatrix::read_bed_subset()} reads. +#' @slot field Which field is read, and so how it becomes a dosage: +#' \code{"vcfGt"}, \code{"vcfDs"}, \code{"snpGdsSnpOrder"}, +#' \code{"snpGdsSampleOrder"}, \code{"seqArrayGt"}, +#' \code{"seqArrayDs"} or \code{"plinkBed"}. +#' @slot rowRecord Integer; for each row, the element of \code{records} it +#' reads. +#' @slot rowAllele Integer; for each row, the ALT allele it counts, 1 for a +#' record's first ALT allele. +#' @slot records Where each record is in the file. For a VCF, a +#' \code{GRanges} of each record's REF allele, with \code{posRank}, the +#' record's rank among those starting at its position; for a GDS, an +#' \code{IRanges} of the columns (or SeqArray's 2-bit planes) of the node +#' holding it; for a PLINK1 fileset, an \code{IRanges} of each variant's +#' position in the \code{.bed}. +#' @slot dn List of dimnames (variant ids, sample ids). +#' @name GenotypeDosageSeed-class +#' @keywords internal +#' @importClassesFrom S4Vectors Vector +#' @importFrom BiocGenerics width +setClass( + "GenotypeDosageSeed", + representation( + backend = "ANY", + field = "character", + rowRecord = "integer", + rowAllele = "integer", + records = "Vector", + dn = "list" + ) +) + +#' @rdname GenotypeDosageSeed-class +setMethod("dim", "GenotypeDosageSeed", function(x) { + c(length(x@rowRecord), length(x@dn[[2L]])) +}) + +#' @rdname GenotypeDosageSeed-class +setMethod("dimnames", "GenotypeDosageSeed", function(x) x@dn) + +#' @rdname GenotypeDosageSeed-class +#' @importFrom S4Arrays extract_array +setMethod("extract_array", "GenotypeDosageSeed", function(x, index) { + # A NULL index means everything along that dimension, as for GhSeed. + dm <- dim(x) + i <- index[[1L]] %||% seq_len(dm[[1L]]) + j <- index[[2L]] %||% seq_len(dm[[2L]]) + if (length(i) == 0L || length(j) == 0L) { + return(matrix(numeric(0), length(i), length(j))) + } + # Each distinct row and sample is read once, in file order, and the block + # then laid out as asked: DelayedArray may ask in any order, and repeat. + rows <- sort(unique(i)) + samples <- sort(unique(j)) + block <- .gdSeedRead(x, rows, samples) + block[match(i, rows), match(j, samples), drop = FALSE] +}) + +# Internal accessors: GenotypeDosageSeed is not exported, so these add no +# public surface, and they keep the `@` next to the class. +# @noRd +.gdSeedBackend <- function(x) x@backend + +# @noRd +.gdSeedField <- function(x) x@field + +# @noRd +.gdSeedRowRecord <- function(x) x@rowRecord + +# @noRd +.gdSeedRowAllele <- function(x) x@rowAllele + +# @noRd +.gdSeedRecords <- function(x) x@records + +# The dosages of rows `rows` for samples `samples`, both ascending and +# distinct: a length(rows) x length(samples) matrix. A GDS seed's backend is +# GDSArray's, whose methods are there only once its namespace is loaded, +# which reading a saved panel back does not do. +# @noRd +.gdSeedRead <- function(x, rows, samples) { + if (str_starts(.gdSeedField(x), "snpGds|seqArray")) { + loadNamespace("GDSArray") + } + switch( + .gdSeedField(x), + vcfGt = , + vcfDs = .vcfSeedRead(x, rows, samples), + snpGdsSnpOrder = , + snpGdsSampleOrder = .snpGdsSeedRead(x, rows, samples), + seqArrayGt = .seqArrayGtSeedRead(x, rows, samples), + seqArrayDs = .seqArrayDsSeedRead(x, rows, samples), + plinkBed = .plinkBedSeedRead(x, rows, samples) + ) +} + +# The seed cut to rows `keep` (ascending positions), carrying only the +# records those rows read, so a panel cut to a few variants does not carry +# every record of the file. +# @noRd +.gdSeedRows <- function(seed, keep) { + rowRecord <- .gdSeedRowRecord(seed)[keep] + used <- sort(unique(rowRecord)) + methods::initialize( + seed, + rowRecord = match(rowRecord, used), + rowAllele = .gdSeedRowAllele(seed)[keep], + records = .gdSeedRecords(seed)[used], + dn = list(dimnames(seed)[[1L]][keep], dimnames(seed)[[2L]]) + ) +} + +# ---- VCF ------------------------------------------------------------------- + +# The VCF FORMAT field a seed reads. +# @noRd +.vcfSeedFieldName <- function(x) { + if (.gdSeedField(x) == "vcfGt") "GT" else "DS" +} + +# A VCF seed's rows: the records they read are fetched by their ranges, each +# picked out of what its range returns, and the field turned into the +# dosage of each row's ALT allele. +# @noRd +.vcfSeedRead <- function(x, rows, samples) { + recordOfRow <- .gdSeedRowRecord(x)[rows] + wanted <- sort(unique(recordOfRow)) + spans <- .gdSeedRecords(x)[wanted] + queryRanges <- IRanges::reduce(spans) + queryRanges <- `names<-`( + queryRanges, + as.character(seq_along(queryRanges)) + ) + sampleIds <- dimnames(x)[[2L]][samples] + vcf <- VariantAnnotation::readVcf( + .vcfSeedFile(x), + param = VariantAnnotation::ScanVcfParam( + fixed = NA, + info = NA, + geno = .vcfSeedFieldName(x), + samples = sampleIds, + which = queryRanges + ) + ) + returned <- .vcfMatchRecords(spans, queryRanges, vcf, x) + values <- VariantAnnotation::geno(vcf)[[.vcfSeedFieldName(x)]] + picked <- values[ + returned[match(recordOfRow, wanted)], + match(sampleIds, colnames(values)), + drop = FALSE + ] + alleles <- .gdSeedRowAllele(x)[rows] + if (.gdSeedField(x) == "vcfGt") { + return(vcfGtDosageCpp(picked, alleles)) + } + .vcfDsDosage(picked, alleles) +} + +# A fresh VcfFile over the seed's file and index. The one the seed holds is +# not read through directly: one saved with the panel and loaded again would +# carry a stale connection. +# @noRd +.vcfSeedFile <- function(x) { + file <- .gdSeedBackend(x) + VariantAnnotation::VcfFile(path(file), index = Rsamtools::index(file)) +} + +# Which row of `vcf` holds each record of `spans`. +# +# A range returns every record overlapping it, so a record is not simply the +# n-th row returned. Each record lies in exactly one of the disjoint +# `queryRanges`, and that range returns every record starting at the +# record's position, in file order; so the record is the row from its range +# that starts at its position with its rank there, which `posRank` recorded +# when the panel was read. Matching on integers keeps the seed free of a +# string per record. +# @noRd +.vcfMatchRecords <- function(spans, queryRanges, vcf, x) { + got <- SummarizedExperiment::rowRanges(vcf) + have <- tibble( + range = as.integer(as.character(got$paramRangeID)), + start = as.integer(start(got)) + ) |> + mutate( + rank = row_number(), + .by = all_of(c("range", "start")) + ) + want <- tibble( + range = findOverlaps(spans, queryRanges, select = "first"), + start = as.integer(start(spans)), + rank = as.integer(S4Vectors::mcols(spans)$posRank) + ) + hit <- vctrs::vec_match(want, have) + if (anyNA(hit)) { + abort(c( + glue( + "{path(.gdSeedBackend(x))} no longer holds the records the ", + "panel read from it." + ), + i = "Read it again with readGenotypes()." + )) + } + hit +} + +# The dosage of each row's ALT allele from a block of FORMAT/DS values: one +# value per ALT allele (Number=A, list cells), or one per record (Number=1), +# which is then its first ALT allele's. A row asking for an allele the +# record holds no value for is missing. +# @noRd +.vcfDsDosage <- function(values, alleles) { + if (!is.list(values)) { + return(unname(`[<-`(values, alleles != 1L, , value = NA_real_))) + } + # A list keeps its dim through as.vector(); drop it to walk the cells. + cells <- `dim<-`(values, NULL) + nValues <- lengths(cells) + allele <- rep(alleles, times = ncol(values)) + held <- allele <= nValues + dosage <- rep(NA_real_, length(cells)) + if (any(held)) { + flat <- as.numeric(list_c(cells)) + at <- cumsum(nValues) - nValues + allele + dosage <- replace(dosage, held, flat[at[held]]) + } + matrix(dosage, nrow = nrow(values)) +} + +# ---- SNPRelate GDS --------------------------------------------------------- + +# A SNPRelate GDS stores genotype codes 0-2 counting the first of a SNP's two +# alleles, which is therefore A1, and 3 for a missing call. +# @noRd +.snpGdsSeedRead <- function(x, rows, samples) { + variant <- start(.gdSeedRecords(x))[.gdSeedRowRecord(x)[rows]] + codes <- if (.gdSeedField(x) == "snpGdsSnpOrder") { + extract_array(.gdSeedBackend(x), list(variant, samples)) + } else { + t(extract_array(.gdSeedBackend(x), list(samples, variant))) + } + replace(`storage.mode<-`(codes, "double"), codes == 3L, NA_real_) +} + +# ---- SeqArray GDS ---------------------------------------------------------- + +# A SeqArray GDS stores each call's allele indices (0 for REF, k for the +# k-th ALT allele) in 2-bit planes, ploidy x samples x planes: one plane per +# record, or more for a record with too many alleles for one, its index then +# the planes' sum weighted by 1, 4, 16, .... A missing allele sets every bit +# of the record's planes. A call with a missing allele is missing, as +# SeqArray's own dosages read it. +# @noRd +.seqArrayGtSeedRead <- function(x, rows, samples) { + recordOfRow <- .gdSeedRowRecord(x)[rows] + wanted <- sort(unique(recordOfRow)) + planes <- .gdSeedRecords(x)[wanted] + bits <- extract_array( + .gdSeedBackend(x), + list(NULL, samples, sequence(width(planes), start(planes))) + ) + last <- cumsum(width(planes)) + calls <- map2( + last - width(planes) + 1L, + width(planes), + .seqArrayRecordCalls, + bits = bits + ) + copies <- map2( + calls[match(recordOfRow, wanted)], + .gdSeedRowAllele(x)[rows], + .seqArrayCopies + ) + matrix(list_c(copies), nrow = length(rows), byrow = TRUE) +} + +# One record's allele indices, ploidy x samples, from its `n` planes starting +# at plane `first` of `bits`; NA where an allele is missing. +# @noRd +.seqArrayRecordCalls <- function(first, n, bits) { + weighted <- map( + seq_len(n), + .seqArrayPlaneValue, + first = first, + bits = bits + ) + value <- reduce(weighted, `+`) + replace(value, value == 4^n - 1, NA) +} + +# Plane `k` of a record whose planes start at `first`, weighted by its place. +# @noRd +.seqArrayPlaneValue <- function(k, first, bits) { + plane <- matrix(bits[,, first + k - 1L], nrow = dim(bits)[[1L]]) + plane * 4^(k - 1L) +} + +# The copies of ALT allele `allele` in each sample's call; NA for a call with +# a missing allele. +# @noRd +.seqArrayCopies <- function(calls, allele) { + colSums(calls == allele) +} + +# A SeqArray GDS stores FORMAT/DS as samples x values, each record's values +# in consecutive columns: one per ALT allele (Number=A), or one (Number=1), +# which is then its first ALT allele's. A missing value is stored as NaN. +# @noRd +.seqArrayDsSeedRead <- function(x, rows, samples) { + spans <- .gdSeedRecords(x)[.gdSeedRowRecord(x)[rows]] + alleles <- .gdSeedRowAllele(x)[rows] + column <- start(spans) + alleles - 1L + held <- alleles <= width(spans) + missing <- matrix(NA_real_, length(rows), length(samples)) + if (!any(held)) { + return(missing) + } + columns <- sort(unique(column[held])) + values <- t(extract_array(.gdSeedBackend(x), list(samples, columns))) + dosage <- `[<-`( + missing, + held, + , + value = values[match(column[held], columns), , drop = FALSE] + ) + replace(dosage, is.nan(dosage), NA_real_) +} + +# ---- PLINK1 ---------------------------------------------------------------- + +# A PLINK1 .bed stores 2-bit genotype codes SNP by SNP. PlinkMatrix reads them +# as the copies of each variant's A1 allele -- the .bim's fifth column, as +# pecotmr counts it -- with NA for a missing call. It is not told the sample +# count: it counts the .fam itself, and a wrong count would misread silently. +# The stem may be a bundled example's portable reference, resolved here. +# @noRd +.plinkBedSeedRead <- function(x, rows, samples) { + variant <- start(.gdSeedRecords(x))[.gdSeedRowRecord(x)[rows]] + PlinkMatrix::read_bed_subset( + .resolveGenotypeResourcePath(.gdSeedBackend(x)), + variant, + samples + ) +} diff --git a/R/GenotypeHandle.R b/R/GenotypeHandle.R index c424eb36c..133fe4418 100644 --- a/R/GenotypeHandle.R +++ b/R/GenotypeHandle.R @@ -1,9 +1,11 @@ # ============================================================================= # GenotypeHandle S4 class # ----------------------------------------------------------------------------- -# Lazy file handle for genotype data (PLINK1, PLINK2, VCF/BCF, GDS). Opens -# the file for metadata only (sample IDs and SNP info); dosage extraction -# is deferred until extractBlockGenotypes() is called. +# Lazy file handle for genotype data (PLINK2, BGEN). Opens the file for +# metadata only (sample IDs and SNP info); dosage extraction is deferred until +# extractBlockGenotypes() is called. A VCF, GDS or PLINK1 file is read as a +# panel directly, through a GenotypeDosageSeed (genotypeIo.R), not through a +# handle. # ============================================================================= #' @include AllGenerics.R @@ -11,13 +13,13 @@ NULL #' @title Genotype File Handle #' @description S4 container holding a path + format + metadata for lazy -#' genotype access. Supports PLINK1 (.bed/.bim/.fam), PLINK2 -#' (.pgen/.pvar/.psam), VCF/BCF, and GDS. +#' genotype access. Supports PLINK2 (.pgen/.pvar/.psam) and BGEN (.bgen +#' with its .bgi index); a VCF, GDS or PLINK1 file is read as a panel by +#' \code{readGenotypes()} without one. #' @slot path Character, file path. For a one-file-per-chromosome handle this is #' the chrom-meta file path (a display/provenance value); the per-chromosome #' payload files live in \code{chromPaths}. -#' @slot format Character, one of \code{"plink1"}, \code{"plink2"}, -#' \code{"vcf"}, \code{"gds"}. +#' @slot format Character, \code{"plink2"} or \code{"bgen"}. #' @slot snpInfo data.frame, SNP metadata read from the index/sidecar. For a #' sharded handle this is the union across chromosomes (row-bound in the order #' the shards were supplied), so \code{snpIdx} stays a single global index @@ -49,7 +51,7 @@ setClass( chromPaths = character(0) ), validity = function(object) { - validFormats <- c("gds", "vcf", "plink1", "plink2") + validFormats <- c("plink2", "bgen") nm <- names(object@chromPaths) badChromPaths <- length(object@chromPaths) > 0L && (is.null(nm) || any(str_length(nm) == 0L) || anyDuplicated(nm)) @@ -100,54 +102,51 @@ setMethod("show", "GenotypeHandle", function(object) { #' forms. Exactly one of the following must be specified: #' \describe{ #' \item{\code{path}}{A single file path with a recognized extension: -#' \code{.vcf}, \code{.vcf.gz}, \code{.vcf.bgz}, \code{.bcf}, or -#' \code{.gds}. Format is auto-detected from the extension.} -#' \item{\code{plink1Prefix}}{A path prefix; the constructor appends -#' \code{.bed}, \code{.bim}, and \code{.fam} to locate the triplet.} +#' \code{.bgen} or \code{.pgen}. Format is auto-detected from the +#' extension. A BGEN file needs its \code{.bgi} index beside it, and +#' its sample ids in the file or in a \code{.sample} file beside it. A +#' VCF, GDS or PLINK1 file is refused: it is read as a panel by +#' \code{readGenotypes()}.} #' \item{\code{plink2Prefix}}{A path prefix; the constructor appends #' \code{.pgen}, \code{.pvar} (or \code{.pvar.zst}), and \code{.psam} #' to locate the triplet.} -#' \item{\code{bed} + \code{bim} + \code{fam}}{Explicit PLINK1 triplet. -#' The three files must share a stem; if they don't, use -#' \code{plink1Prefix} or arrange symlinks at a common stem.} #' \item{\code{pgen} + \code{pvar} + \code{psam}}{Explicit PLINK2 -#' triplet. Same shared-stem requirement.} +#' triplet. The three files must share a stem; if they don't, use +#' \code{plink2Prefix} or arrange symlinks at a common stem.} #' \item{\code{genoMeta}}{One genotype file per chromosome. Either a path #' to a whitespace/TSV meta file whose first column is the chromosome #' (\code{#chr}) and second column the per-chromosome payload -#' (a \code{.bed}/\code{.pgen}/\code{.vcf[.gz]}/\code{.bcf}/\code{.gds} -#' file or a PLINK prefix; relative paths resolve against the meta -#' file's directory), or a named character vector mapping chromosome to -#' payload. All shards must share one format and identical sample IDs in -#' the same order. Extraction is routed to the correct file by the -#' requested region's chromosome.} +#' (a \code{.pgen}/\code{.bgen} file or a PLINK2 prefix; +#' relative paths resolve against the meta file's directory), or a +#' named character vector mapping chromosome to payload. All shards +#' must share one format and identical sample IDs in the same order. +#' Extraction is routed to the correct file by the requested region's +#' chromosome.} #' } #' The constructor opens the file for metadata only (sample IDs and SNP #' info); dosage extraction is deferred until \code{extractBlockGenotypes()} #' is called. #' -#' @param path Single file path (.vcf/.vcf.gz/.vcf.bgz/.bcf/.gds), or -#' \code{NULL}. -#' @param plink1Prefix Path prefix for a PLINK1 triplet, or \code{NULL}. +#' @param path Single file path (.bgen/.pgen), or \code{NULL}. #' @param plink2Prefix Path prefix for a PLINK2 triplet, or \code{NULL}. -#' @param bed,bim,fam Explicit paths to the PLINK1 triplet, or all \code{NULL}. #' @param pgen,pvar,psam Explicit paths to the PLINK2 triplet, or all #' \code{NULL}. #' @param ldMeta Path to an LD-meta TSV file (columns \code{chrom}, #' \code{start}, \code{end}, \code{path}; the \code{path} column may be #' comma-separated as \code{ld_file,bim_file}). Requires \code{region}. The #' constructor resolves the row covering \code{region}, then delegates to the -#' appropriate file-based handler. When the resolved row points at PLINK1 / -#' PLINK2 / VCF / GDS files, the corresponding reader is used; \code{.cor.xz} -#' (pre-computed LD-matrix) rows are not supported here -- use -#' \code{\link{loadLdMatrix}} for that case. +#' appropriate file-based handler. When the resolved row points at PLINK2 +#' or BGEN files, the corresponding reader is used; a row pointing +#' at a pre-computed LD matrix (\code{.cor.xz}) is refused, as pecotmr reads +#' no pre-computed LD from disk -- wrap such a matrix in an +#' \code{\link{LdMatrix}} instead. #' @param region Region specification for \code{ldMeta} lookup: #' \code{"chr:start-end"} string or a one-row data.frame with \code{chrom}, #' \code{start}, \code{end}. #' @param genoMeta One-file-per-chromosome specification: a path to a #' \code{#chr,path} meta file or a named character vector (names = #' chromosomes, values = payload paths/prefixes). Optionally pass -#' \code{format} via \code{...} to force a single backend for every shard. +#' \code{format} to force a single backend for every shard. #' @param chroms Optional character vector of chromosomes. With \code{genoMeta} #' (a sharded, one-file-per-chromosome panel) only the shards whose chromosome #' is listed are read, skipping the rest -- an I/O optimisation when the panel @@ -157,18 +156,15 @@ setMethod("show", "GenotypeHandle", function(object) { #' shard is read (so the caller's own absence check can report the mismatch). #' Only meaningful with \code{genoMeta}; supplying it with any other source is #' an error (a single-file panel has no per-chromosome shards to skip). -#' @param vcfArgs Optional named list of arguments forwarded to -#' \code{VariantAnnotation::readVcf} when the source is a VCF. +#' @param format Character, \code{"plink2"} or \code{"bgen"}, forcing the +#' backend of \code{path} or of every \code{genoMeta} shard. If NULL, +#' inferred from the file extension. #' @return A \code{GenotypeHandle} object. #' @keywords internal #' @rdname GenotypeHandle-class GenotypeHandle <- function( path = NULL, - plink1Prefix = NULL, plink2Prefix = NULL, - bed = NULL, - bim = NULL, - fam = NULL, pgen = NULL, pvar = NULL, psam = NULL, @@ -176,13 +172,12 @@ GenotypeHandle <- function( region = NULL, genoMeta = NULL, chroms = NULL, - format = NULL, - vcfArgs = list() + format = NULL ) { flags <- .ghValidateArgs( - bed = bed, - bim = bim, - fam = fam, + bed = NULL, + bim = NULL, + fam = NULL, pgen = pgen, pvar = pvar, psam = psam, @@ -191,28 +186,20 @@ GenotypeHandle <- function( ) sources <- .ghResolveSources( path = path, - plink1Prefix = plink1Prefix, + plink1Prefix = NULL, plink2Prefix = plink2Prefix, ldMeta = ldMeta, genoMeta = genoMeta, chroms = chroms, flags = flags ) - # .ghResolveSources() has already enforced that exactly one is TRUE, so - # the chosen name is well defined and the switch is total. switch( names(sources)[which(sources)], - path = .readGenotypeHandle(path, format = format, vcfArgs = vcfArgs), - plink1Prefix = .makePlink1Handle(plink1Prefix), + path = .readGenotypeHandle(path, format = format), plink2Prefix = .makePlink2Handle(plink2Prefix), - plink1Triplet = .genotypeHandleFromPlink1Triplet(bed, bim, fam), plink2Triplet = .genotypeHandleFromPlink2Triplet(pgen, pvar, psam), - ldMeta = .genotypeHandleFromLdMeta(ldMeta, region, vcfArgs = vcfArgs), - genoMeta = .genotypeHandleFromChromMeta( - genoMeta, - chroms = chroms, - format = format - ) + ldMeta = .genotypeHandleFromLdMeta(ldMeta, region), + genoMeta = .genotypeHandleFromChromMeta(genoMeta, chroms, format) ) } @@ -250,7 +237,8 @@ GenotypeHandle <- function( } # Build the exactly-one-source indicator vector; error unless exactly one input -# source was supplied, and gate `chroms` to the genoMeta path. +# source was supplied, and gate `chroms` to the genoMeta path. Because exactly +# one entry is TRUE, GenotypeHandle()'s switch on its name is total. # @noRd .ghResolveSources <- function( path, @@ -290,9 +278,8 @@ GenotypeHandle <- function( sources } -.genotypeHandleFromLdMeta <- function(ldMeta, region, vcfArgs = list()) { - ldPath <- .ghResolveLdPath(ldMeta, region) - .ghLdPathToHandle(ldPath, vcfArgs = vcfArgs) +.genotypeHandleFromLdMeta <- function(ldMeta, region) { + .ghLdPathToHandle(.ghResolveLdPath(ldMeta, region)) } # Resolve the single genotype-payload path for `region` from an LD meta, @@ -303,7 +290,7 @@ GenotypeHandle <- function( if (length(ldPaths) == 0L) { regionStr <- deparse(region) msg <- glue( - "GenotypeHandle: no LD-meta row covers region {regionStr} ", + "ldMeta: no LD-meta row covers region {regionStr} ", "in {ldMeta}." ) abort(msg) @@ -311,10 +298,9 @@ GenotypeHandle <- function( if (length(ldPaths) > 1L) { regionStr <- deparse(region) msg <- glue( - "GenotypeHandle: region {regionStr} spans multiple LD-meta ", - "rows; the GenotypeHandle constructor only resolves single-row ", - "regions. Use loadLdMatrix() for multi-row regions, or restrict ", - "the region to a single LD block." + "ldMeta: region {regionStr} spans multiple LD-meta rows; ", + "only a region within one row is resolved. Restrict the region ", + "to a single LD block." ) abort(msg) } @@ -322,53 +308,49 @@ GenotypeHandle <- function( if (str_detect(ldPath, regex("\\.cor(\\.xz)?$", ignore_case = TRUE))) { regionStr <- deparse(region) msg <- glue( - "GenotypeHandle: the LD-meta row for region {regionStr} points ", - "at a pre-computed correlation matrix ({ldPath}). Use ", - "loadLdMatrix() for .cor.xz inputs; ", - "GenotypeHandle accepts only genotype payloads (VCF/GDS/PLINK)." + "ldMeta: the LD-meta row for region {regionStr} points at a ", + "pre-computed correlation matrix ({ldPath}). pecotmr does not ", + "read pre-computed LD from disk; wrap the matrix in an LdMatrix ", + "instead. An LD-meta row names genotypes (VCF/GDS/BGEN/PLINK)." ) abort(msg) } ldPath } -# Dispatch a resolved genotype path to the format-specific reader by extension. +# The handle of the genotype file or PLINK prefix an LD-meta row names, for a +# format a GenotypeHandle reads. # @noRd -.ghLdPathToHandle <- function(ldPath, vcfArgs = list()) { - lower <- str_to_lower(ldPath) - if (str_detect(lower, "\\.vcf(\\.b?gz)?$") || str_ends(lower, "\\.bcf")) { - return(.readGenotypeHandle(ldPath, format = "vcf", vcfArgs = vcfArgs)) - } - if (str_ends(lower, "\\.gds")) { - return(.readGenotypeHandle(ldPath, format = "gds")) - } - if (str_ends(lower, "\\.bed")) { - return(.makePlink1Handle( - str_remove(ldPath, regex("\\.bed$", ignore_case = TRUE)) - )) - } - if (str_ends(lower, "\\.pgen")) { - return(.makePlink2Handle( - str_remove(ldPath, regex("\\.pgen$", ignore_case = TRUE)) - )) - } - msg <- glue( - "GenotypeHandle: unsupported LD-meta file extension on ", - "'{ldPath}'. Expected one of ", - ".vcf/.vcf.gz/.vcf.bgz/.bcf/.gds/.bed/.pgen." +.ghLdPathToHandle <- function(ldPath) { + .readGenotypeHandle( + ldPath, + format = .requireGenotypeFormat(ldPath, "ldMeta") + ) +} + +# The panel of the genotype file or PLINK prefix an LD-meta row names, in any +# format. +# @noRd +.ghLdPathToPanel <- function(ldPath, vcfArgs = list()) { + .readGenotypePanel( + ldPath, + format = .requireGenotypeFormat(ldPath, "ldMeta"), + vcfArgs = vcfArgs ) - abort(msg) } +# The stem the three files of a PLINK1 triplet share, which is how its panel +# is read. +# @noRd #' @importFrom checkmate assertString -.genotypeHandleFromPlink1Triplet <- function(bed, bim, fam) { +.plink1TripletStem <- function(bed, bim, fam) { assertString(bed) assertString(bim) assertString(fam) stems <- c( - bed = file_path_sans_ext(bed), - bim = file_path_sans_ext(bim), - fam = file_path_sans_ext(fam) + bed = .genotypeStem(bed), + bim = .genotypeStem(bim), + fam = .genotypeStem(fam) ) if (n_distinct(stems) != 1L) { stemList <- str_c(" ", names(stems), ": ", stems, collapse = "\n") @@ -382,7 +364,7 @@ GenotypeHandle <- function( ) abort(msg) } - .makePlink1Handle(unname(stems[1L])) + unname(stems[1L]) } .genotypeHandleFromPlink2Triplet <- function(pgen, pvar, psam) { @@ -391,11 +373,10 @@ GenotypeHandle <- function( abort("Each of `pgen`, `pvar`, `psam` must be a single file path.") } } - pvarStem <- str_remove(pvar, regex("\\.zst$", ignore_case = TRUE)) stems <- c( - pgen = file_path_sans_ext(pgen), - pvar = file_path_sans_ext(pvarStem), - psam = file_path_sans_ext(psam) + pgen = .genotypeStem(pgen), + pvar = .genotypeStem(pvar), + psam = .genotypeStem(psam) ) if (n_distinct(stems) != 1L) { stemList <- str_c(" ", names(stems), ": ", stems, collapse = "\n") @@ -447,7 +428,7 @@ GenotypeHandle <- function( if (length(multi) > 0L) { multiStr <- str_flatten(multi, ", ") msg <- glue( - "GenotypeHandle(genoMeta): chromosome(s) {multiStr} map to ", + "genoMeta: chromosome(s) {multiStr} map to ", "multiple genotype payloads; each chromosome must map to ", "exactly one payload (no sub-chromosomal blocks)." ) @@ -480,7 +461,7 @@ GenotypeHandle <- function( ))) } msg <- glue( - "GenotypeHandle(genoMeta): expected a path to a `#chr,path` meta ", + "genoMeta: expected a path to a `#chr,path` meta ", "file or a named character vector (names = chromosomes, ", "values = paths)." ) @@ -508,7 +489,7 @@ GenotypeHandle <- function( ) if (ncol(meta) < 2L) { msg <- glue( - "GenotypeHandle(genoMeta): meta file '{genoMeta}' must have ", + "genoMeta: meta file '{genoMeta}' must have ", "at least 2 columns (chromosome, path)." ) abort(msg) @@ -536,51 +517,50 @@ GenotypeHandle <- function( map_chr(pth, .ghResolvePath, base = base) } -# Build a single-file GenotypeHandle for one shard payload, dispatching to the -# right reader. `format` (optional) forces a backend; otherwise it is detected -# from the file extension, falling back to PLINK prefix probing. +# The format of one shard payload: `format` when it is forced, else told by +# the file extension, falling back to probing a PLINK prefix's sidecars. +# Nothing is read, so a set's shards can be checked to share one format +# before any of them is. +# @noRd +.shardFormat <- function(p, format = NULL) { + format %||% .requireGenotypeFormat(p, "genoMeta") +} + +# Build a single-file GenotypeHandle for one shard payload, of a format a +# handle reads. `format` (optional) forces a backend; otherwise it is detected +# as .shardFormat() detects it. #' @keywords internal .resolveGenotypeShard <- function(p, format = NULL) { - lower <- str_to_lower(p) - if (!is.null(format)) { - if (format == "plink1") { - return(.makePlink1Handle(p)) - } - if (format == "plink2") { - return(.makePlink2Handle(p)) - } - return(.readGenotypeHandle(p, format = format)) - } - if (str_detect(lower, "\\.vcf(\\.b?gz)?$") || str_ends(lower, "\\.bcf")) { - return(.readGenotypeHandle(p, format = "vcf")) - } - if (str_ends(lower, "\\.gds")) { - return(.readGenotypeHandle(p, format = "gds")) - } - if (str_ends(lower, "\\.bed")) { - return(.makePlink1Handle( - str_remove(p, regex("\\.bed$", ignore_case = TRUE)) - )) + .readGenotypeHandle(p, format = .shardFormat(p, format)) +} + +# The panel of a per-chromosome meta. A VCF, GDS or PLINK1 set is its +# shards' panels stacked (.stackDosagePanels()); a set in a format a handle +# reads, one sharded handle's panel. `chroms` (optional) restricts the read +# to the shards for those chromosomes, as for .genotypeHandleFromChromMeta(). +# @noRd +.chromMetaPanel <- function(genoMeta, chroms = NULL, format = NULL) { + parsed <- .parseChromMeta(genoMeta) + if (nrow(parsed) == 0L) { + abort( + "genoMeta: no chromosomes found in the meta input." + ) } - if (str_ends(lower, "\\.pgen")) { - return(.makePlink2Handle( - str_remove(p, regex("\\.pgen$", ignore_case = TRUE)) + selected <- .chromMetaSelect(parsed, chroms) + formats <- map_chr(selected$path, .shardFormat, format = format) + shared <- .chromMetaCheckFormats(formats) + if (!is_in(shared, .DOSAGE_PANEL_FORMATS)) { + return(.genotypeExperiment( + .genotypeHandleFromChromMeta(genoMeta, chroms, format) )) } - # No recognized extension: treat as a PLINK prefix, probe for the sidecar. - if (file.exists(str_c(p, ".bed"))) { - return(.makePlink1Handle(p)) - } - if (file.exists(str_c(p, ".pgen"))) { - return(.makePlink2Handle(p)) - } - msg <- glue( - "GenotypeHandle(genoMeta): cannot determine genotype format for ", - "'{p}'. Use a recognized extension ", - "(.bed/.pgen/.vcf[.gz]/.bcf/.gds), a PLINK prefix, or pass ", - "`format=`." - ) - abort(msg) + panels <- map2(selected$path, formats, .readDosagePanel) + .withSourceProjection(.stackDosagePanels( + panels, + shared, + .chromMetaPath(genoMeta), + selected$path + )) } # Assemble a sharded handle from a per-chromosome meta. Reads each shard's @@ -599,12 +579,12 @@ GenotypeHandle <- function( parsed <- .parseChromMeta(genoMeta) if (nrow(parsed) == 0L) { abort( - "GenotypeHandle(genoMeta): no chromosomes found in the meta input." + "genoMeta: no chromosomes found in the meta input." ) } selected <- .chromMetaSelect(parsed, chroms) shards <- map(selected$path, .resolveGenotypeShard, format = format) - sharedFormat <- .chromMetaCheckFormats(shards) + sharedFormat <- .chromMetaCheckFormats(map_chr(shards, .ghFormat)) .chromMetaCheckSamples(shards, selected) unifiedSnpInfo <- bind_rows(map(shards, .ghSnpInfo)) new( @@ -635,14 +615,13 @@ GenotypeHandle <- function( if (any(keep)) filter(parsed, keep) else parsed } -# Require a single shared format across shards; returns it. +# Require a single shared format across shards' `formats`; returns it. # @noRd -.chromMetaCheckFormats <- function(shards) { - formats <- map_chr(shards, .ghFormat) +.chromMetaCheckFormats <- function(formats) { if (n_distinct(formats) != 1L) { formatStr <- str_flatten(unique(formats), ", ") msg <- glue( - "GenotypeHandle(genoMeta): all per-chromosome files must share ", + "genoMeta: all per-chromosome files must share ", "one format; got: {formatStr}." ) abort(msg) @@ -658,7 +637,7 @@ GenotypeHandle <- function( if (!identical(shards[[i]]@sampleIds, sample0)) { mismatchPath <- parsed$path[[i]] msg <- glue( - "GenotypeHandle(genoMeta): all per-chromosome files must ", + "genoMeta: all per-chromosome files must ", "have identical sample IDs in the same order (mismatch ", "at '{mismatchPath}')." ) @@ -683,7 +662,7 @@ GenotypeHandle <- function( return(invisible(NULL)) } msg <- glue( - "GenotypeHandle(genoMeta): chromosome '{ch}' appears ", + "genoMeta: chromosome '{ch}' appears ", "in more than one per-chromosome file." ) abort(msg) diff --git a/R/GenotypeMixture.R b/R/GenotypeMixture.R new file mode 100644 index 000000000..196e84ef3 --- /dev/null +++ b/R/GenotypeMixture.R @@ -0,0 +1,526 @@ +# ============================================================================= +# GenotypeMixture S4 class +# ----------------------------------------------------------------------------- +# A mixture of genotype panels used as one LD reference: a +# MultiAssayExperiment with one experiment per cohort, that cohort's panel. +# Its LD is the weighted average of the panels' LD, sum_k w_k R_k. The panels +# stay as they are -- lazy, on disk -- and are combined only when a step +# reads LD for some variants, so each keeps answering for its own samples: +# allele frequencies, sample size, missingness. +# ============================================================================= + +#' @include AllGenerics.R +NULL + +#' @title Mixture of Genotype Panels +#' @description A \code{GenotypeMixture} uses several genotype panels (see +#' \code{\link{readGenotypes}}) as one LD reference whose LD is the +#' weighted average of theirs, \eqn{\sum_k w_k R_k}. That is the LD of +#' summary statistics meta-analysed across cohorts, with each cohort's +#' weight its share of the GWAS sample size. +#' +#' Unlike an \code{\link{LdMatrix}} mixture, which is combined once when it +#' is built, the panels stay lazy and on disk: LD is read from each and +#' combined only for the variants a step asks about, and every panel keeps +#' answering for its own samples. A step that needs allele frequencies, +#' missingness or minor-allele counts judges each panel on its own and +#' drops a variant that fails in any of them. +#' +#' It \strong{is} a \code{MultiAssayExperiment} with one experiment per +#' cohort: that cohort's genotype panel, cut to the variants every panel +#' carries, in the first panel's order. The mixture's variants, as +#' \code{\link{variantIds}} gives them, are the first panel's. Each panel +#' keeps its own samples and allele coding, and its \code{rowData} column +#' \code{mixtureSign} is \code{1} where it codes a variant's alleles as the +#' first panel does and \code{-1} where it codes them the other way round. +#' The \code{sampleMap} names each sample \code{_}, since +#' cohorts can reuse sample ids, and the weights are +#' \code{metadata(x)$mixtureWeights} (see \code{\link{mixtureWeights}}). +#' +#' Row subsetting, \code{x[i, ]} by position, variant id or \code{GRanges}, +#' cuts every panel to the same variants, and column subsetting narrows +#' the panels' samples. A panel cannot be dropped, since the weights +#' describe all of them: build a new \code{GenotypeMixture} over the panels +#' wanted instead. +#' @seealso \code{\link{GenotypeMixture}} to build one, \code{\link{LdMatrix}}. +#' @importClassesFrom MultiAssayExperiment MultiAssayExperiment +#' @export +setClass("GenotypeMixture", contains = "MultiAssayExperiment") + +setValidity("GenotypeMixture", function(object) { + problems <- .gmCheckComponents(object) + if (length(problems) == 0L) { + problems <- c(.gmCheckSign(object), .gmCheckWeights(object)) + } + if (length(problems) == 0L) TRUE else problems +}) + +# @noRd +.gmCheckComponents <- function(object) { + comps <- .gmComponents(object) + if (length(comps) < 2L || !all(map_lgl(comps, .gmIsPanel))) { + return("the experiments must be at least two genotype panels.") + } + if (length(unique(map_int(comps, nrow))) != 1L) { + return("every panel must hold exactly the mixture's variants.") + } + character() +} + +# A panel as a mixture holds it: the RSE readGenotypes() returns. +# @noRd +.gmIsPanel <- function(x) { + methods::is(x, "RangedSummarizedExperiment") +} + +# @noRd +.gmCheckSign <- function(object) { + signs <- map(.gmComponents(object), .gmComponentSign) + if (all(map_lgl(signs, .gmIsSign)) && all(signs[[1L]] == 1)) { + return(character()) + } + str_c( + "every panel's rowData must carry `mixtureSign`, +1 or -1 per ", + "variant, and the first panel's must be all +1." + ) +} + +# @noRd +.gmIsSign <- function(s) { + !is.null(s) && all(is_in(s, c(-1, 1))) +} + +# @noRd +.gmCheckWeights <- function(object) { + w <- mixtureWeights(object) + named <- identical(names(w), names(.gmComponents(object))) + c( + .ldmCheckWeights(w), + if (length(w) == 0L || !named) { + "`mixtureWeights` must hold one weight per panel, named after it." + } + ) +} + +#' @title Build a GenotypeMixture +#' @description Combine genotype panels into one LD reference whose LD is +#' the weighted average of theirs. See \code{\link{GenotypeMixture-class}}. +#' +#' The panels are matched by position and alleles and put into the first +#' panel's allele coding, so they need not share variant ids or allele +#' orientation. The mixture covers the variants every panel carries; a +#' variant some panel lacks is left out, with a message. +#' @param panels A named list of at least two genotype panels (see +#' \code{\link{readGenotypes}}). The names are the cohorts: they name the +#' mixture's experiments and prefix its samples. +#' @param mixtureWeights One non-negative weight per panel, summing to 1; +#' typically each cohort's share of the GWAS sample size. Matched to the +#' panels by name when named, by position otherwise. +#' @return A \code{GenotypeMixture}. +#' @examples +#' panel <- readGenotypes(plink2Prefix = file.path(system.file("extdata", +#' "ld_reference", "chr22", package = "pecotmr"), +#' "protocol_example.LD.chr22")) +#' half <- seq_len(ncol(panel) / 2) +#' mix <- GenotypeMixture(list(EUR = panel[, half], AFR = panel[, -half]), +#' mixtureWeights = c(EUR = 0.7, AFR = 0.3)) +#' mix +#' @rdname GenotypeMixture-constructor +#' @importFrom MultiAssayExperiment MultiAssayExperiment +#' @export +GenotypeMixture <- function(panels, mixtureWeights) { + .gmAssertPanels(panels) + panels <- map(panels, .asLdRef) + if (!all(map_lgl(panels, .gmIsPanel))) { + abort("Every element of `panels` must be a genotype panel.") + } + w <- .gmNamedWeights(mixtureWeights, names(panels)) + ref <- panels[[1L]] + matched <- map(panels, .ldmMatchTo, ref = ref) + common <- sort(reduce(map(matched, "refIdx"), intersect)) + if (length(common) == 0L) { + abort("The genotype panels share no variant to combine over.") + } + .ldmReportDropped( + length(.ldRefRanges(ref)) - length(common), + length(common), + what = "GenotypeMixture" + ) + aligned <- map(matched, .ldmAlignedOn, common = common) + experiments <- map2(panels, aligned, .gmAlignedComponent) + mae <- MultiAssayExperiment( + experiments = experiments, + colData = .gmColData(experiments), + sampleMap = .gmSampleMap(experiments), + metadata = list(mixtureWeights = w) + ) + obj <- methods::new("GenotypeMixture", mae) + validObject(obj) + obj +} + +# @noRd +.gmAssertPanels <- function(panels) { + if (!is.list(panels) || length(panels) < 2L) { + abort("`panels` must be a list of at least two genotype panels.") + } + nms <- names(panels) + if (is.null(nms) || anyNA(nms) || any(!nzchar(nms)) || anyDuplicated(nms)) { + abort(c( + str_c( + "`panels` must be a named list: each name is a cohort, which ", + "names its experiment and prefixes its samples." + ), + i = "For example, list(EUR = eurPanel, AFR = afrPanel)." + )) + } + invisible(NULL) +} + +# The weights, one per panel and named after it: matched by name when they +# are named, by position otherwise. +# @noRd +.gmNamedWeights <- function(mixtureWeights, cohorts) { + given <- names(mixtureWeights) + w <- .ldmAssertWeights(mixtureWeights, length(cohorts)) + if (is.null(given)) { + return(set_names(w, cohorts)) + } + if (anyDuplicated(given) || !setequal(given, cohorts)) { + abort(glue( + "Named `mixtureWeights` must name each panel once: ", + "{str_flatten(cohorts, ', ')}." + )) + } + set_names(w, given)[cohorts] +} + +# A panel cut to the shared variants in the first panel's order, recording +# how it codes each one's alleles relative to the first panel. +# @noRd +.gmAlignedComponent <- function(panel, aligned) { + .gmWithSign(.ldRefSubset(panel, aligned$idx), aligned$sign) +} + +# @noRd +.gmWithSign <- function(panel, sign) { + rd <- SummarizedExperiment::rowData(panel) + rd$mixtureSign <- as.numeric(sign) + SummarizedExperiment::`rowData<-`(panel, value = rd) +} + +# The primary name of each of a cohort's samples. Cohorts can reuse sample +# ids, and every stochastic sketch does, so the cohort is part of the name. +# @noRd +.gmPrimaryIds <- function(cohort, ids) { + str_c(cohort, "_", ids) +} + +# One row per sample of every panel, recording its cohort. +# @noRd +.gmColData <- function(experiments) { + exec(rbind, !!!unname(imap(experiments, .gmColDataPart))) +} + +# @noRd +.gmColDataPart <- function(panel, cohort) { + ids <- as.character(colnames(panel)) + S4Vectors::DataFrame( + cohort = rep(cohort, length(ids)), + row.names = .gmPrimaryIds(cohort, ids) + ) +} + +# The sampleMap: each panel's samples under their cohort-prefixed names. +# @noRd +.gmSampleMap <- function(experiments) { + exec(rbind, !!!unname(imap(experiments, .gmSampleMapPart))) +} + +# @noRd +.gmSampleMapPart <- function(panel, cohort) { + ids <- as.character(colnames(panel)) + S4Vectors::DataFrame( + assay = factor(rep(cohort, length(ids)), levels = cohort), + primary = .gmPrimaryIds(cohort, ids), + colname = ids + ) +} + +# ---- subsetting ------------------------------------------------------------- + +# Row subsetting cuts every panel to the same variants. Every subscript is +# turned into positions on the first panel, whose ids and alleles the +# mixture's are, and those positions are applied to all of them: the panels' +# own ids can differ in allele order, so matching each on its own could cut +# them to different variants. +# @noRd +.gmSubsetByRow <- function(x, y, ...) { + .gmRowsAt(x, .gmRowIndex(x, y)) +} + +# Registered for List and list as well as ANY: a GRanges is a List, and for +# either MultiAssayExperiment's own methods would otherwise win the dispatch +# and cut each panel on its own -- a GRanges by overlap with that panel, a +# list by one index per panel, which can leave the panels holding different +# variants. +#' @importFrom MultiAssayExperiment subsetByRow +#' @importClassesFrom S4Vectors List +setMethod("subsetByRow", c("GenotypeMixture", "ANY"), .gmSubsetByRow) +setMethod("subsetByRow", c("GenotypeMixture", "List"), .gmSubsetByRow) +setMethod("subsetByRow", c("GenotypeMixture", "list"), .gmSubsetByRow) + +# The weights describe every panel, so none can be dropped. +#' @importFrom MultiAssayExperiment subsetByAssay +setMethod("subsetByAssay", "GenotypeMixture", function(x, y) { + abort(c( + str_c( + "A GenotypeMixture's panels cannot be subset: its weights ", + "describe all of them." + ), + i = "Build a new GenotypeMixture() over the panels wanted." + )) +}) + +# The positions of the variants a row subscript names: a position, a logical +# mask, a variant id (the first panel's row names) or a GRanges. +# @noRd +#' @importFrom IRanges overlapsAny +.gmRowIndex <- function(x, y) { + ranges <- .gmRanges(x) + if (methods::is(y, "GenomicRanges")) { + return(which(overlapsAny(ranges, y))) + } + if (is.character(y)) { + at <- match(y, names(ranges)) + return(at[!is.na(at)]) + } + if (is.logical(y) || is.numeric(y)) { + return(seq_along(ranges)[y]) + } + abort(str_c( + "A GenotypeMixture's rows are subset by position, logical mask, ", + "variant id or GRanges." + )) +} + +# The mixture with every panel cut to the variants at positions `i`, in +# that order. +# @noRd +#' @importFrom MultiAssayExperiment ExperimentList +.gmRowsAt <- function(x, i) { + comps <- map(.gmComponents(x), .gmComponentRowsAt, i = i) + MultiAssayExperiment::`experiments<-`(x, value = ExperimentList(comps)) +} + +# One panel's rows `i`. With no rows left it is held in memory with its +# samples, which the sampleMap names, so an empty mixture does not carry its +# panels' seeds (see .emptyPanel()). +# @noRd +.gmComponentRowsAt <- function(panel, i) { + sign <- .gmComponentSign(panel)[i] + rows <- if (length(i) == 0L) { + .emptyPanel(panel, keepSamples = TRUE) + } else { + .ldRefSubset(panel, i) + } + .gmWithSign(rows, sign) +} + +# ---- accessors -------------------------------------------------------------- + +#' @rdname mixtureWeights +#' @export +setMethod("mixtureWeights", "GenotypeMixture", function(x) { + S4Vectors::metadata(x)$mixtureWeights +}) + +#' @rdname variantIds +#' @export +setMethod("variantIds", "GenotypeMixture", function(x, ...) { + .ldRefVariantIds(x) +}) + +#' @rdname GenotypeMixture-class +#' @param object A \code{GenotypeMixture}. +#' @export +setMethod("show", "GenotypeMixture", function(object) { + w <- mixtureWeights(object) + comps <- .gmComponents(object) + cat(glue( + "GenotypeMixture: {.gmNVariants(object)} variants from ", + "{length(comps)} genotype panels\n", + .trim = FALSE + )) + cat(glue( + " panels {str_flatten(names(comps), ', ')}; weights ", + "{str_flatten(signif(w, 3), ', ')}; panel sizes ", + "{str_flatten(map_int(comps, ncol), ', ')}\n", + .trim = FALSE + )) +}) + +# ---- the LD reference answers, combined over the panels --------------------- + +# The panels, named after their cohorts. +# @noRd +#' @importFrom MultiAssayExperiment experiments +.gmComponents <- function(x) { + as.list(experiments(x)) +} + +# @noRd +.gmComponentSign <- function(panel) { + SummarizedExperiment::rowData(panel)$mixtureSign +} + +# A +1 / -1 matrix with one row per variant and one column per panel: each +# panel's allele coding relative to the first's. +# @noRd +.gmSign <- function(x) { + exec(cbind, !!!unname(map(.gmComponents(x), .gmComponentSign))) +} + +# The mixture's variants: the first panel's ranges, with the SNP / A1 / A2 +# columns that identify them. +# @noRd +.gmRanges <- function(x) { + rr <- SummarizedExperiment::rowRanges(.gmComponents(x)[[1L]]) + S4Vectors::`mcols<-`( + rr, + value = S4Vectors::mcols(rr)[, c("SNP", "A1", "A2")] + ) +} + +# @noRd +.gmNVariants <- function(x) { + nrow(.gmComponents(x)[[1L]]) +} + +# 1 / sum(w^2 / n_k) over the panels' sizes as `nOf` measures them: the size +# of one panel whose LD would be as noisy as the weighted average. +# @noRd +.gmPooledN <- function(x, nOf) { + n <- map_int(.gmComponents(x), nOf) + as.integer(round(1 / sum(mixtureWeights(x)^2 / n))) +} + +# The mixture's LD among its variants at `idx`: each panel's LD, re-signed +# into the first panel's allele coding, averaged with the weights. One +# panel's block is held at a time. +# @noRd +.gmLdAt <- function(x, idx) { + reduce( + seq_along(.gmComponents(x)), + .gmAddLd, + .init = NULL, + x = x, + idx = idx + ) +} + +# @noRd +.gmAddLd <- function(acc, k, x, idx) { + s <- .gmSign(x)[idx, k] + term <- mixtureWeights(x)[[k]] * + unname(.ldRefLdAt(.gmComponents(x)[[k]], idx)) * + outer(s, s) + if (is.null(acc)) term else acc + term +} + +# Per-variant statistics a panel filter judges, from each panel on its own +# terms: a variant's MAF is its smallest in any panel and its missingness its +# largest, so a cutoff drops a variant that fails in any of them. +# @noRd +.gmVariantStats <- function(x, idx, needMissing, step) { + each <- map( + .gmComponents(x), + .ldRefVariantStats, + idx = idx, + needMissing = needMissing, + step = step + ) + list( + maf = exec(pmin, !!!unname(map(each, "maf"))), + missRate = if (needMissing) exec(pmax, !!!unname(map(each, "missRate"))) + ) +} + +# The mixture's A1 frequency, sum_k w_k p_k with each panel's frequency put +# into the first panel's coding, or NULL unless every panel records one. +# @noRd +.gmAf <- function(x) { + afs <- map(.gmComponents(x), .ldRefAf) + if (any(map_lgl(afs, is.null))) { + return(NULL) + } + signs <- .gmSign(x) + aligned <- map(seq_along(afs), .gmAlignedAf, afs = afs, signs = signs) + reduce(map2(unname(mixtureWeights(x)), aligned, `*`), `+`) +} + +# @noRd +.gmAlignedAf <- function(k, afs, signs) { + if_else(signs[, k] > 0, afs[[k]], 1 - afs[[k]]) +} + +# Per-variant genotype variance averaged over the panels with the weights -- +# the average within-panel variance, which is what the averaged LD describes. +# The variance of the pooled frequency, 2p(1 - p), would also count the +# spread of frequencies between panels, which the mixture LD leaves out. +# @noRd +.gmVariance <- function(x, idx) { + each <- map(.gmComponents(x), .ldRefVariance, idx = idx) + reduce(map2(unname(mixtureWeights(x)), each, `*`), `+`) +} + +# A factor of the mixture's LD over `idx`: each panel's standardized +# dosages, re-signed and scaled by sqrt(w_k / (m_k - 1)), stacked by rows, +# then scaled so the crossproduct is (N - 1) R for N rows -- the same +# convention as a single panel's scaled dosages. Its crossproduct is the +# weighted average of the panels' LD exactly, .gmLdAt()'s. +# @noRd +.gmFactor <- function(x, idx) { + blocks <- map(seq_along(.gmComponents(x)), .gmFactorBlock, x = x, idx = idx) + stacked <- exec( + rbind, + !!!blocks, + !!!map2(blocks, unname(mixtureWeights(x)), .gmMonomorphicRows) + ) + stacked * sqrt(nrow(stacked) - 1) +} + +# A variant monomorphic in a panel has an all-zero column in that panel's +# block, which would leave the mixture's LD short of a unit diagonal. A +# panel's LD treats such a variant as independent of every other (see +# .ldCleanCorrelation()), so in the average it contributes w_k to the +# variant's own variance and nothing else: two rows per such variant, holding +# +/- sqrt(w_k / 2) in its column, so the column keeps a zero mean and an +# engine that centres the factor's rows itself still sees the same LD. +# @noRd +.gmMonomorphicRows <- function(block, w) { + dead <- which(colSums(block^2) == 0) + .ldPaddingRows(dead, ncol(block), sqrt(w / 2)) +} + +# @noRd +.gmFactorBlock <- function(k, x, idx) { + scaled <- .ldRefStandardized(.gmComponents(x)[[k]], idx) + signed <- sweep(scaled, 2L, .gmSign(x)[idx, k], `*`) + signed * sqrt(mixtureWeights(x)[[k]] / (nrow(scaled) - 1)) +} + +# TRUE when two mixtures average the same panels -- the same samples, in the +# same order -- with the same weights. Their variant sets may differ, as two +# QC'd subsets of one mixture's do. +# @noRd +.gmSameMixture <- function(x, y) { + cx <- .gmComponents(x) + cy <- .gmComponents(y) + length(cx) == length(cy) && + isTRUE(all.equal(mixtureWeights(x), mixtureWeights(y))) && + identical( + map(cx, .ldRefSampleIds), + map(cy, .ldRefSampleIds) + ) +} diff --git a/R/GwasFineMappingResult.R b/R/GwasFineMappingResult.R index 1a2aefd9c..db4978363 100644 --- a/R/GwasFineMappingResult.R +++ b/R/GwasFineMappingResult.R @@ -8,7 +8,7 @@ # range -- the genome-wide-across-blocks shape that # qtlEnrichmentPipeline / colocPipeline expect when sweeping a study # across LD blocks. Class-level slots: -# * ldSketch GenotypeHandle for the LD reference; required for the +# * ldReference GenotypeHandle for the LD reference; required for the # LD-block-indexed susieRSS workflow. # Methods that take per-row selectors accept (study, method) and ignore # context/trait (GWAS has no per-tuple context or trait axis). @@ -133,7 +133,7 @@ setClass( #' @param dataSource Optional per-row label for the kind of input the fit saw, #' \code{"individual"} or \code{"sumstat"}. Recorded rather than derived: a #' combined collection can hold rows of both kinds, and its single -#' \code{ldSketch} cannot say which row came from which. +#' \code{ldReference} cannot say which row came from which. #' @param weightStandardized Optional per-row flag: whether the posterior #' effect is on the STANDARDIZED genotype scale. The posterior effect IS the #' prediction weight, so it carries the same scale question as a TWAS @@ -141,7 +141,7 @@ setClass( #' it standardizes genotypes before fitting, and the posterior mean is #' reported on the scale of the \code{X} the fit was given. The argument #' exists for a collection assembled by hand, where only the caller knows. -#' @param ldSketch An optional genotype panel (see +#' @param ldReference An optional genotype panel (see #' \code{\link{readGenotypes}}). #' @param traitPos Optional per-row trait genomic anchor (a \code{GRanges} or #' \code{NULL}), carried forward as provenance; not part of the identity key. @@ -169,7 +169,7 @@ GwasFineMappingResult <- function( dataType = NULL, dataSource = NULL, weightStandardized = NULL, - ldSketch = NULL + ldReference = NULL ) { n <- length(studyName) if (length(method) != n || length(entry) != n) { @@ -200,7 +200,7 @@ GwasFineMappingResult <- function( obj <- new( "GwasFineMappingResult", grl, - ldSketch = .asLdSketch(ldSketch) + ldReference = .asLdRef(ldReference) ) validObject(obj) obj @@ -334,10 +334,10 @@ setMethod("show", "GwasFineMappingResult", function(object) { .trim = FALSE )) } - ldSrc <- if (is.null(object@ldSketch)) { + ldSrc <- if (is.null(object@ldReference)) { "NULL" } else { - .ldSketchLabel(object@ldSketch) + .ldRefLabel(object@ldReference) } - cat(glue(" LD sketch: {ldSrc}\n", .trim = FALSE)) + cat(glue(" LD reference: {ldSrc}\n", .trim = FALSE)) }) diff --git a/R/H2Estimate.R b/R/H2Estimate.R index 104382844..1f162578e 100644 --- a/R/H2Estimate.R +++ b/R/H2Estimate.R @@ -8,6 +8,9 @@ # integration with the sLDSC postprocessing pipeline. # ============================================================================= +#' @include MethodParam.R +NULL + #' @title Heritability Estimate #' @description Container for univariate heritability estimation results. Holds #' global, local, and annotation-stratified estimates. @@ -56,10 +59,10 @@ setClass( estimateSe = "numeric", intercept = "numeric", interceptSe = "numeric", - localBlocks = "ANY", # data.frame or NULL - enrichment = "ANY", # data.frame or NULL - annotationJackknifeCoefs = "ANY", # matrix or NULL - scoreStats = "ANY", # list or NULL + localBlocks = "data.frame_OR_NULL", + enrichment = "data.frame_OR_NULL", + annotationJackknifeCoefs = "matrix_OR_NULL", + scoreStats = "list_OR_NULL", method = "character", nSnps = "integer", traitName = "character" diff --git a/R/JointGroup.R b/R/JointGroup.R index 33404b177..3be7be749 100644 --- a/R/JointGroup.R +++ b/R/JointGroup.R @@ -95,7 +95,11 @@ setClass( # any of them is fitted. The sketch is a lazy panel, so the matrix is # derived once per group at fit time -- which is what the univariate RSS # path in fineMappingPipeline already does. - representation(Z = "matrix", ldSketch = "LdSketch_OR_NULL", N = "numeric"), + representation( + Z = "matrix", + ldReference = "LdReference_OR_NULL", + N = "numeric" + ), validity = function(object) { errors <- c( if (ncol(object@Z) != nrow(object@conditions)) { @@ -140,8 +144,9 @@ setClass( # ---- Pipeline markers ------------------------------------------------------- # Not empty: the `config` list carries the per-pipeline parameter tail -# (coverage/cvFolds/samplePartition/fitFullData/fitRetention/... for fm; -# fitRetention/cvFolds/... for twas), and dispatch on the concrete +# (credibleSetParam/crossValidationParam/fitRetention/... for fm; +# crossValidationParam/ensembleParam/fitRetention/... for twas), and dispatch on +# the concrete # class selects the result type via `construct()`. setClass("JointPipeline", contains = "VIRTUAL", representation(config = "list")) @@ -175,7 +180,7 @@ setClass("TwasJointPipeline", contains = "JointPipeline") .jgZ <- function(g) g@Z # @noRd -.jgLdSketch <- function(g) g@ldSketch +.jgLdRef <- function(g) g@ldReference # The variants a summary-statistics group covers, in Z's row order -- which is # the order the derived LD matrix comes back in. @@ -189,8 +194,8 @@ setClass("TwasJointPipeline", contains = "JointPipeline") # would recompute the same matrix for every condition. # @noRd .jgLdMatrix <- function(g) { - .ldFromSketch( - .jgLdSketch(g), + .ldFromRef( + .jgLdRef(g), .jgVariantIds(g), label = "jointEngine" ) @@ -199,6 +204,38 @@ setClass("TwasJointPipeline", contains = "JointPipeline") # @noRd .jgN <- function(g) g@N +# The group restricted to the conditions `keep` marks: each condition's Y / Z +# column goes with it, as does its trait position or sample size where those +# are per condition. NULL when none is kept. Rebuilt through initialize(), so +# the result is validated like any constructed group. +# @noRd +.jgKeepConditions <- function(g, keep) { + if (all(keep)) { + return(g) + } + if (!any(keep)) { + return(NULL) + } + idx <- which(keep) + cond <- slice(g@conditions, idx) + if (is(g, "IndividualJointGroup")) { + traitPos <- if (length(g@traitPos) > 0L) g@traitPos[idx] else g@traitPos + return(methods::initialize( + g, + conditions = cond, + Y = g@Y[, idx, drop = FALSE], + traitPos = traitPos + )) + } + N <- if (length(g@N) == length(keep)) g@N[idx] else g@N + methods::initialize( + g, + conditions = cond, + Z = g@Z[, idx, drop = FALSE], + N = N + ) +} + # @noRd .jcPattern <- function(cell) cell@pattern diff --git a/R/LdData.R b/R/LdData.R deleted file mode 100644 index 07a119ff8..000000000 --- a/R/LdData.R +++ /dev/null @@ -1,723 +0,0 @@ -# ============================================================================= -# LdData S4 class -# ----------------------------------------------------------------------------- -# Container for LD information used by fine-mapping / colocalization. Holds -# a pre-computed correlation matrix (or a list of per-block matrices) and/or -# a GenotypeHandle (or list of handles for mixture panels) for on-demand -# correlation computation. -# ============================================================================= - -#' @include GenotypeHandle.R AllClasses.R -NULL - -#' @title LD Data Container -#' @description S4 container for LD information. Stores either a pre-computed -#' correlation matrix or a \code{GenotypeHandle} (or list of handles for -#' mixture panels) for lazy genotype/correlation access. -#' -#' An \code{LdData} \strong{is} a \code{GRanges} over the variants it -#' covers -- carrying A1, A2, variant_id and optionally allele_freq, -#' variance and n_nomiss as metadata columns -- so \code{length()}, -#' \code{seqnames()} and \code{start()} answer directly, as they do for -#' \code{\link{LdScore}} and \code{\link{LdEigen}}. The correlation may -#' be NULL, in which case those ranges are the object's only record of which -#' variants it describes. -#' -#' @slot correlation A correlation matrix, a list of per-block matrices -#' (block-diagonal LD), or NULL if genotypes are available and R should be -#' computed on demand. -#' @slot genotypeHandle Where genotypes are read from: a genotype handle, a -#' list of them (for mixture panels), a matrix of dosages already extracted -#' and filtered, or NULL when only pre-computed R is available. Pass a -#' genotype panel (see \code{\link{readGenotypes}}) to the constructor and -#' it is unwrapped to its handle. -#' @slot snpIdx Integer vector of 1-based SNP indices into the handle's -#' \code{snpInfo}. NULL when correlation is pre-computed, or when the -#' source is a matrix (which is already the subset). -#' @slot blockMetadata A \code{GRanges} with one range per block: its -#' \code{seqnames} and range are the block's chromosome and genomic span, -#' and \code{mcols} carry \code{blockId}, \code{size}, \code{startIdx} -#' and \code{endIdx} -- the index range into the correlation matrix the -#' block addresses. Extra columns the caller supplied are kept as mcols. -#' A block whose index range is out of bounds has no span to derive and -#' gets a width-0 range. -#' @slot nSamples Integer, reference panel sample size. -#' @slot mixtureWeights NULL when \code{genotypeHandle} is a single -#' \code{GenotypeHandle}; a numeric vector of mixing proportions (one per -#' panel, summing to 1) when \code{genotypeHandle} is a list of -#' \code{GenotypeHandle}s. Used by \code{ldMatrix()} to compute a -#' weighted-average mixture LD matrix; required whenever \code{genotypeHandle} -#' is a list and \code{ldMatrix()} will be called. -#' @export -setClass( - "LdData", - contains = "GRanges", - representation( - correlation = "LdCorrelation", - genotypeHandle = "LdGenotypeSource", - snpIdx = "LdSnpIndex", - blockMetadata = "GRanges", - nSamples = "integer", - mixtureWeights = "LdMixtureWeights" - ), - validity = function(object) { - errors <- c( - if (is.null(object@correlation) && is.null(object@genotypeHandle)) { - str_c( - "At least one of 'correlation' or ", - "'genotypeHandle' must be non-NULL" - ) - }, - if (length(object) == 0) "an LdData must cover >= 1 variant", - .ldCheckGenotypeSource(object@genotypeHandle), - .ldCheckCorrelation(object@correlation), - .ldCheckMixtureWeights(object), - .ldCheckBlockMetadata(object) - ) - if (length(errors) == 0) TRUE else errors - } -) - -# Mixture weights are only meaningful over a LIST of panels, and must then be -# a proper simplex over them. NULL weights are always valid. -# @noRd -.ldCheckMixtureWeights <- function(object) { - if (is.null(object@mixtureWeights)) { - return(NULL) - } - if (!is.list(object@genotypeHandle)) { - return(str_c( - "'mixtureWeights' may only be set when ", - "'genotypeHandle' is a list of panels" - )) - } - w <- object@mixtureWeights - if (!is.numeric(w) || length(w) != length(object@genotypeHandle)) { - return(str_c( - "'mixtureWeights' must be numeric of length ", - "equal to the genotypeHandle list" - )) - } - if (any(w < 0) || abs(sum(w) - 1) > 1e-6) { - return("'mixtureWeights' must be non-negative and sum to 1") - } - NULL -} - -#' @describeIn LdData-class Refused. Subsetting would narrow the variants -#' while \code{correlation} -- variant-by-variant, and \code{snpIdx}, which -#' indexes the reference panel -- stayed as they were, leaving an LD matrix -#' describing variants the object no longer has. Build the LdData over the -#' variant set you want instead. -#' @param x An \code{LdData}. -#' @param i,j,... Subscripts; any use is an error. -#' @param drop Ignored. -#' @return Nothing: this method always signals an error. -#' @export -setMethod("[", "LdData", function(x, i, j, ..., drop = TRUE) { - abort(glue( - "an LdData cannot be subset: its correlation is variant-by-variant ", - "and its snpIdx addresses the reference panel, so narrowing the ", - "variants would leave both describing variants that are no longer ", - "present. Build the LdData over the variant set you want instead." - )) -}) - -#' @rdname show-methods -#' @export -setMethod("show", "LdData", function(object) { - n_var <- length(object) - has_R <- !is.null(object@correlation) - has_geno <- !is.null(object@genotypeHandle) - r_type <- if (has_R && is.list(object@correlation)) { - "block-diagonal" - } else { - "single" - } - cat(glue("LdData: {n_var} variants\n", .trim = FALSE)) - cat(glue( - " Correlation: {if (has_R) r_type else 'NULL'}, ", - "Genotype handle: {if (has_geno) 'available' else 'NULL'}\n", - .trim = FALSE - )) - cat(glue(" Reference N: {object@nSamples}\n", .trim = FALSE)) -}) - -# One element of a mixture list: unwrap a panel, pass anything else through -# for validity to judge. -# @noRd -.ldDataSourceElement <- function(x) { - open <- .openGenotypeHandle(x) - if (is.null(open)) x else open -} - -# Normalise whatever the caller passed for `genotypeHandle` into one of the -# shapes the slot admits. A panel is the public shape (readGenotypes()); the -# slot stores the handle behind it, because `snpIdx` selects into the handle's -# whole snpInfo and a panel adds nothing the handle does not already carry. -# Anything else is passed through for the slot's class union to accept or -# reject -- this is a normaliser, not a second type check. -# @noRd -.ldDataGenotypeSource <- function(x) { - if (is.null(x) || is.matrix(x)) { - return(x) - } - if (is.list(x)) { - # Unwrap the panels but do not reject here: validity reports a bad - # mixture element by its index, which a purrr-wrapped abort would bury. - return(map(x, .ldDataSourceElement)) - } - open <- .openGenotypeHandle(x) - if (!is.null(open)) { - return(open) - } - # The slot's class union would reject this anyway, but its message names - # the union rather than what to pass instead. - hint <- if (methods::is(x, "DelayedArray")) { - str_c( - " -- pass the panel it came from rather than its assay, so the ", - "variant selection in `snpIdx` still means something" - ) - } else { - "" - } - abort(glue( - "`genotypeHandle` must be a genotype panel from readGenotypes(), a ", - "list of them, a matrix of dosages, or NULL (got ", - "{class(x)[[1L]]}){hint}." - )) -} - -# --- block metadata -------------------------------------------------------- -# -# Five paths used to build this table -- the two region loaders, the two -# bare-matrix wrappers, and callers handing over a bare genomic span -- and -# each emitted a different set of columns, so consumers read `startIdx`, -# `size` and `chrom` that were there by luck rather than by contract. One -# normaliser at the only door (LdData()) fills whatever is absent and stores -# a single shape, the way .ldDataGenotypeSource() does for the handle. -# -# These are the columns consumers actually read. `blockStart` / `blockEnd` -# are deliberately NOT required: the two region loaders record a block's -# genomic span, nothing reads it, and demanding it would reject every -# multi-block table built without it. Supplied columns are carried through. -# @noRd -.ldBlockColumns <- c("blockId", "chrom", "size", "startIdx", "endIdx") - -# What survives as mcols once chrom / blockStart / blockEnd become the -# GRanges itself. -# @noRd -.ldBlockMcols <- c("blockId", "size", "startIdx", "endIdx") - -# Supplied values are never replaced: a caller handing over deliberately -# out-of-range indices keeps them, because partitionLdMatrix() still has to -# reject those and substituting valid ones would hide the error. -# @noRd -.ldBlockMetadata <- function(blockMetadata, variants) { - if (length(variants) == 0L) { - # Nothing to derive a block from. Validity rejects the object for - # covering no variant; crashing here would pre-empt that message. - return(GenomicRanges::GRanges()) - } - tbl <- .ldBlockMetadataTibble(blockMetadata) - if (nrow(tbl) == 0L) { - # A placeholder table means "one block", not "no blocks": an LdData - # always covers at least one variant. - tbl <- tibble(blockId = 1L) - } - tbl <- .ldBlockMetadataIndices(tbl, length(variants)) - tbl <- .ldBlockMetadataOrder(.ldBlockMetadataDerive(tbl, variants)) - .ldBlockMetadataGRanges(tbl, variants) -} - -# The stored shape: one range per block, so the invariants the merge logic -# depends on are the ones GRanges already answers -- isDisjoint() for -# overlap, sort() for order, seqnames() for the same-chromosome guard. The -# index payload the matrix is addressed by rides along in mcols. -# @noRd -.ldBlockMetadataGRanges <- function(tbl, variants) { - span <- .ldBlockSpans(tbl, variants) - gr <- GenomicRanges::GRanges( - seqnames = tbl$chrom, - ranges = IRanges::IRanges(start = span$start, end = span$end) - ) - keep <- c( - intersect(.ldBlockMcols, names(tbl)), - setdiff(names(tbl), c(.ldBlockColumns, "blockStart", "blockEnd")) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - as.data.frame(select(tbl, all_of(keep))) - ) - gr -} - -# Each block's genomic span. Supplied blockStart / blockEnd win; otherwise -# the span is read off the variants the index range covers. -# -# A block whose index range is out of bounds has no span to read, and a -# GRanges cannot hold an NA one (seqnames reject NAs outright). It gets a -# WIDTH-0 range at the first variant instead: legal, and visibly not an -# interval, so nothing downstream mistakes it for a real span. -# partitionLdMatrix() rejects the block on its indices regardless. -# @noRd -.ldBlockSpans <- function(tbl, variants) { - if (is_in("blockStart", names(tbl)) && is_in("blockEnd", names(tbl))) { - return(list(start = tbl$blockStart, end = tbl$blockEnd)) - } - parts <- map( - seq_len(nrow(tbl)), - .ldBlockSpanAt, - tbl = tbl, - variants = variants - ) - list( - start = map_dbl(parts, "start"), - end = map_dbl(parts, "end") - ) -} - -# @noRd -.ldBlockSpanAt <- function(i, tbl, variants) { - s <- tbl$startIdx[[i]] - e <- tbl$endIdx[[i]] - if (.ldBlockRangeUsable(s, e, length(variants))) { - part <- variants[seq.int(s, e)] - return(list( - start = min(GenomicRanges::start(part)), - end = max(GenomicRanges::end(part)) - )) - } - anchor <- GenomicRanges::start(variants)[[1L]] - list(start = anchor, end = anchor - 1L) -} - -# @noRd -.ldBlockRangeUsable <- function(s, e, n) { - !is.na(s) && !is.na(e) && s >= 1L && e >= s && e <= n -} - -# Any accepted shape as a tibble. `start`/`end` is how a bare genomic span -# arrives; they name the BLOCK's span, so they become blockStart/blockEnd. -# @noRd -.ldBlockMetadataTibble <- function(x) { - if (!is(x, "GRanges") && !is.data.frame(x) && !is(x, "DataFrame")) { - # as.data.frame() would happily turn a string into a one-column - # table, so the shapes have to be named rather than coerced blindly. - abort(glue( - "`blockMetadata` must be a GRanges, a data.frame or a ", - "DataFrame; got {class(x)[[1L]]}" - )) - } - tbl <- if (is(x, "GRanges")) { - .ldBlockMetadataFromGranges(x) - } else { - as_tibble(as.data.frame(x)) - } - .ldBlockMetadataRenameSpan(tbl) -} - -# @noRd -.ldBlockMetadataFromGranges <- function(x) { - md <- as_tibble(as.data.frame(S4Vectors::mcols(x))) - # An LdBlocks-style GRanges carries chrom / blockStart / blockEnd in its - # mcols as well as in its ranges. The mcols win: binding both would - # duplicate the names and leave no column called `chrom` at all. - fromRanges <- tibble( - chrom = as.character(GenomicRanges::seqnames(x)), - blockStart = GenomicRanges::start(x), - blockEnd = GenomicRanges::end(x) - ) - bind_cols( - md, - select( - fromRanges, - all_of(setdiff(names(fromRanges), names(md))) - ) - ) -} - -# @noRd -.ldBlockMetadataRenameSpan <- function(tbl) { - if (!is_in("blockStart", names(tbl)) && is_in("start", names(tbl))) { - tbl <- rename(tbl, blockStart = "start") - } - if (!is_in("blockEnd", names(tbl)) && is_in("end", names(tbl))) { - tbl <- rename(tbl, blockEnd = "end") - } - tbl -} - -# The index range is the one thing that cannot be derived for several -# blocks: only the caller knows which variants each covers. A single block -# covers all of them. -# @noRd -.ldBlockMetadataIndices <- function(tbl, n) { - absent <- setdiff(c("startIdx", "endIdx"), names(tbl)) - if (length(absent) == 0L) { - return(tbl) - } - if (length(absent) == 1L) { - abort(glue( - "`blockMetadata` gives one of startIdx / endIdx but not the ", - "other; supply both or neither." - )) - } - if (is_in("size", names(tbl))) { - # Blocks are taken in order, so the sizes give the ranges. This is - # the LdBlocks shape: a block table that says how many variants each - # block holds but not where they sit in the matrix. - sizes <- as.integer(tbl$size) - ends <- cumsum(sizes) - return(mutate(tbl, startIdx = ends - sizes + 1L, endIdx = ends)) - } - if (nrow(tbl) > 1L) { - abort(glue( - "`blockMetadata` describes {nrow(tbl)} blocks but gives neither ", - "an index range nor `size`, so which variants each block covers ", - "cannot be determined." - )) - } - mutate(tbl, startIdx = 1L, endIdx = n) -} - -# `blockId`, `chrom` and `size` all follow from the index range, for one -# block or many. -# @noRd -.ldBlockMetadataDerive <- function(tbl, variants) { - absent <- setdiff(.ldBlockColumns, names(tbl)) - if (length(absent) == 0L) { - return(tbl) - } - derived <- tibble( - blockId = seq_len(nrow(tbl)), - chrom = .ldBlockChroms(tbl, variants), - size = as.integer(tbl$endIdx - tbl$startIdx + 1L), - startIdx = tbl$startIdx, - endIdx = tbl$endIdx - ) - bind_cols(tbl, select(derived, all_of(absent))) -} - -# @noRd -.ldBlockChroms <- function(tbl, variants) { - map_chr( - seq_len(nrow(tbl)), - .ldBlockChromAt, - tbl = tbl, - variants = variants - ) -} - -# An out-of-range block falls back to the data's own chromosome rather than -# NA: seqnames cannot hold NA, and partitionLdMatrix() rejects the block on -# its indices anyway. Its range is width 0 (see .ldBlockSpanAt). -# @noRd -.ldBlockChromAt <- function(i, tbl, variants) { - s <- tbl$startIdx[[i]] - e <- tbl$endIdx[[i]] - part <- if (.ldBlockRangeUsable(s, e, length(variants))) { - variants[seq.int(s, e)] - } else { - variants - } - as.character(GenomicRanges::seqnames(part))[[1L]] -} - -# Canonical columns first, anything the caller added after. -# @noRd -.ldBlockMetadataOrder <- function(tbl) { - select(tbl, all_of(.ldBlockColumns), everything()) -} - -# Every LdData describes at least one block, with the columns its consumers -# read. The normaliser guarantees both; this is the backstop that keeps a -# future construction path from quietly dropping one. -# @noRd -.ldCheckBlockMetadata <- function(object) { - bm <- object@blockMetadata - absent <- setdiff(.ldBlockMcols, names(S4Vectors::mcols(bm))) - if (length(absent) > 0L) { - return(str_c( - "'blockMetadata' is missing required column(s): ", - str_flatten(absent, ", ") - )) - } - if (length(bm) == 0L) { - return("'blockMetadata' must describe at least one block") - } - NULL -} - -#' @title Create an LdData Object -#' @description Construct an \code{LdData} from a correlation matrix and/or -#' genotype handle, plus variant metadata as a GRanges. -#' @param correlation A correlation matrix, list of matrices, or NULL. -#' @param genotypeHandle A genotype panel (see -#' \code{\link{readGenotypes}}), a list of panels for a mixture reference, -#' a matrix of already-extracted dosages, or NULL. -#' @param snpIdx Vector of 1-based SNP indices, coerced to integer, or NULL. -#' @param variants A GRanges with variant metadata (must have variant_id in -#' mcols, plus A1, A2). -#' @param blockMetadata Block boundaries: a \code{GRanges}, a -#' \code{data.frame} or a \code{DataFrame}. Whatever is absent for a -#' single block is derived from \code{variants}, so a bare genomic span -#' -- or nothing at all -- is enough; with several blocks either the index -#' columns or \code{size} must be supplied. Normalised on the way in and -#' stored as a \code{GRanges} (see the \code{blockMetadata} slot). -#' @param nSamples Integer, reference panel sample size. -#' @param mixtureWeights Optional numeric vector of mixing proportions, one per -#' panel in \code{genotypeHandle} when it is a list. Must be non-negative and -#' sum to 1. Required whenever \code{genotypeHandle} is a list and downstream -#' code will call \code{ldMatrix()}. -#' @return An \code{LdData} object. -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:8] -#' gr <- GenomicRanges::GRanges("22", -#' IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -#' ld <- LdData(correlation = cor(X), variants = gr, -#' blockMetadata = S4Vectors::DataFrame( -#' chrom = "22", start = 1L, end = 1000L)) -#' ld -#' @importFrom checkmate assert checkMatrix checkList checkNull -#' @importFrom checkmate assertNumeric -#' @export -LdData <- function( - correlation = NULL, - genotypeHandle = NULL, - snpIdx = NULL, - variants, - blockMetadata, - nSamples = 0L, - mixtureWeights = NULL -) { - # correlation is documented as a matrix OR a list of matrices OR NULL, - # so this must be an or-combination, not assertMatrix. - assert( - checkMatrix(correlation), - checkList(correlation), - checkNull(correlation), - .var.name = "correlation" - ) - assertNumeric(mixtureWeights, null.ok = TRUE) - obj <- new( - "LdData", - variants, - correlation = correlation, - genotypeHandle = .ldDataGenotypeSource(genotypeHandle), - snpIdx = if (is.null(snpIdx)) NULL else as.integer(snpIdx), - blockMetadata = .ldBlockMetadata(blockMetadata, variants), - nSamples = as.integer(nSamples), - mixtureWeights = mixtureWeights - ) - validObject(obj) - obj -} - -# Internal: convert a refPanel data.frame (chrom/pos/A1/A2/variant_id, with -# optional allele_freq/variance/n_nomiss) into the GRanges an LdData is. -.refPanelToGranges <- function(refPanel) { - chr <- withChrPrefix(refPanel$chrom) - pos <- as.integer(refPanel$pos) - - gr <- GRanges( - seqnames = chr, - ranges = IRanges(start = pos, width = 1L) - ) - - mcolsData <- DataFrame( - variant_id = refPanel$variant_id, - A1 = refPanel$A1, - A2 = refPanel$A2 - ) - - optional <- intersect( - c("allele_freq", "variance", "n_nomiss"), - names(refPanel) - ) - `mcols<-`( - gr, - value = cbind( - mcolsData, - DataFrame(refPanel[optional], check.names = FALSE) - ) - ) -} - -# One panel scaled by its mixture weight. -# @noRd -.ldScalePanel <- function(w, panel) { - w * panel -} - -#' @rdname ldMatrix -#' @export -setMethod("ldMatrix", "LdData", function(x) { - if (!is.null(x@correlation)) { - return(x@correlation) - } - if (is.null(x@genotypeHandle)) { - abort("No correlation matrix or genotype handle available") - } - if (is.list(x@genotypeHandle)) { - if (is.null(x@mixtureWeights)) { - msg <- glue( - "Cannot compute mixture LD: `mixtureWeights` is NULL. ", - "Construct LdData with mixtureWeights = ", - "when supplying a list of GenotypeHandles." - ) - abort(msg) - } - perPanel <- map(x@genotypeHandle, .ldPanelLd, snpIdx = x@snpIdx) - dims <- map_int(perPanel, nrow) - if (length(unique(dims)) != 1L) { - msg <- glue( - "Mixture panels yielded LD matrices of differing ", - "dimensions: {str_flatten(dims, ', ')}. All panels ", - "must be aligned on the same variant subset." - ) - abort(msg) - } - # The mixture is a weighted sum over the panels, so it is a fold. - weighted <- map2(x@mixtureWeights, perPanel, .ldScalePanel) - return(`dimnames<-`( - reduce( - weighted, - `+`, - .init = matrix(0, nrow = dims[[1L]], ncol = dims[[1L]]) - ), - dimnames(perPanel[[1L]]) - )) - } - computeLd(.ldSourceDosages(x@genotypeHandle, x@snpIdx), method = "sample") -}) - -#' @rdname genotypes -#' @export -setMethod("genotypes", "LdData", function(x) { - if (is.null(x@genotypeHandle)) { - return(NULL) - } - if (is.list(x@genotypeHandle)) { - # A mixture list may hold matrices as well as handles. - map(x@genotypeHandle, .ldSourceDosages, x@snpIdx) - } else { - .ldSourceDosages(x@genotypeHandle, x@snpIdx) - } -}) - -#' @rdname hasGenotypes -#' @export -setMethod("hasGenotypes", "LdData", function(x) { - !is.null(genotypeHandle(x)) -}) - -#' @rdname variantIds -#' @export -setMethod("variantIds", "LdData", function(x) { - mcols(x)$variant_id -}) - -#' @rdname variantInfo -#' @export -setMethod("variantInfo", "LdData", function(x) { - # A plain GRanges view: callers subset and re-wrap it, and carrying the - # LD payload along would make those copies quietly expensive. - as(x, "GRanges") -}) - -#' @rdname blockMetadata -#' @export -setMethod("blockMetadata", "LdData", function(x) { - x@blockMetadata -}) - -#' @rdname refPanel -#' @export -setMethod("refPanel", "LdData", function(x) { - mutate( - as_tibble(as.data.frame(mcols(x))), - chrom = as.character(seqnames(x)), - pos = start(x) - ) -}) - -#' @rdname genotypeHandle -#' @keywords internal -setMethod("genotypeHandle", "LdData", function(x) x@genotypeHandle) - -#' @rdname mixtureWeights -#' @export -setMethod("mixtureWeights", "LdData", function(x) x@mixtureWeights) - -#' @rdname snpIdx -#' @export -setMethod("snpIdx", "LdData", function(x) x@snpIdx) - -#' @rdname ldPanelNSamples -#' @export -setMethod("ldPanelNSamples", "LdData", function(x) x@nSamples) - -# ---- map/apply helpers (lambda-free callbacks) --------------------------- - -# Sample-LD matrix for one mixture panel's genotype handle (over `snpIdx`). -# @noRd -.ldPanelLd <- function(h, snpIdx) { - computeLd(.ldSourceDosages(h, snpIdx), method = "sample") -} - -# Dosages from a genotype source. A matrix IS the dosages already -- extracted -# and filtered upstream, with `snpIdx` NULL because the matrix is the subset -- -# so it is returned as-is rather than fed to the file readers, which would -# dispatch on it and fail. -# @noRd -.ldSourceDosages <- function(x, snpIdx) { - if (is.matrix(x)) { - return(x) - } - .dosageMatrix(x, snpIdx) -} - -# Every element of a mixture list has to be something LD can be computed from. -# The class union admits any list, so the elements are checked here. -# @noRd -.ldCheckGenotypeSource <- function(x) { - if (!is.list(x)) { - return(character()) - } - ok <- map_lgl(x, .ldIsGenotypeSource) - if (all(ok)) { - return(character()) - } - str_c( - "'genotypeHandle' list elements must each be a genotype panel or a ", - "dosage matrix; element(s) ", - str_flatten(which(!ok), ", "), - " are not." - ) -} - -# @noRd -.ldIsGenotypeSource <- function(x) { - methods::is(x, "GenotypeHandle") || is.matrix(x) -} - -# Block-diagonal LD is one matrix per block. The union admits any list, so the -# elements are checked here -- a list of something else would otherwise sail -# through and fail later inside the LD arithmetic. -# @noRd -.ldCheckCorrelation <- function(x) { - if (!is.list(x)) { - return(character()) - } - ok <- map_lgl(x, is.matrix) - if (all(ok)) { - return(character()) - } - str_c( - "'correlation' list elements must each be a matrix (block-diagonal ", - "LD is one matrix per block); element(s) ", - str_flatten(which(!ok), ", "), - " are not." - ) -} diff --git a/R/LdEigen.R b/R/LdEigen.R index 1d37f3e70..b1daeb3dc 100644 --- a/R/LdEigen.R +++ b/R/LdEigen.R @@ -1,8 +1,9 @@ # ============================================================================= # LdEigen S4 class # ----------------------------------------------------------------------------- -# Pre-computed per-block eigendecompositions of the LD correlation matrix. -# Consumed by LDER / HDL / sHDL h2 estimators. +# Per-block eigendecompositions of the LD correlation matrix: stored for +# LdMatrix input, computed from the genotype panel one block at a time for +# panel input. Consumed by LDER / HDL / sHDL h2 estimators. # ============================================================================= #' @include LdStatistic.R @@ -18,7 +19,16 @@ NULL #' narrow when the ranges do, subsetting an \code{LdEigen} is refused #' rather than allowed to produce an object whose decompositions no longer #' describe its variants. -#' @slot eigenList A list of length \code{nBlocks}, each element a list with +#' +#' An \code{LdEigen} built from a genotype panel stores no +#' decompositions: each block's is computed from the panel's factor (its +#' standardized genotypes) when an estimator reaches the block. That gives +#' the block's nonzero eigenvalues and their eigenvectors; when the panel +#' has fewer samples than the block has variants, the block's remaining +#' eigenvalues are exactly zero, and the estimators account for those +#' directions without listing them. +#' @slot eigenList A list of length \code{nBlocks} (empty for an +#' \code{LdEigen} built from a genotype panel), each element a list with #' components: #' \describe{ #' \item{values}{Numeric vector of eigenvalues} @@ -47,9 +57,11 @@ setClass( if (!isTRUE(parentCheck)) { coll$push(parentCheck) } + # One decomposition per block, or none for an LdEigen that computes them + # from its genotype panel. assertList( object@eigenList, - len = length(object@ldBlocks), + len = if (is.null(object@ldReference)) length(object@ldBlocks) else 0L, .var.name = "eigenList", add = coll ) @@ -117,51 +129,58 @@ LdEigen <- function( } #' @importFrom checkmate assertCount assertFlag -#' @title Build an LdEigen from loaded LD -#' @description Eigendecompose already-loaded LD, block by block, into the +#' @title Build an LdEigen from an LD reference +#' @description Eigendecompose an LD reference, block by block, into the #' \code{LdEigen} that \code{\link{estimateH2}} consumes for #' \code{method = "lder"} and \code{method = "hdl"}. This is the supported #' route from an LD reference to an h2 input: \code{\link{LdEigen}} itself #' is the low-level constructor and expects the decompositions to have been #' computed already. #' -#' No file I/O happens here. Read the LD first with -#' \code{\link{loadLdMatrix}} -- passing a vector of regions returns one -#' \code{LdData} per block -- then pass the result in. -#' @param ldBlockData An \code{\link{LdData}}, or a list of them, covering -#' the reference variants. An \code{LdData} whose correlation is a list of -#' per-block matrices contributes one LD block per matrix; one whose -#' correlation is a single matrix contributes one block. Blocks are kept in -#' the order given, and that order defines the variant order of the result. +#' @param ldReference The LD reference, block by block: a list of +#' \code{\link{LdMatrix}} objects, one per LD block (a single +#' \code{LdMatrix} is one block), or a genotype panel (see +#' \code{\link{readGenotypes}}) together with \code{ldBlocks}. Blocks are +#' kept in the order given, and that order defines the variant order of the +#' result. #' #' Block structure matters downstream: \code{\link{estimateH2}} takes its #' standard error from a delete-one-block jackknife, so it requires at -#' least two blocks and wants many more. Loading a whole region as one -#' dense matrix yields a single block. -#' @param nSamples Integer, the LD reference panel sample size. Defaults to the -#' size recorded by the supplied \code{LdData}; required when they record -#' none, and an error when they disagree. +#' least two blocks and wants many more. +#' @param ldBlocks With a genotype panel, the LD blocks to cut it into: a +#' \code{GRanges}, or a data frame with columns \code{chrom}, \code{start} +#' and \code{end}. Each block's LD is computed from the panel variants +#' inside it; variants outside every block are left out. Not used with +#' \code{LdMatrix} blocks. +#' @param nSamples Integer, the number of samples the reference's LD was +#' estimated from. Defaults to a panel's sample count (a stochastic +#' sketch's effective size), or the size the \code{LdMatrix} blocks record; +#' required when they record none, and an error when they disagree. #' @param inSample Logical, whether the reference is the GWAS cohort itself. #' Selects LDER's weighting and HDL's finite-reference correction. #' @param genome Character, genome build. Defaults to the build recorded by -#' the supplied \code{LdData}, which \code{\link{loadLdMatrix}} leaves -#' unset. +#' the reference's variants. #' @param eigenvalueTruncation Numeric in (0, 1]; the proportion of each #' block's eigenvalue mass to retain. \code{1} (the default) keeps every #' component; HDL conventionally uses \code{0.9}. -#' @return An \code{LdEigen} over every variant in \code{ldBlockData}. +#' @return An \code{LdEigen} over every variant in the reference's blocks. +#' One built from a genotype panel keeps the panel and decomposes each +#' block when it is needed, rather than storing the decompositions. #' @seealso \code{\link{buildLdScore}} for the g-LDSC input, -#' \code{\link{estimateH2}}, \code{\link{loadLdMatrix}} +#' \code{\link{estimateH2}}, \code{\link{LdMatrix}} #' @examples -#' meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", -#' package = "pecotmr") -#' ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") -#' ldEigen <- buildLdEigen(ld, genome = "hg38") +#' panel <- readGenotypes(plink2Prefix = file.path(system.file("extdata", +#' "ld_reference", "chr22", package = "pecotmr"), +#' "protocol_example.LD.chr22")) +#' blocks <- data.frame(chrom = "chr22", start = c(10000000, 15000001), +#' end = c(15000000, 19000000)) +#' ldEigen <- buildLdEigen(panel, ldBlocks = blocks, genome = "hg38") #' ldEigen #' length(eigenList(ldEigen)) #' @export buildLdEigen <- function( - ldBlockData, + ldReference, + ldBlocks = NULL, nSamples = NULL, inSample = FALSE, genome = NA_character_, @@ -169,7 +188,10 @@ buildLdEigen <- function( ) { assertCount(nSamples, positive = TRUE, null.ok = TRUE) assertFlag(inSample) - prep <- .ldRefPrepare(ldBlockData, nSamples, genome) + prep <- .h2RefPrepare(ldReference, ldBlocks, nSamples, genome) + if (!is.null(prep$ldReference)) { + return(.ldEigenFromPanel(prep, inSample, eigenvalueTruncation)) + } eigenList <- map2( prep$blocks, prep$snpIdx, @@ -187,6 +209,28 @@ buildLdEigen <- function( ) } +# An LdEigen over a genotype panel: the panel and each variant's row in it, +# and no decompositions, which are computed a block at a time when needed. +# Built in one step because an empty eigenList is valid only alongside the +# panel it is read from. +# @noRd +.ldEigenFromPanel <- function(prep, inSample, truncation) { + gr <- .ldStatRanges(prep$snpInfo, prep$genome) + S4Vectors::mcols(gr)$panelRow <- prep$panelRow + obj <- methods::new( + "LdEigen", + gr, + ldBlocks = .asLdBlockRanges(prep$ldBlocks), + nSamples = as.integer(prep$nRef), + inSample = isTRUE(inSample), + eigenList = list(), + eigenvalueTruncation = as.numeric(truncation), + ldReference = prep$ldReference + ) + validObject(obj) + obj +} + # One block's decomposition, truncated to the leading components carrying # `truncation` of its eigenvalue mass. # @noRd @@ -226,28 +270,67 @@ buildLdEigen <- function( #' @return Nothing: this method always signals an error. #' @export setMethod("[", "LdEigen", function(x, i, j, ..., drop = TRUE) { + .ldEigenRefuseSubset() +}) + +# head(), tail(), window() and subset() reach the rows through extractROWS() +# without passing `[`, so the refusal is made there as well. +setMethod("extractROWS", "LdEigen", function(x, i) { + .ldEigenRefuseSubset() +}) + +# @noRd +.ldEigenRefuseSubset <- function() { abort(glue( "an LdEigen cannot be subset: its eigendecompositions are per LD ", "block, so narrowing the variants would leave them describing ", "variants that are no longer present. Recompute over the subset." )) -}) +} #' @rdname show-methods #' @export setMethod("show", "LdEigen", function(object) { cat(glue( "LdEigen: {length(object)} SNPs across ", - "{length(object@eigenList)} blocks\n", + "{length(object@ldBlocks)} blocks\n", .trim = FALSE )) cat(sprintf(" Eigenvalue truncation: %.2f\n", object@eigenvalueTruncation)) + if (!is.null(object@ldReference)) { + cat(" Decompositions: computed from the genotype panel when needed\n") + } cat(glue( " Reference N: {object@nSamples}, In-sample: {object@inSample}\n", .trim = FALSE )) }) +# The block records of an LdEigen (see .ldStatLazyBlocks()). +# @noRd +.ldEigenBlocks <- function(x) { + if (length(x@eigenList) > 0L) { + return(map(x@eigenList, .ldEigenStoredBlock)) + } + .ldStatLazyBlocks(x) +} + +# @noRd +.ldEigenStoredBlock <- function(block) { + list(idx = block$snpIdx, eigen = block) +} + +# One block's decomposition, at the truncation the LdEigen records. +# @noRd +.ldEigenBlockAt <- function(block, x) { + .ldStatBlockEigen(block, x@ldReference, x@eigenvalueTruncation) +} + #' @rdname eigenList #' @export -setMethod("eigenList", "LdEigen", function(x) x@eigenList) +setMethod("eigenList", "LdEigen", function(x) { + if (is.null(x@ldReference)) { + return(x@eigenList) + } + map(.ldEigenBlocks(x), .ldEigenBlockAt, x = x) +}) diff --git a/R/LdMatrix.R b/R/LdMatrix.R new file mode 100644 index 000000000..590234958 --- /dev/null +++ b/R/LdMatrix.R @@ -0,0 +1,652 @@ +# ============================================================================= +# LdMatrix S4 class +# ----------------------------------------------------------------------------- +# An LD correlation matrix the caller supplies, over the variants it +# describes. This is one of the two ways LD enters pecotmr. The other is a +# genotype panel (readGenotypes()), which is read lazily from disk; pecotmr +# never reads a pre-computed matrix from disk, so a matrix is built in memory +# by the caller and handed over whole. +# ============================================================================= + +#' @include AllGenerics.R +NULL + +#' @title LD Correlation Matrix +#' @description An \code{LdMatrix} carries one LD correlation matrix together +#' with the variants it describes, and can stand wherever pecotmr takes an +#' LD reference (the \code{ldReference} of a summary-statistics collection, +#' \code{\link{raiss}}, the heritability builders). It \strong{is} a +#' \code{GRanges} over those variants, in the order of the matrix's rows, +#' with metadata columns \code{SNP} (the variant id), \code{A1} (the allele +#' whose dosage the correlations are signed by), \code{A2} and, optionally, +#' \code{AF} (the frequency of \code{A1}). +#' +#' The other kind of LD reference is a genotype panel (see +#' \code{\link{readGenotypes}}), which pecotmr reads from disk on demand. A +#' matrix carries no genotypes, so the steps that need them are not +#' available with one: the panel missingness filter, and RAiSS's +#' singular-value route (RAiSS falls back to the matrix itself). Steps that +#' need the panel's sample size or allele frequencies -- MAF / MAC panel +#' filters, DENTIST, ldsc's unbiased \eqn{r^2}, HDL -- use \code{nSamples} +#' and \code{AF} when they are supplied and refuse otherwise. +#' +#' Validity checks the matrix's shape and labels, that its diagonal is 1, +#' that its entries lie in \eqn{[-1, 1]}, and its symmetry on an evenly +#' spaced subset of entries. It does not check positive semi-definiteness, +#' which costs an eigendecomposition; run \code{\link{checkLd}} for that. +#' +#' @slot correlation The correlation matrix, its dimnames the variant ids. +#' @slot nSamples Integer, the number of independent samples the LD is +#' worth, or \code{NA} when unknown. For one panel this is its sample size. +#' For a mixture it is \eqn{1 / \sum_k w_k^2 / n_k}, the size of a single +#' panel whose LD would be as noisy. +#' @slot mixtureWeights The weights a mixture's components were combined +#' with; empty for a single panel's LD. +#' @seealso \code{\link{LdMatrix}} to build one, \code{\link{checkLd}}. +#' @importClassesFrom GenomicRanges GRanges +#' @importFrom S4Vectors extractROWS normalizeSingleBracketSubscript +#' @export +setClass( + "LdMatrix", + contains = "GRanges", + slots = c( + correlation = "matrix", + nSamples = "integer", + mixtureWeights = "numeric" + ), + prototype = prototype( + correlation = matrix(numeric(0), 0L, 0L), + nSamples = NA_integer_, + mixtureWeights = numeric(0) + ) +) + +setValidity("LdMatrix", function(object) { + problems <- c( + .ldmCheckColumns(object), + .ldmCheckShape(object), + .ldmCheckValues(object@correlation), + .ldmCheckAf(object), + .ldmCheckN(object@nSamples), + .ldmCheckWeights(object@mixtureWeights) + ) + if (length(problems) == 0L) TRUE else problems +}) + +# @noRd +.ldmCheckColumns <- function(object) { + missingCols <- setdiff( + c("SNP", "A1", "A2"), + colnames(S4Vectors::mcols(object)) + ) + if (length(missingCols) == 0L) { + return(character()) + } + str_c( + "the variants carry no ", + str_flatten(missingCols, ", "), + " column(s)." + ) +} + +# The matrix must be square over exactly the object's variants, labelled by +# their ids: every consumer looks LD up by id, so a matrix whose labels drift +# from the variant table would hand back some other variant's LD. +# @noRd +.ldmCheckShape <- function(object) { + R <- object@correlation + p <- length(object) + if (!is.numeric(R) || nrow(R) != p || ncol(R) != p) { + return(glue( + "`correlation` is {nrow(R)} x {ncol(R)} but there are {p} ", + "variant(s); it must be numeric and square over them." + )) + } + # An empty matrix has no labels to check: subsetting to zero variants + # leaves NULL dimnames, which is as labelled as nothing gets. + ids <- as.character(S4Vectors::mcols(object)$SNP) + if (p == 0L) { + return(character()) + } + if ( + !identical(rownames(R), ids) || + !identical(colnames(R), ids) + ) { + return( + "`correlation`'s row and column names must be the variant ids." + ) + } + character() +} + +# A correlation matrix has a unit diagonal, entries in [-1, 1] and is +# symmetric. Symmetry is checked on an evenly spaced block of rows and +# columns: comparing a large matrix with its transpose costs another copy of +# it, and the strided block catches a wrong input just as well. +# @noRd +.ldmCheckValues <- function(R, tol = 1e-6) { + p <- nrow(R) + if (!is.numeric(R) || p == 0L || nrow(R) != ncol(R)) { + return(character()) + } + if (anyNA(R)) { + return("`correlation` holds missing values.") + } + span <- range(R) + problems <- c( + if (span[[1L]] < -1 - tol || span[[2L]] > 1 + tol) { + "`correlation` holds entries outside [-1, 1]." + }, + if (max(abs(diag(R) - 1)) > tol) { + "`correlation`'s diagonal is not 1." + } + ) + probe <- unique(round(seq(1, p, length.out = min(p, 200L)))) + block <- R[probe, probe, drop = FALSE] + if (max(abs(block - t(block))) > tol) { + problems <- c(problems, "`correlation` is not symmetric.") + } + problems +} + +# @noRd +.ldmCheckAf <- function(object) { + af <- S4Vectors::mcols(object)$AF + if (is.null(af)) { + return(character()) + } + if (!is.numeric(af) || any(af < 0 | af > 1, na.rm = TRUE)) { + return("`AF` must be numeric allele frequencies in [0, 1].") + } + character() +} + +# @noRd +.ldmCheckN <- function(n) { + if (length(n) == 1L && (is.na(n) || n >= 1L)) { + return(character()) + } + "`nSamples` must be one positive count, or NA when unknown." +} + +# @noRd +.ldmCheckWeights <- function(w) { + if (length(w) == 0L) { + return(character()) + } + if (anyNA(w) || any(w < 0) || abs(sum(w) - 1) > 1e-8) { + return("`mixtureWeights` must be non-negative and sum to 1.") + } + character() +} + +# Documented on its own page, LdMatrix-constructor.Rd: the default LdMatrix.Rd +# would collide with the ldMatrix() generic's ldMatrix.Rd on a +# case-insensitive filesystem (macOS), and one would overwrite the other. +#' @title Build an LdMatrix +#' @description Wrap an LD correlation matrix, or combine several into a +#' mixture, for use as an LD reference. See \code{\link{LdMatrix-class}}. +#' +#' \strong{One panel's LD.} Pass the matrix and the variants it covers. +#' The variants may be given as a \code{GRanges} (metadata columns +#' \code{A1}, \code{A2}, and optionally \code{SNP} and \code{AF}), as a +#' data frame with columns \code{chrom}, \code{pos}, \code{A1}, \code{A2} +#' (and optionally \code{SNP}, \code{AF}), or omitted when the matrix's +#' dimnames are \code{chrom:pos:A2:A1} ids, from which they are parsed. The +#' correlations must be signed by the dosage of \code{A1}. +#' +#' \strong{A mixture.} Pass a list of \code{LdMatrix} objects and their +#' \code{mixtureWeights}. The result is their weighted average +#' \eqn{\sum_k w_k R_k}, computed once here, over the variants every +#' component covers; a variant some component lacks is left out, with a +#' message. Components are matched by position and alleles and put into +#' the first component's allele coding, so they need not share variant ids +#' or allele orientation. The mixture's \code{AF} is \eqn{\sum_k w_k AF_k} +#' when every component records \code{AF}, and its \code{nSamples} is +#' \eqn{1 / \sum_k w_k^2 / n_k} when every component records a size. +#' +#' @param correlation A numeric correlation matrix, or a list of +#' \code{LdMatrix} objects to combine into a mixture. +#' @param variants The variants the matrix covers, in its row order: a +#' \code{GRanges} or a data frame (see Description), or \code{NULL} to +#' parse them from the matrix's dimnames. Not used for a mixture. +#' @param nSamples The size of the panel the LD was estimated from, or +#' \code{NA} when unknown. Not used for a mixture. +#' @param mixtureWeights For a mixture, one non-negative weight per +#' component, summing to 1. +#' @return An \code{LdMatrix}. +#' @rdname LdMatrix-constructor +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:8] +#' ld <- LdMatrix(cor(X), nSamples = nrow(X)) +#' ld +#' ldMatrix(ld)[1:3, 1:3] +#' +#' # A mixture of two panels' LD, weighted 3:1. +#' half <- seq_len(nrow(X) / 2) +#' ldA <- LdMatrix(cor(X[half, ]), nSamples = length(half)) +#' ldB <- LdMatrix(cor(X[-half, ]), nSamples = nrow(X) - length(half)) +#' LdMatrix(list(ldA, ldB), mixtureWeights = c(0.75, 0.25)) +#' @importFrom checkmate assertNumber +#' @export +LdMatrix <- function( + correlation, + variants = NULL, + nSamples = NA_integer_, + mixtureWeights = NULL +) { + if (is.list(correlation) && !is.data.frame(correlation)) { + return(.ldmMixture(correlation, mixtureWeights)) + } + if (!is.null(mixtureWeights)) { + abort(c( + "`mixtureWeights` is for combining LD matrices.", + i = "Pass a list of LdMatrix objects as `correlation`." + )) + } + assertNumber(nSamples, na.ok = TRUE, lower = 1) + R <- .ldmAsMatrix(correlation) + gr <- .ldmVariants(variants, R) + .ldmNew(gr, .ldmLabelled(R, gr), nSamples, numeric(0)) +} + +# @noRd +.ldmNew <- function(gr, R, nSamples, mixtureWeights) { + obj <- methods::new( + "LdMatrix", + gr, + correlation = R, + nSamples = as.integer(round(nSamples)), + mixtureWeights = as.numeric(mixtureWeights) + ) + validObject(obj) + obj +} + +# A plain numeric matrix: a Matrix-package matrix is made dense, as every +# consumer works on one. +# @noRd +#' @importFrom checkmate assertMatrix +.ldmAsMatrix <- function(correlation) { + if (methods::is(correlation, "Matrix")) { + correlation <- as.matrix(correlation) + } + assertMatrix( + correlation, + mode = "numeric", + any.missing = FALSE, + .var.name = "correlation" + ) + correlation +} + +# The matrix labelled by the variant ids. A matrix that already carries +# labels must carry exactly these, in this order: a mismatch means the matrix +# and the variant table describe different variants, or the same ones in a +# different order. +# @noRd +.ldmLabelled <- function(R, gr) { + ids <- as.character(S4Vectors::mcols(gr)$SNP) + if (nrow(R) != length(ids) || ncol(R) != length(ids)) { + abort(glue( + "`correlation` is {nrow(R)} x {ncol(R)} but `variants` lists ", + "{length(ids)} variant(s)." + )) + } + labelled <- !is.null(rownames(R)) || !is.null(colnames(R)) + if ( + labelled && + (!identical(rownames(R), ids) || !identical(colnames(R), ids)) + ) { + abort(c( + "`correlation`'s dimnames do not match the variant ids.", + i = str_c( + "Order the matrix as the variants are ordered, or drop its ", + "dimnames to label it by `variants`." + ) + )) + } + `dimnames<-`(R, list(ids, ids)) +} + +# The variant table, normalised to the GRanges an LdMatrix is: chr-prefixed +# seqnames (as a genotype panel's), names and `SNP` the ids, `A1` / `A2`, and +# `AF` when supplied. +# @noRd +.ldmVariants <- function(variants, R) { + tbl <- if (is.null(variants)) { + .ldmVariantsFromIds(rownames(R)) + } else if (methods::is(variants, "GRanges")) { + .ldmVariantsFromRanges(variants, rownames(R)) + } else if (is.data.frame(variants)) { + .ldmVariantsFromTable(variants, rownames(R)) + } else { + abort(glue( + "`variants` must be a GRanges, a data frame or NULL ", + "(got {class(variants)[[1L]]})." + )) + } + .ldmRangesOf(tbl) +} + +# @noRd +.ldmVariantsFromIds <- function(ids) { + if (is.null(ids)) { + abort(c( + "`variants` is required when the matrix has no dimnames.", + i = "Pass the variants, or label the matrix chrom:pos:A2:A1." + )) + } + parsed <- parseVariantId(ids) + if (anyNA(parsed$pos) || anyNA(parsed$A1)) { + abort(c( + "The matrix's dimnames are not chrom:pos:A2:A1 variant ids.", + i = "Pass `variants` to say which variants it covers." + )) + } + tibble( + SNP = ids, + chrom = parsed$chrom, + pos = parsed$pos, + A1 = parsed$A1, + A2 = parsed$A2 + ) +} + +# @noRd +.ldmVariantsFromRanges <- function(gr, ids) { + mc <- as.data.frame(S4Vectors::mcols(gr)) + .ldmVariantsFromTable( + mutate( + as_tibble(mc), + chrom = as.character(GenomicRanges::seqnames(gr)), + pos = GenomicRanges::start(gr), + SNP = .ldmIdsOf(mc, names(gr), ids) + ), + ids + ) +} + +# @noRd +.ldmVariantsFromTable <- function(tbl, ids) { + missingCols <- setdiff(c("chrom", "pos", "A1", "A2"), colnames(tbl)) + if (length(missingCols) > 0L) { + abort(glue( + "`variants` lacks column(s) {str_flatten(missingCols, ', ')}." + )) + } + snp <- if (is_in("SNP", colnames(tbl))) { + as.character(tbl$SNP) + } else { + .ldmIdsOf(tbl, NULL, ids) + } + out <- tibble( + SNP = snp %||% + formatVariantId( + canonChrom(as.character(tbl$chrom)), + as.integer(tbl$pos), + as.character(tbl$A2), + as.character(tbl$A1) + ), + chrom = as.character(tbl$chrom), + pos = as.integer(tbl$pos), + A1 = as.character(tbl$A1), + A2 = as.character(tbl$A2) + ) + if (is_in("AF", colnames(tbl))) { + mutate(out, AF = as.numeric(tbl$AF)) + } else { + out + } +} + +# The ids a variant table names, in order of preference: its own SNP or +# variant_id column, then the ranges' names, then the matrix's dimnames. +# NULL when none of those exist. +# @noRd +.ldmIdsOf <- function(tbl, rangeNames, ids) { + if (is_in("SNP", colnames(tbl))) { + return(as.character(tbl$SNP)) + } + if (is_in("variant_id", colnames(tbl))) { + return(as.character(tbl$variant_id)) + } + if (!is.null(rangeNames)) { + return(as.character(rangeNames)) + } + ids +} + +# @noRd +.ldmRangesOf <- function(tbl) { + if (anyDuplicated(tbl$SNP) > 0L) { + abort("The variant ids must be unique.") + } + gr <- GenomicRanges::GRanges( + seqnames = withChrPrefix(as.character(tbl$chrom)), + ranges = IRanges::IRanges(as.integer(tbl$pos), width = 1L) + ) + S4Vectors::`mcols<-`( + `names<-`(gr, tbl$SNP), + value = S4Vectors::DataFrame( + select(tbl, -all_of(c("chrom", "pos"))), + row.names = NULL + ) + ) +} + +# ---- mixtures --------------------------------------------------------------- + +# The weighted average of several LD matrices, over the variants they all +# cover, in the first component's allele coding. +# @noRd +.ldmMixture <- function(components, mixtureWeights) { + .ldmAssertComponents(components) + w <- .ldmAssertWeights(mixtureWeights, length(components)) + ref <- components[[1L]] + matched <- map(components, .ldmMatchTo, ref = ref) + common <- sort(reduce(map(matched, "refIdx"), intersect)) + if (length(common) == 0L) { + abort("The LD matrices share no variant to combine over.") + } + .ldmReportDropped(length(ref) - length(common), length(common)) + aligned <- map(matched, .ldmAlignedOn, common = common) + R <- reduce( + seq_along(components), + .ldmAddComponent, + .init = NULL, + components = components, + aligned = aligned, + w = w + ) + ids <- rownames(ref@correlation)[common] + gr <- .ldmMixtureVariants(ref[common], components, aligned, w) + obj <- methods::new( + "LdMatrix", + gr, + correlation = `dimnames<-`(R, list(ids, ids)), + nSamples = .ldmMixtureN(map_int(components, nSamples), w), + mixtureWeights = w + ) + validObject(obj) + obj +} + +# @noRd +.ldmAssertComponents <- function(components) { + isLd <- map_lgl(components, methods::is, class2 = "LdMatrix") + if (length(components) < 2L || !all(isLd)) { + abort(c( + "A mixture needs a list of at least two LdMatrix objects.", + i = str_c( + "Build each component with LdMatrix(), then combine them ", + "with LdMatrix(list(...), mixtureWeights = ...)." + ) + )) + } +} + +# @noRd +.ldmAssertWeights <- function(w, k) { + if ( + is.null(w) || + !is.numeric(w) || + length(w) != k || + anyNA(w) || + any(w < 0) || + abs(sum(w) - 1) > 1e-8 + ) { + abort(glue( + "`mixtureWeights` must be {k} non-negative weights summing to 1, ", + "one per component." + )) + } + as.numeric(w) +} + +# Where each of `ref`'s variants sits in `x`, and with which allele sign. +# @noRd +.ldmMatchTo <- function(x, ref) { + m <- matchVariants( + .ldRefMatchIds(ref), + .ldRefMatchIds(x), + removeStrandAmbiguous = FALSE + ) + list(refIdx = m$idxA, idx = m$idxB, sign = m$sign) +} + +# A component's positions and signs for the shared variants, in `ref` order. +# @noRd +.ldmAlignedOn <- function(matched, common) { + at <- match(common, matched$refIdx) + list(idx = matched$idx[at], sign = matched$sign[at]) +} + +# A component's matrix over the shared variants, re-signed into the first +# component's allele coding: a swapped variant's dosage counts the other +# allele, which negates each of its correlations. +# @noRd +.ldmAlignedR <- function(x, aligned) { + R <- unname(x@correlation[aligned$idx, aligned$idx, drop = FALSE]) + if (all(aligned$sign > 0)) { + return(R) + } + R * outer(aligned$sign, aligned$sign) +} + +# Add the k-th component's weighted, aligned matrix to the running sum, so only +# one aligned copy exists at a time rather than every component's at once. +# @noRd +.ldmAddComponent <- function(acc, k, components, aligned, w) { + term <- w[[k]] * .ldmAlignedR(components[[k]], aligned[[k]]) + if (is.null(acc)) term else acc + term +} + +# The mixture's variant table: the first component's, with AF the weighted +# average of the components' (each put into the first component's coding) +# when every component records one. +# @noRd +.ldmMixtureVariants <- function(gr, components, aligned, w) { + afs <- map2(components, aligned, .ldmAlignedAf) + mc <- S4Vectors::mcols(gr) + mc$AF <- if (any(map_lgl(afs, is.null))) { + NULL + } else { + reduce(map2(w, afs, `*`), `+`) + } + S4Vectors::`mcols<-`(gr, value = mc) +} + +# @noRd +.ldmAlignedAf <- function(x, aligned) { + af <- S4Vectors::mcols(x)$AF + if (is.null(af)) { + return(NULL) + } + af <- as.numeric(af)[aligned$idx] + if_else(aligned$sign > 0, af, 1 - af) +} + +# 1 / sum(w^2 / n): the size of one panel whose LD is as noisy as the mixture. +# @noRd +.ldmMixtureN <- function(n, w) { + if (anyNA(n)) { + return(NA_integer_) + } + as.integer(round(1 / sum(w^2 / n))) +} + +# @noRd +.ldmReportDropped <- function(nDropped, nKept, what = "LdMatrix") { + if (nDropped == 0L) { + return(invisible(NULL)) + } + inform(glue( + "{what}: {nDropped} variant(s) of the first component are not in ", + "every component and are left out; the mixture covers {nKept}." + )) +} + +# ---- subsetting ------------------------------------------------------------- + +# Subsetting the variants subsets the matrix with them, so the two never fall +# out of step. +setMethod("extractROWS", "LdMatrix", function(x, i) { + i <- normalizeSingleBracketSubscript(i, x) + ans <- methods::callNextMethod(x, i) + ans@correlation <- x@correlation[i, i, drop = FALSE] + ans +}) + +# ---- accessors -------------------------------------------------------------- + +#' @rdname ldMatrix +#' @export +setMethod("ldMatrix", "LdMatrix", function(x) x@correlation) + +#' @rdname nSamples +#' @export +setMethod("nSamples", "LdMatrix", function(x, ...) x@nSamples) + +#' @rdname mixtureWeights +#' @export +setMethod("mixtureWeights", "LdMatrix", function(x) { + if (length(x@mixtureWeights) == 0L) NULL else x@mixtureWeights +}) + +#' @rdname variantIds +#' @export +setMethod("variantIds", "LdMatrix", function(x, ...) { + as.character(S4Vectors::mcols(x)$SNP) +}) + +#' @rdname af +#' @export +setMethod("af", "LdMatrix", function(x, ...) { + af <- S4Vectors::mcols(x)$AF + ids <- as.character(S4Vectors::mcols(x)$SNP) + set_names(if (is.null(af)) rep(NA_real_, length(ids)) else af, ids) +}) + +#' @rdname LdMatrix-class +#' @param object An \code{LdMatrix}. +#' @export +setMethod("show", "LdMatrix", function(object) { + n <- if (is.na(object@nSamples)) "unknown" else object@nSamples + cat(glue( + "LdMatrix: {length(object)} variants, panel size {n}\n", + .trim = FALSE + )) + w <- object@mixtureWeights + if (length(w) > 0L) { + cat(glue( + " mixture of {length(w)} panels, weights ", + "{str_flatten(signif(w, 3), ', ')}\n", + .trim = FALSE + )) + } + if (!is_in("AF", colnames(S4Vectors::mcols(object)))) { + cat(" no allele frequencies\n") + } +}) diff --git a/R/LdScore.R b/R/LdScore.R index 80223afc8..6442a3068 100644 --- a/R/LdScore.R +++ b/R/LdScore.R @@ -1,9 +1,10 @@ # ============================================================================= # LdScore S4 class # ----------------------------------------------------------------------------- -# Pre-computed LD scores (sum of r^2) per SNP. Consumed by S-LDSC and -# g-LDSC. Holds the optional per-block LD matrices needed for g-LDSC's -# FGLS residual covariance. +# Pre-computed LD scores (sum of ldsc's unbiased r^2) per SNP. Consumed by +# S-LDSC and g-LDSC. g-LDSC's FGLS residual covariance also needs each block's +# LD: stored per block for LdMatrix input, read from the genotype panel on +# demand for panel input. # ============================================================================= #' @include LdStatistic.R @@ -17,8 +18,17 @@ NULL #' slots, because they are parallel to the variants: as slots they would #' survive a subset unchanged while the ranges narrowed, leaving scores #' describing variants that are no longer there. -#' @slot ldMatrixList For g-LDSC: a list of per-block LD (R^2) matrices used to -#' compute the FGLS residual covariance. Empty for S-LDSC. +#' +#' An \code{LdScore} storing per-block LD matrices (\code{ldMatrixList}) +#' cannot be subset or reordered: each block's matrix indexes its variants +#' by position, so narrowing the variants would leave it describing other +#' variants. A scores-only object, or one reading its LD from a genotype +#' panel, subsets freely. +#' @slot ldMatrixList For g-LDSC: a list of per-block LD correlation (R) +#' matrices used to compute the FGLS residual covariance, kept when the +#' scores were built from \code{LdMatrix} blocks. Empty for a scores-only +#' object, and for one built from a genotype panel, which reads each +#' block's LD from the panel instead (see \code{\linkS4class{LdStatistic}}). #' @export setClass( "LdScore", @@ -50,7 +60,8 @@ setClass( #' @param snpInfo A \code{data.frame} with columns \code{SNP}, \code{CHR}, #' \code{BP}, \code{A1}, \code{A2} (and optionally \code{MAF}). #' @param ldScores A numeric matrix, one row per variant. The first column is -#' the base LD score (sum of r^2); further columns are +#' the base LD score (sum of r^2, which \code{\link{buildLdScore}} takes as +#' ldsc's unbiased r^2, as ldsc's own score files do); further columns are #' annotation-stratified scores. #' @param ldScoreWeights Numeric regression weights, one per variant. #' @param ldBlocks A \code{GRanges} of LD block intervals. @@ -109,56 +120,71 @@ LdScore <- function( } #' @importFrom checkmate assertCount assertFlag -#' @title Build an LdScore from loaded LD -#' @description Compute per-variant LD scores from already-loaded LD, block by +#' @title Build an LdScore from an LD reference +#' @description Compute per-variant LD scores from an LD reference, block by #' block, into the \code{LdScore} that \code{\link{estimateH2}} consumes #' for \code{method = "gldsc"}. This is the supported route from an LD #' reference to an h2 input: \code{\link{LdScore}} itself is the low-level #' constructor and expects the scores to have been computed already. #' -#' The score is \eqn{\ell_j = \sum_k r^2_{jk}} within each block, the same -#' quantity \code{\link{computeLdScores}} reconstructs from an -#' \code{\link{LdEigen}}, so the two agree on a shared reference. +#' The score is \eqn{\ell_j = \sum_k r^2_{jk}} within each block, with +#' each term ldsc's unbiased estimate of \eqn{r^2} (Bulik-Sullivan et al. +#' 2015, \code{ldscore.py}): \code{r^2 - (1 - r^2) / (n - 2)}, where +#' \code{n} is the reference panel sample size. A sample \eqn{r^2} +#' overstates the population value by about \code{(1 - r^2) / (n - 2)}, +#' and a block sums many of them. A variant's own term stays 1, and +#' negative estimates are kept, as in ldsc. \code{\link{computeLdScores}} +#' gives the same scores from an \code{\link{LdEigen}} built on the same +#' reference. #' -#' No file I/O happens here. Read the LD first with -#' \code{\link{loadLdMatrix}} -- passing a vector of regions returns one -#' \code{LdData} per block -- then pass the result in. -#' @param ldBlockData An \code{\link{LdData}}, or a list of them, covering -#' the reference variants. An \code{LdData} whose correlation is a list of -#' per-block matrices contributes one LD block per matrix; one whose -#' correlation is a single matrix contributes one block. Blocks are kept in -#' the order given, and that order defines the variant order of the result. +#' @param ldReference The LD reference, block by block: a list of +#' \code{\link{LdMatrix}} objects, one per LD block (a single +#' \code{LdMatrix} is one block), or a genotype panel (see +#' \code{\link{readGenotypes}}) together with \code{ldBlocks}. Blocks are +#' kept in the order given, and that order defines the variant order of the +#' result. #' #' Block structure matters downstream: \code{\link{estimateH2}} takes its #' standard error from a delete-one-block jackknife, so it requires at -#' least two blocks and wants many more. Loading a whole region as one -#' dense matrix yields a single block. -#' @param nSamples Integer, the LD reference panel sample size. Defaults to the -#' size recorded by the supplied \code{LdData}; required when they record -#' none, and an error when they disagree. +#' least two blocks and wants many more. +#' @param ldBlocks With a genotype panel, the LD blocks to cut it into: a +#' \code{GRanges}, or a data frame with columns \code{chrom}, \code{start} +#' and \code{end}. Each block's LD is computed from the panel variants +#' inside it; variants outside every block are left out. Not used with +#' \code{LdMatrix} blocks. +#' @param nSamples Integer, the number of samples the reference's LD was +#' estimated from. Defaults to a panel's sample count (a stochastic +#' sketch's effective size), or the size the \code{LdMatrix} blocks record; +#' required when they record none, and an error when they disagree. It is +#' also the \code{n} of the unbiased \eqn{r^2}, and it must exceed 2. #' @param inSample Logical, whether the reference is the GWAS cohort itself. #' @param genome Character, genome build. Defaults to the build recorded by -#' the supplied \code{LdData}, which \code{\link{loadLdMatrix}} leaves -#' unset. +#' the reference's variants. #' @param ldScoreWeights Optional numeric regression weights, one per variant. #' Defaults to the conventional \eqn{1/\max(\ell_j, 1)}. -#' @param keepLdMatrices Logical. Keep each block's LD matrix on the result. -#' \code{TRUE} (the default) is required for \code{method = "gldsc"}, -#' which forms its FGLS residual covariance from them and errors without -#' them. \code{FALSE} drops them, leaving a scores-only object. -#' @return An \code{LdScore} over every variant in \code{ldBlockData}. +#' @param keepLdMatrices Logical, for \code{LdMatrix} blocks: keep each +#' block's LD matrix on the result. \code{TRUE} (the default) is required +#' for \code{method = "gldsc"} and for annotation-stratified scores, which +#' need each block's LD. \code{FALSE} drops them, leaving a scores-only +#' object. A genotype panel is never copied into matrices: the result keeps +#' the panel and reads each block's LD from it when it is needed, so it +#' serves every method either way. +#' @return An \code{LdScore} over every variant in the reference's blocks. #' @seealso \code{\link{buildLdEigen}} for the LDER / HDL input, #' \code{\link{estimateH2}}, \code{\link{computeLdScores}} #' @examples -#' meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", -#' package = "pecotmr") -#' ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") -#' ldScore <- buildLdScore(ld, genome = "hg38") +#' panel <- readGenotypes(plink2Prefix = file.path(system.file("extdata", +#' "ld_reference", "chr22", package = "pecotmr"), +#' "protocol_example.LD.chr22")) +#' blocks <- data.frame(chrom = "chr22", start = c(10000000, 15000001), +#' end = c(15000000, 19000000)) +#' ldScore <- buildLdScore(panel, ldBlocks = blocks, genome = "hg38") #' ldScore #' head(S4Vectors::mcols(ldScore)$ldScores) #' @export buildLdScore <- function( - ldBlockData, + ldReference, + ldBlocks = NULL, nSamples = NULL, inSample = FALSE, genome = NA_character_, @@ -168,14 +194,14 @@ buildLdScore <- function( assertCount(nSamples, positive = TRUE, null.ok = TRUE) assertFlag(inSample) assertFlag(keepLdMatrices) - prep <- .ldRefPrepare(ldBlockData, nSamples, genome) - l2 <- .ldScoreVector(prep$blocks, prep$snpIdx, nrow(prep$snpInfo)) - ldMatrixList <- if (isTRUE(keepLdMatrices)) { + prep <- .h2RefPrepare(ldReference, ldBlocks, nSamples, genome) + l2 <- .ldScoreVector(prep, .ldscAssertN(prep$nRef)) + ldMatrixList <- if (isTRUE(keepLdMatrices) && is.null(prep$ldReference)) { map2(prep$blocks, prep$snpIdx, .ldScoreKeepMatrix) } else { list() } - LdScore( + scores <- LdScore( snpInfo = prep$snpInfo, ldScores = matrix(l2, ncol = 1, dimnames = list(NULL, "base_l2")), ldScoreWeights = .ldScoreResolveWeights(ldScoreWeights, l2), @@ -185,27 +211,78 @@ buildLdScore <- function( genome = prep$genome, ldMatrixList = ldMatrixList ) + .ldStatAttachReference(scores, prep) +} + +# Per-variant sum of ldsc's unbiased r^2 within the variant's own block, in +# reference order. The blocks partition the variants, which are stacked +# block by block, so the blocks' sums concatenate into place; a genotype +# panel's blocks are read one at a time. +# @noRd +.ldScoreVector <- function(prep, nRef) { + blocks <- map2(prep$blocks, prep$snpIdx, .ldScoreBuildBlock) + list_c(map( + blocks, + .ldScoreBlockSums, + ldReference = prep$ldReference, + nRef = nRef + )) +} + +# A block of the reference being built, as the record the block readers take. +# @noRd +.ldScoreBuildBlock <- function(block, snpIdx) { + list(idx = snpIdx, R = block$R, rows = block$rows) +} + +# One block's base LD scores: the raw sums of r^2 over the block, corrected to +# ldsc's unbiased r^2 by its summed form. +# @noRd +.ldScoreBlockSums <- function(block, ldReference, nRef) { + ld <- .ldStatBlockLd(block, ldReference) + p <- .ldSourceSize(ld) + raw <- .ldSquaredProduct(ld, matrix(1, p, 1L)) + as.vector(.ldscUnbiasedSum(raw, p, nRef)) } -# Per-variant sum of r^2 within the variant's own block, scattered back into -# reference order. +# ldsc's unbiased estimator of r^2 (ldscore.py, __l2_unbiased__): a sample +# r^2 overstates the population value by about (1 - r^2) / (n - 2). The self +# term (r^2 = 1) stays 1, and negative estimates are kept, as in ldsc. Every +# LD score pecotmr computes goes through this or its summed form below. # @noRd -.ldScoreVector <- function(blocks, snpIdx, nVariants) { - if (length(blocks) == 0L) { - return(numeric(nVariants)) +.ldscUnbiasedR2 <- function(r2, nRef) { + r2 - (1 - r2) / (nRef - 2) +} + +# .ldscUnbiasedR2() summed over a block with weights a_k: +# sum_k a_k (r2_jk - (1 - r2_jk) / (n - 2)) +# = ((n - 1) * sum_k a_k r2_jk - sum_k a_k) / (n - 2). +# Exact, so a route that has the raw weighted sums but not r^2 itself -- an +# eigendecomposition -- corrects them without rebuilding the matrix. +# `rawSums` is variants x columns; `weightSums` holds each column's sum_k a_k +# over the block, which for the unweighted base score is the block size. +# @noRd +.ldscUnbiasedSum <- function(rawSums, weightSums, nRef) { + sweep((nRef - 1) * rawSums, 2L, weightSums) / (nRef - 2) +} + +# ldsc's unbiased r^2 divides by n - 2, so the panel must exceed 2 samples. +# @noRd +.ldscAssertN <- function(nRef) { + if (nRef > 2L) { + return(nRef) } - # The blocks partition the variants, so each variant's score lands in - # exactly one place; variants in no block stay zero. - replace( - numeric(nVariants), - list_c(snpIdx), - list_c(map(blocks, .ldScoreBlockSums)) - ) + abort(glue( + "ldsc's unbiased r^2 divides by n - 2, so the LD reference panel ", + "needs more than 2 samples, and it records {nRef}. Give the panel's ", + "size as `nSamples`." + )) } +# The n of ldsc's unbiased r^2 for a built LD reference: its panel size. # @noRd -.ldScoreBlockSums <- function(block) { - rowSums(block$R^2) +.ldscPanelN <- function(ldRef) { + .ldscAssertN(ldPanelNSamples(ldRef)) } # @noRd @@ -233,17 +310,76 @@ setMethod("show", "LdScore", function(object) { "{ncol(scores)} LD score columns\n", .trim = FALSE )) - cat(glue( - " Full LD matrices: {length(object@ldMatrixList) > 0} ", - "(needed for g-LDSC)\n", - .trim = FALSE - )) + cat(glue(" Block LD: {.ldScoreLdSource(object)}\n", .trim = FALSE)) cat(glue( " Reference N: {object@nSamples}, In-sample: {object@inSample}\n", .trim = FALSE )) }) +# Where an LdScore's per-block LD comes from, as show() describes it. +# @noRd +.ldScoreLdSource <- function(x) { + if (!is.null(x@ldReference)) { + return("read from the genotype panel when needed") + } + if (length(x@ldMatrixList) > 0L) { + return("stored matrices") + } + "none (scores only; g-LDSC and stratified scores need it)" +} + +# TRUE when each block's LD can be had: stored, or read from the panel. +# @noRd +.ldScoreHasLd <- function(x) { + !is.null(x@ldReference) || length(x@ldMatrixList) > 0L +} + +# The block records of an LdScore (see .ldStatLazyBlocks()). +# @noRd +.ldScoreBlocks <- function(x) { + if (length(x@ldMatrixList) > 0L) { + return(map(x@ldMatrixList, .ldScoreStoredBlock)) + } + .ldStatLazyBlocks(x) +} + +# @noRd +.ldScoreStoredBlock <- function(block) { + list(idx = block$snpIdx, R = block$R) +} + +# ---- subsetting ------------------------------------------------------------- + +# Stored block matrices index their variants by position (`snpIdx`), so a +# subset or reorder would leave them describing other variants. Without them +# each block's variants are found afresh from the ranges, so the subset is +# safe. Every subset -- `[`, head(), tail(), window(), subset() -- reaches the +# rows through extractROWS(). +setMethod("extractROWS", "LdScore", function(x, i) { + if (length(x@ldMatrixList) > 0L) { + abort(glue( + "an LdScore storing per-block LD matrices cannot be subset: each ", + "block's matrix indexes its variants by position, so narrowing ", + "or reordering the variants would leave it describing other ", + "variants. Rebuild the scores over the subset instead." + )) + } + methods::callNextMethod() +}) + #' @rdname ldMatrixList #' @export -setMethod("ldMatrixList", "LdScore", function(x) x@ldMatrixList) +setMethod("ldMatrixList", "LdScore", function(x) { + if (is.null(x@ldReference)) { + return(x@ldMatrixList) + } + map(.ldScoreBlocks(x), .ldScorePanelMatrix, ldReference = x@ldReference) +}) + +# One block's LD matrix computed from the panel an LdScore reads it from. +# @noRd +.ldScorePanelMatrix <- function(block, ldReference) { + F <- .ldRefFactor(ldReference, block$rows) + list(R = crossprod(F) / (nrow(F) - 1), snpIdx = block$idx) +} diff --git a/R/LdStatistic.R b/R/LdStatistic.R index c324cf174..bcd87248b 100644 --- a/R/LdStatistic.R +++ b/R/LdStatistic.R @@ -7,7 +7,7 @@ # LD-score-based methods (S-LDSC/g-LDSC). # ============================================================================= -#' @include AllGenerics.R LdBlocks.R +#' @include AllGenerics.R AllClasses.R LdBlocks.R NULL #' @title LD Statistic (Virtual Base Class) @@ -21,10 +21,21 @@ NULL #' live in \code{mcols} too, so subsetting narrows the ranges and the #' statistics together. The genome build comes from \code{seqinfo()} rather #' than a slot of its own. +#' +#' A statistic built from a genotype panel (or a +#' \code{\link{GenotypeMixture}}) keeps that reference rather than its +#' blocks' LD: each block's LD is read from the panel when an estimator +#' reaches the block, so only one block's is ever in memory, and +#' \code{mcols()} records each variant's row in the panel as +#' \code{panelRow}. One built from \code{\link{LdMatrix}} blocks stores +#' what it needs of their LD instead. #' @slot ldBlocks A \code{GRanges} of LD block intervals. #' @slot nSamples Integer, sample size of the LD reference panel. #' @slot inSample Logical, whether the LD reference is from the same cohort as #' the GWAS (affects bias correction). +#' @slot ldReference The genotype panel or \code{GenotypeMixture} the +#' statistic reads its blocks' LD from, or \code{NULL} when it was built +#' from \code{LdMatrix} blocks. #' @export setClass( "LdStatistic", @@ -32,8 +43,10 @@ setClass( representation( ldBlocks = "GRanges", nSamples = "integer", - inSample = "logical" + inSample = "logical", + ldReference = "LdReference_OR_NULL" ), + prototype(ldReference = NULL), validity = function(object) .validateLdStatistic(object) ) @@ -53,9 +66,41 @@ setClass( if (length(object) == 0L) { coll$push("an LdStatistic must carry at least one variant") } + referenceCheck <- .ldStatReferenceCheck(object) + if (!isTRUE(referenceCheck)) { + coll$push(referenceCheck) + } coll$getMessages() } +# A statistic read from a genotype reference finds each variant there by its +# `panelRow`, so every variant needs one, and it must be a row of the panel. +# @noRd +.ldStatReferenceCheck <- function(object) { + ref <- object@ldReference + if (is.null(ref)) { + return(TRUE) + } + if (!.ldIsGenotypeRef(ref)) { + return(str_c( + "`ldReference` must be a genotype panel or a GenotypeMixture: ", + "LdMatrix blocks are stored, not read on demand" + )) + } + rows <- S4Vectors::mcols(object, use.names = FALSE)$panelRow + nRows <- length(.ldRefRanges(ref)) + valid <- is.integer(rows) && + !anyNA(rows) && + all(rows >= 1L & rows <= nRows) + if (valid) { + return(TRUE) + } + str_c( + "a statistic read from `ldReference` needs an integer `panelRow` ", + "column naming each variant's row in it" + ) +} + # The variants of an LD reference, as the GRanges every subclass is built on. # Shared by the LdScore() and LdEigen() constructors so the two agree on what # a reference panel's variant table looks like. @@ -98,146 +143,161 @@ setClass( } # ============================================================================= -# Building an LD statistic from already-loaded LD +# Building an LD statistic from an LD reference # ----------------------------------------------------------------------------- -# buildLdEigen() and buildLdScore() both start from LD that has already been -# read -- one or more LdData, as loadLdMatrix() returns them -- -# and differ only in what they compute per block. Everything before that -# (splitting into blocks, assembling the variant table, resolving nRef and the -# genome build) is shared, so it lives here next to .ldStatRanges(). +# buildLdEigen() and buildLdScore() both start from an LD reference -- one +# LdMatrix per LD block, or a genotype panel cut at the blocks' spans -- and +# differ only in what they compute per block. Everything before that +# (splitting into blocks, assembling the variant table, resolving nRef and +# the genome build) is shared, so it lives here next to .ldStatRanges(). # ============================================================================= # Shared front half of buildLdEigen()/buildLdScore(): validate the input, -# split it into blocks, and resolve what the LdStatistic base needs. +# split it into blocks, and resolve what the LdStatistic base needs. A +# genotype reference is kept, with each variant's row in it, for the +# statistic to read its blocks from. # @noRd -.ldRefPrepare <- function(ldBlockData, nSamples, genome) { - dataList <- .ldRefAsDataList(ldBlockData) - blocks <- list_flatten(map(dataList, .ldRefBlocksOf)) - resolvedGenome <- .ldRefResolveGenome(dataList, genome) +.h2RefPrepare <- function(ldReference, ldBlocks, nSamples, genome) { + blocks <- .h2RefBlocks(ldReference, ldBlocks) + resolvedGenome <- .h2RefResolveGenome(ldReference, genome) + lazy <- .ldIsGenotypeRef(ldReference) list( blocks = blocks, - snpInfo = .ldRefSnpInfo(blocks), - snpIdx = .ldRefSnpIdx(blocks), - ldBlocks = .ldRefBlockRanges(blocks, resolvedGenome), - nRef = .ldRefResolveNRef(dataList, nSamples), - genome = resolvedGenome + snpInfo = .h2RefSnpInfo(blocks), + snpIdx = .h2RefSnpIdx(blocks), + ldBlocks = .h2RefBlockRanges(blocks, resolvedGenome), + nRef = .h2RefResolveNRef(ldReference, nSamples), + genome = resolvedGenome, + ldReference = if (lazy) ldReference, + panelRow = if (lazy) list_c(map(blocks, "rows")) ) } -# Accept a single LdData as well as a list of them. +# The reference's LD blocks: list(R, gr) per LdMatrix, or list(rows, gr) per +# block a genotype panel is cut into at `ldBlocks` -- the panel rows whose LD +# is computed when it is needed, not here. # @noRd -.ldRefAsDataList <- function(ldBlockData) { - if (is(ldBlockData, "LdData")) { - return(list(ldBlockData)) +.h2RefBlocks <- function(ldReference, ldBlocks) { + if (.ldIsGenotypeRef(ldReference)) { + return(.h2RefPanelBlocks(ldReference, ldBlocks)) } - if (!is.list(ldBlockData) || length(ldBlockData) == 0L) { - abort(glue( - "`ldBlockData` must be an LdData or a non-empty list of them ", - "(got {class(ldBlockData)[[1L]]})." + if (!is.null(ldBlocks)) { + abort(c( + "`ldBlocks` cuts a genotype panel into LD blocks.", + i = "A list of LdMatrix objects is already one block per element." )) } - bad <- which(!map_lgl(ldBlockData, is, class2 = "LdData")) - if (length(bad) > 0L) { - abort(glue( - "`ldBlockData` element(s) {str_flatten(bad, ', ')} are not ", - "LdData objects." + map(.h2RefMatrixList(ldReference), .h2RefMatrixBlock) +} + +# A single LdMatrix is one block; a list must hold LdMatrix objects only. +# @noRd +.h2RefMatrixList <- function(ldReference) { + if (.ldIsMatrixRef(ldReference)) { + return(list(ldReference)) + } + isList <- is.list(ldReference) && + length(ldReference) > 0L && + all(map_lgl(ldReference, .ldIsMatrixRef)) + if (!isList) { + abort(c( + str_c( + "`ldReference` must be a genotype panel, an LdMatrix, or a ", + "non-empty list of LdMatrix objects (one per LD block)." + ), + i = glue("Got {class(ldReference)[[1L]]}.") )) } - ldBlockData + ldReference } -# The per-block LD matrices of one LdData, each paired with the variants it -# describes. An LdData holds either a single matrix (one block) or a list of -# them (block-diagonal LD across a multi-block region). # @noRd -.ldRefBlocksOf <- function(x) { - R <- ldMatrix(x) - gr <- variantInfo(x) - if (!is.list(R)) { - return(list(.ldRefOneBlock(R, gr))) - } - idx <- .ldRefBlockIndices(x, R, length(gr)) - map2(R, idx, .ldRefBlockFromIdx, gr = gr) +.h2RefMatrixBlock <- function(x) { + list(R = ldMatrix(x), gr = as(x, "GRanges")) } +# A genotype panel cut into the LD blocks `ldBlocks` spans. Each block holds +# the panel variants inside it, whose LD is computed from their dosages; +# variants outside every block are not part of the reference, and a variant +# inside two blocks would be scored twice, so overlapping blocks are refused. # @noRd -.ldRefBlockFromIdx <- function(R, idx, gr) { - .ldRefOneBlock(R, gr[idx]) +.h2RefPanelBlocks <- function(panel, ldBlocks) { + if (is.null(ldBlocks)) { + abort(c( + "`ldBlocks` is required with a genotype panel.", + i = "It says where each LD block starts and ends." + )) + } + # A panel's seqnames are chr-prefixed; a block table may not be. + blocks <- .asLdBlockRanges(ldBlocks) + spans <- GenomeInfoDb::renameSeqlevels( + blocks, + withChrPrefix(GenomeInfoDb::seqlevels(blocks)) + ) + gr <- .ldRefRanges(panel) + hits <- GenomicRanges::findOverlaps(gr, spans) + if (anyDuplicated(S4Vectors::queryHits(hits)) > 0L) { + abort("`ldBlocks` overlap: a variant may sit in only one LD block.") + } + idx <- compact(map( + seq_along(spans), + .h2RefSpanIdx, + hits = hits + )) + if (length(idx) == 0L) { + abort("None of the panel's variants falls inside `ldBlocks`.") + } + map(idx, .h2RefPanelBlockAt, panel = panel, gr = gr) } +# The panel rows inside block `k`, in panel order, or NULL for an empty block. # @noRd -#' @importFrom checkmate assertMatrix -.ldRefOneBlock <- function(R, gr) { - R <- as.matrix(R) - assertMatrix(R, nrows = length(gr), .var.name = "LD block correlation") - list(R = R, gr = gr) +.h2RefSpanIdx <- function(k, hits) { + idx <- sort(S4Vectors::queryHits(hits)[S4Vectors::subjectHits(hits) == k]) + if (length(idx) == 0L) NULL else idx } -# Which variants each block matrix covers. blockMetadata's startIdx/endIdx is -# authoritative when it lines up with the matrices; otherwise the blocks are -# taken in order, each covering as many variants as its matrix has rows. # @noRd -.ldRefBlockIndices <- function(x, R, nVariants) { - sizes <- map_int(R, nrow) - if (sum(sizes) != nVariants) { - abort(glue( - "the LD block matrices cover {sum(sizes)} variant(s) but the ", - "LdData carries {nVariants}." - )) - } - md <- blockMetadata(x) - # blockMetadata is a GRanges: the index payload is in mcols. - hasIdx <- all(is_in( - c("startIdx", "endIdx"), - names(S4Vectors::mcols(md)) - )) && - length(md) == length(R) - if (hasIdx) { - return(map2(as.integer(md$startIdx), as.integer(md$endIdx), seq.int)) - } - ends <- cumsum(sizes) - map2(as.integer(ends - sizes + 1L), as.integer(ends), seq.int) +.h2RefPanelBlockAt <- function(idx, panel, gr) { + list(rows = idx, gr = gr[idx]) } # Global (concatenated) variant positions of each block. # @noRd -.ldRefSnpIdx <- function(blocks) { - sizes <- map_int(blocks, .ldRefBlockSize) +.h2RefSnpIdx <- function(blocks) { + sizes <- map_int(blocks, .h2RefBlockSize) ends <- cumsum(sizes) map2(as.integer(ends - sizes + 1L), as.integer(ends), seq.int) } # @noRd -.ldRefBlockSize <- function(block) length(block$gr) +.h2RefBlockSize <- function(block) length(block$gr) # The variant table .ldStatRanges() expects, stacked over the blocks in -# order. An LdData names its variants `variant_id`, and reports frequency as -# allele_freq rather than MAF. +# order. Both kinds of reference name their variants `SNP`; frequency comes +# from `AF` (an LdMatrix's, or a stochastic sketch's recorded one) as MAF. # @noRd -.ldRefSnpInfo <- function(blocks) { - bind_rows(map(blocks, .ldRefSnpInfoOne)) +.h2RefSnpInfo <- function(blocks) { + bind_rows(map(blocks, .h2RefSnpInfoOne)) } # @noRd -.ldRefSnpInfoOne <- function(block) { +.h2RefSnpInfoOne <- function(block) { gr <- block$gr md <- S4Vectors::mcols(gr, use.names = FALSE) info <- tibble( - SNP = .ldRefVariantIds(gr, md), + SNP = .h2RefVariantIds(gr, md), CHR = as.character(seqnames(gr)), BP = as.integer(start(gr)), - A1 = .ldRefAllele(md, "A1"), - A2 = .ldRefAllele(md, "A2") + A1 = .h2RefAllele(md, "A1"), + A2 = .h2RefAllele(md, "A2") ) - maf <- .ldRefMaf(md) + maf <- .h2RefMaf(md) if (is.null(maf)) info else mutate(info, MAF = maf) } # @noRd -.ldRefVariantIds <- function(gr, md) { - if (is_in("variant_id", colnames(md))) { - return(as.character(md$variant_id)) - } +.h2RefVariantIds <- function(gr, md) { if (is_in("SNP", colnames(md))) { return(as.character(md$SNP)) } @@ -248,7 +308,7 @@ setClass( } # @noRd -.ldRefAllele <- function(md, which) { +.h2RefAllele <- function(md, which) { if (!is_in(which, colnames(md))) { abort(glue( "the LD reference's variants carry no `{which}` column; an ", @@ -259,37 +319,35 @@ setClass( } # @noRd -.ldRefMaf <- function(md) { - if (is_in("MAF", colnames(md))) { - return(as.numeric(md$MAF)) +.h2RefMaf <- function(md) { + if (!is_in("AF", colnames(md))) { + return(NULL) } - if (is_in("allele_freq", colnames(md))) { - af <- as.numeric(md$allele_freq) - return(pmin(af, 1 - af)) - } - NULL + af <- as.numeric(md$AF) + pmin(af, 1 - af) } # One range per block, spanning the variants it covers. These are the blocks # the jackknife leaves out one at a time, so they must line up with -# eigenList / ldMatrixList element for element. +# eigenList / ldMatrixList element for element; a statistic read from a panel +# finds each block's variants by placing them in these ranges. # @noRd -.ldRefBlockRanges <- function(blocks, genome) { +.h2RefBlockRanges <- function(blocks, genome) { gr <- GRanges( - seqnames = map_chr(blocks, .ldRefBlockChrom), + seqnames = map_chr(blocks, .h2RefBlockChrom), ranges = IRanges::IRanges( - start = map_int(blocks, .ldRefBlockStart), - end = map_int(blocks, .ldRefBlockEnd) + start = map_int(blocks, .h2RefBlockStart), + end = map_int(blocks, .h2RefBlockEnd) ) ) - .withGenomeBuild(gr, .ldRefNamedGenome(genome), genome) + .withGenomeBuild(gr, .h2RefNamedGenome(genome), genome) } -# An LD block is within-chromosome by construction, and .ldRefBlockRanges() +# An LD block is within-chromosome by construction, and .h2RefBlockRanges() # collapses each to a single range, so a block spanning chromosomes would # silently get a range covering everything between them. # @noRd -.ldRefBlockChrom <- function(block) { +.h2RefBlockChrom <- function(block) { chrom <- unique(withChrPrefix(as.character(seqnames(block$gr)))) if (length(chrom) != 1L) { abort(glue( @@ -301,60 +359,75 @@ setClass( } # @noRd -.ldRefBlockStart <- function(block) as.integer(min(start(block$gr))) +.h2RefBlockStart <- function(block) as.integer(min(start(block$gr))) # @noRd -.ldRefBlockEnd <- function(block) as.integer(max(start(block$gr))) +.h2RefBlockEnd <- function(block) as.integer(max(start(block$gr))) # @noRd -.ldRefNamedGenome <- function(genome) { +.h2RefNamedGenome <- function(genome) { !is.null(genome) && length(genome) == 1L && !is.na(genome) && nzchar(genome) } -# nRef comes from the LdData unless the caller names one. Differing panel -# sizes are an error rather than a silent pick: nRef drives HDL's -# finite-reference correction, so the wrong one shifts h2. +# nRef is the number of independent samples the reference's LD is worth -- +# a panel's sample count, a sketch's effective size, or what each LdMatrix +# records -- unless the caller names one with `nSamples`. Differing sizes +# across LdMatrix blocks are an error rather than a silent pick: nRef drives +# HDL's finite-reference correction and the n of ldsc's unbiased r^2 in the +# LD scores, so the wrong one shifts h2. # @noRd -.ldRefResolveNRef <- function(dataList, nSamples) { +.h2RefResolveNRef <- function(ldReference, nSamples) { if (!is.null(nSamples)) { return(as.integer(nSamples)) } - found <- discard(unique(map_int(dataList, .ldRefNRefOf)), is.na) + if (.ldIsGenotypeRef(ldReference)) { + return(as.integer(.ldRefNoiseN(ldReference))) + } + found <- discard( + unique(map_int(.h2RefMatrixList(ldReference), .h2RefNSamplesOf)), + is.na + ) if (length(found) == 0L) { - abort(glue( - "`nRef` is required: none of the supplied LdData records a ", - "reference panel sample size." + abort(c( + "`nSamples` is required: no LdMatrix records its panel's size.", + i = "Pass `nSamples`, or build them with LdMatrix(nSamples = )." )) } if (length(found) > 1L) { abort(glue( - "the supplied LdData record differing reference panel sizes ", - "({str_flatten(found, ', ')}); pass `nRef` to choose one." + "the LdMatrix blocks record differing reference panel sizes ", + "({str_flatten(found, ', ')}); pass `nSamples` to choose one." )) } found[[1L]] } +# A named helper rather than `nSamples` itself: inside .h2RefResolveNRef() +# that name is the formal, which would shadow the accessor in FUN position. # @noRd -.ldRefNRefOf <- function(x) { - n <- ldPanelNSamples(x) - if (length(n) == 0L) NA_integer_ else as.integer(n[[1L]]) +.h2RefNSamplesOf <- function(x) { + nSamples(x) } # @noRd -.ldRefResolveGenome <- function(dataList, genome) { - if (.ldRefNamedGenome(genome)) { +.h2RefResolveGenome <- function(ldReference, genome) { + if (.h2RefNamedGenome(genome)) { return(genome) } - found <- discard(unique(map_chr(dataList, .ldRefGenomeOf)), is.na) + refs <- if (.ldIsGenotypeRef(ldReference)) { + list(.ldRefRanges(ldReference)) + } else { + .h2RefMatrixList(ldReference) + } + found <- discard(unique(map_chr(refs, .h2RefGenomeOf)), is.na) if (length(found) == 1L) found[[1L]] else NA_character_ } # @noRd -.ldRefGenomeOf <- function(x) { +.h2RefGenomeOf <- function(x) { g <- discard(unique(GenomeInfoDb::genome(as(x, "GRanges"))), is.na) if (length(g) == 1L) g[[1L]] else NA_character_ } @@ -370,3 +443,103 @@ setMethod("inSample", "LdStatistic", function(x) x@inSample) #' @rdname ldBlocks #' @export setMethod("ldBlocks", "LdStatistic", function(x) x@ldBlocks) + +#' @rdname ldReference +#' @export +setMethod("ldReference", "LdStatistic", function(x) x@ldReference) + +# ============================================================================= +# Reading an LD statistic's blocks +# ----------------------------------------------------------------------------- +# The estimators walk a statistic block by block. Each block is a record: +# `idx`, the block's variant positions in the statistic, and where its LD +# comes from -- `R`, the matrix an LdScore stores; `eigen`, the decomposition +# an LdEigen stores; or `rows`, the block's rows in the genotype reference it +# is read from. A scores-only LdScore has `idx` alone. The readers below turn +# a record into the LD form a computation needs, reading a genotype +# reference's block only then. +# ============================================================================= + +# The records of a statistic that stores nothing per block: its variants +# placed in its LD blocks, with their rows in its genotype reference when it +# has one. +# @noRd +.ldStatLazyBlocks <- function(x) { + idx <- .ldStatPlacedIdx(x) + if (is.null(x@ldReference)) { + return(map(idx, .ldStatIdxBlock)) + } + rows <- S4Vectors::mcols(x, use.names = FALSE)$panelRow + map(idx, .ldStatPanelBlock, rows = rows) +} + +# Each LD block's variant positions, in block order, found by placing the +# variants in `ldBlocks(x)`. A block no variant falls in has no entry: the +# placement only groups the hits there are. +# @noRd +.ldStatPlacedIdx <- function(x) { + snpInfo <- tibble(CHR = as.character(seqnames(x)), BP = start(x)) + idx <- unname(snpsPerBlock(snpInfo, x@ldBlocks)) + if (length(idx) == 0L) { + abort("no LD block covers any reference variant.") + } + idx +} + +# @noRd +.ldStatIdxBlock <- function(idx) { + list(idx = idx) +} + +# @noRd +.ldStatPanelBlock <- function(idx, rows) { + list(idx = idx, rows = rows[idx]) +} + +# A block's LD source (see .ldSourceRows()): the stored matrix, the stored +# decomposition, or a factor of it read from the genotype reference. +# @noRd +.ldStatBlockLd <- function(block, ldReference) { + if (!is.null(block$R)) { + return(list(R = block$R)) + } + if (!is.null(block$eigen)) { + return(block$eigen[c("vectors", "values")]) + } + list(F = .ldRefFactor(ldReference, block$rows)) +} + +# A block's eigendecomposition, keeping the leading components that carry +# `truncation` of its eigenvalue mass: the stored one, or one computed from +# the factor of the block read from the genotype reference. A computed one +# lists only the min(m, p) directions the factor's SVD returns; `nNull` counts +# the block's other directions, whose eigenvalue is exactly zero, when +# nothing is truncated. +# @noRd +.ldStatBlockEigen <- function(block, ldReference, truncation) { + if (!is.null(block$eigen)) { + return(list_assign(block$eigen, nNull = 0L)) + } + dec <- .ldFactorEigen(.ldRefFactor(ldReference, block$rows)) + keep <- .ldEigenKeep(dec$values, truncation) + list( + values = dec$values[keep], + vectors = dec$vectors[, keep, drop = FALSE], + snpIdx = block$idx, + nNull = if (truncation >= 1) dec$nNull else 0L + ) +} + +# `obj` reading its blocks from the genotype reference it was built from: the +# reference in its slot and each variant's row in it as `panelRow`. A +# statistic built from LdMatrix blocks is returned as it is. +# @noRd +.ldStatAttachReference <- function(obj, prep) { + if (is.null(prep$ldReference)) { + return(obj) + } + S4Vectors::mcols(obj)$panelRow <- prep$panelRow + obj@ldReference <- prep$ldReference + validObject(obj) + obj +} diff --git a/R/MethodOptions.R b/R/MethodOptions.R index 98607cf65..95522d970 100644 --- a/R/MethodOptions.R +++ b/R/MethodOptions.R @@ -92,7 +92,7 @@ setClass("MethodOptions", contains = "SimpleList") if (!requireNamespace(parts[[1L]], quietly = TRUE)) { return(NULL) } - tryCatch( + try_fetch( get(parts[[2L]], envir = asNamespace(parts[[1L]])), error = function(cnd) NULL ) @@ -123,7 +123,7 @@ setClass("MethodOptions", contains = "SimpleList") if (is.null(fn)) { return(NULL) } - fm <- tryCatch(names(formals(fn)), error = function(cnd) NULL) + fm <- try_fetch(names(formals(fn)), error = function(cnd) NULL) if (is.null(fm)) { return(NULL) } @@ -150,7 +150,7 @@ setClass("MethodOptions", contains = "SimpleList") if (is.null(fn)) { return(FALSE) } - fm <- tryCatch(names(formals(fn)), error = function(cnd) NULL) + fm <- try_fetch(names(formals(fn)), error = function(cnd) NULL) !is.null(fm) && is_in("...", fm) } @@ -169,7 +169,7 @@ setClass("MethodOptions", contains = "SimpleList") # One callee's formals with `...` removed, NULL when they cannot be read. # @noRd .engineExplicitFormals <- function(fn) { - setdiff(tryCatch(names(formals(fn)), error = function(cnd) NULL), "...") + setdiff(try_fetch(names(formals(fn)), error = function(cnd) NULL), "...") } # --- which input classes a set of engine arguments belongs to ------------- @@ -300,7 +300,7 @@ setClass("MethodOptions", contains = "SimpleList") defaults <- discard(defaults, is.null) overridden <- intersect(names(defaults), names(extra)) defaults[overridden] <- extra[overridden] - c(defaults, extra[!names(extra) %in% overridden]) + c(defaults, extra[!is_in(names(extra), overridden)]) } # Build one engine's argument record: pecotmr's defaults, overlaid with the @@ -575,7 +575,7 @@ setClass("MethodOptions", contains = "SimpleList") # sibling key that shares the same engine. # @noRd .nestedExpectedEngine <- function(key, ctors) { - rec <- tryCatch(ctors[[key]](), error = function(cnd) NULL) + rec <- try_fetch(ctors[[key]](), error = function(cnd) NULL) if (is.null(rec)) { return(key) } @@ -631,7 +631,7 @@ setClass("MethodOptions", contains = "SimpleList") "'{str_split_1(callee, fixed('::'))[[1L]]}' is not installed" )) } - fm <- tryCatch(names(formals(fn)), error = function(cnd) NULL) + fm <- try_fetch(names(formals(fn)), error = function(cnd) NULL) if (is.null(fm)) { return("argument names NOT checked: the engine's formals are unknown") } diff --git a/R/MethodParam.R b/R/MethodParam.R index e9048d210..d6dddff6b 100644 --- a/R/MethodParam.R +++ b/R/MethodParam.R @@ -44,6 +44,10 @@ NULL setClassUnion("numeric_OR_NULL", c("numeric", "NULL")) setClassUnion("logical_OR_NULL", c("logical", "NULL")) setClassUnion("list_OR_NULL", c("list", "NULL")) +# A tibble is a data.frame here, so it fills a data.frame_OR_NULL slot; a bare +# list does not. +setClassUnion("data.frame_OR_NULL", c("data.frame", "NULL")) +setClassUnion("matrix_OR_NULL", c("matrix", "NULL")) # The one cross-family slot: SusieRssParam() carries a SusieRssControlOptions() # record, which is a MethodOptions rather than a Param -- `control` really is @@ -311,10 +315,13 @@ setValidity("MethodsSelectionParam", function(object) { # "is mrmash requested", "are these methods available at all". # @noRd .methodsParamTokens <- function(param) { - unique(unlist(map( - .methodsSlotNames, - function(s) names(slot(param, s)) %||% character(0) - ))) + unique(unlist(map(.methodsSlotNames, .methodsSlotTokens, param = param))) +} + +# The method names one slot of a Param holds; empty when the slot is. +# @noRd +.methodsSlotTokens <- function(slotName, param) { + names(slot(param, slotName)) %||% character(0) } # The same Param with some methods removed from every slot -- the joint @@ -844,13 +851,13 @@ setValidity("MethodsSelectionParam", function(object) { # @noRd .methodsCtorHasCallee <- function(ctor, callee) { - rec <- tryCatch(ctor(), error = function(cnd) NULL) + rec <- try_fetch(ctor(), error = function(cnd) NULL) !is.null(rec) && identical(metadata(rec)$callee, callee) } # @noRd .methodsRecordEngine <- function(ctor) { - rec <- tryCatch(ctor(), error = function(cnd) NULL) + rec <- try_fetch(ctor(), error = function(cnd) NULL) if (is.null(rec)) { return(NULL) } @@ -1053,8 +1060,14 @@ setValidity("MethodsSelectionParam", function(object) { # *Param() has its own class, so handing `ColocPriorParam()` where # `CredibleSetParam()` was wanted is caught here rather than surfacing as a # missing field somewhere downstream. +# +# The message names the argument from the caller's own expression +# (caller_arg()), so it cannot drift from the argument's name the way a +# hand-written label did: 19 of 30 labels still named arguments that had +# since been renamed. # @noRd -.assertMethodParam <- function(x, ctor, argName, class = NULL) { +#' @importFrom rlang caller_arg +.assertMethodParam <- function(x, ctor, argName = caller_arg(x), class = NULL) { class <- class %||% .paramClassOf(ctor) if (is(x, class)) { return(invisible(x)) diff --git a/R/MultiStudyQtlDataset.R b/R/MultiStudyQtlDataset.R index 8136251ea..e9d27060c 100644 --- a/R/MultiStudyQtlDataset.R +++ b/R/MultiStudyQtlDataset.R @@ -8,9 +8,13 @@ # orchestrate joint or per-study analyses across multiple cohorts. # ============================================================================= -#' @include QtlDataset.R +#' @include QtlDataset.R qtlSumStats.R NULL +# The summary-statistic-only studies: a QtlSumStats, or NULL when there are +# none. The slot type refuses anything else when the object is built. +setClassUnion("QtlSumStats_OR_NULL", c("QtlSumStats", "NULL")) + #' @title Multi-Study QTL Dataset #' @description S4 container for a multi-study QTL analysis: a collection of #' individual-level \code{QtlDataset} studies, optionally combined with a @@ -34,7 +38,7 @@ setClass( "MultiStudyQtlDataset", representation( qtlDatasets = "list", - sumStats = "ANY" + sumStats = "QtlSumStats_OR_NULL" ), validity = function(object) .validateMultiStudyQtlDataset(object) ) @@ -46,10 +50,7 @@ setClass( # Each stage only makes sense once the previous one holds: the study count # reads slots the type checks just validated, and trait consistency reads # across the studies the count check just confirmed. - slotErrors <- c( - .msqdCheckDatasets(object@qtlDatasets), - .msqdCheckSumStats(object@sumStats) - ) + slotErrors <- .msqdCheckDatasets(object@qtlDatasets) if (length(slotErrors) > 0L) { return(slotErrors) } @@ -85,14 +86,6 @@ setClass( methods::is(d, "QtlDataset") } -# @noRd -.msqdCheckSumStats <- function(sumStats) { - if (!is.null(sumStats) && !methods::is(sumStats, "QtlSumStats")) { - return("'sumStats' must be a QtlSumStats object or NULL") - } - NULL -} - # At least 2 studies in total (individual-level + summary-statistic). # @noRd .msqdCheckStudyCount <- function(object) { diff --git a/R/QtlDataset.R b/R/QtlDataset.R index f3c7c1e55..0f1a2a133 100644 --- a/R/QtlDataset.R +++ b/R/QtlDataset.R @@ -45,7 +45,7 @@ NULL #' view of that experiment reads its dosages. #' #' @slot studyName Character (length 1). Study identifier; used in collection -#' classes to tag downstream \code{FineMappingResult} / \code{TwasWeights} +#' classes to tag downstream \code{QtlFineMappingResult} / \code{TwasWeights} #' entries. #' The \code{genotype} experiment's assay reads through this handle; the #' extraction accessors read it directly, so that QC can be applied per @@ -159,11 +159,6 @@ setClass( ) } -# Shape checks on the phenotype list handed to the constructor. Run before -# the MultiAssayExperiment is assembled, because a malformed list makes -# ExperimentList fail first with a message about experiments rather than -# about contexts. Returns an error vector. -# @noRd # What is wrong with the context names, if anything. The checks are ordered: # a list with no usable names is not also reported as having duplicates. # @noRd @@ -207,6 +202,11 @@ setClass( character(0) } +# Shape checks on the phenotype list handed to the constructor. Run before +# the MultiAssayExperiment is assembled, because a malformed list makes +# ExperimentList fail first with a message about experiments rather than +# about contexts. Returns an error vector. +# @noRd .qtlCheckPhenotypeList <- function(phenotypes) { emptyError <- if (length(phenotypes) == 0L) { "'phenotypes' must not be empty" @@ -334,7 +334,7 @@ setClass( # QtlDataset constructor and accessors # ============================================================================= -# Check the constructor's inputs and return the handle behind `genotypes`. +# Check the constructor's inputs and return the genotype source as given. # Every phenotype must be a usable SummarizedExperiment, and the genotype # source must be an unsubset panel (or a bare handle) -- see # .qtlCheckWholePanel for why the "unsubset" part matters. @@ -344,28 +344,42 @@ setClass( if (length(errors) > 0L) { abort(str_flatten(errors, "\n")) } - handle <- .openGenotypeHandle(genotypes) - if (is.null(handle)) { + source <- .openGenotypeSource(genotypes) + if (is.null(source)) { abort(glue( "'genotypes' must be a genotype panel from readGenotypes() ", "(got {class(genotypes)[[1L]]})" )) } - .qtlCheckWholePanel(genotypes, handle) - handle + .qtlCheckWholePanel(genotypes) + .qtlCheckRealGenotypes(genotypes) + source } -# A QtlDataset indexes variants positionally into the handle's whole snpInfo -# (see .qtlVariantIndices), so a panel that has already been narrowed would -# leave extraction reading the wrong rows. Refuse it rather than silently -# widening back to the file: narrowing belongs to keepVariants / keepSamples, -# which the extraction path honours. +# A stochastic LD sketch is a panel whose columns are pseudo-samples +# projected from real ones: it carries LD, not anyone's genotypes, so it +# cannot be the genotype experiment a QTL study is fitted on. # @noRd -.qtlCheckWholePanel <- function(genotypes, handle) { +.qtlCheckRealGenotypes <- function(genotypes) { + if (!.ldRefIsProjection(genotypes)) { + return(invisible(NULL)) + } + abort(c( + "'genotypes' is a stochastic LD sketch, not a study's genotypes.", + i = "Its samples are projections; use it as an `ldReference` instead." + )) +} + +# A panel that has already been narrowed is refused rather than taken as the +# study's genotypes: narrowing belongs to keepVariants / keepSamples, which +# the extraction path honours, and it is recorded there rather than in which +# panel happened to be passed. +# @noRd +.qtlCheckWholePanel <- function(genotypes) { if (!methods::is(genotypes, "RangedSummarizedExperiment")) { return(invisible(NULL)) } - full <- c(nrow(snpInfo(handle)), nSamples(handle)) + full <- .panelFullDims(genotypes) got <- c(nrow(genotypes), ncol(genotypes)) if (identical(as.integer(got), as.integer(full))) { return(invisible(NULL)) @@ -450,8 +464,7 @@ QtlDataset <- function( ) { .assertMethodParam( genotypeFilterParam, - "GenotypeFilterParam", - "genotypeFilter" + "GenotypeFilterParam" ) filt <- .qtlResolveFilter(genotypeFilterParam) handle <- .qtlValidateInputs(phenotypes, genotypes) @@ -743,12 +756,19 @@ setMethod("genotypeHandle", "QtlDataset", function(x) { # Derived, not stored. The handle already lives inside the genotype # assay's seed -- that is what lets the dosages read lazily -- so a # parallel slot was a second copy that had to be kept in step by hand. - # Reading it back removes the invariant instead of policing it. - .ldSketchHandle( - MultiAssayExperiment::experiments(x)[[.QTL_GENO_EXPERIMENT]] - ) + # Reading it back removes the invariant instead of policing it. NULL for + # genotypes read through another backend (VCF, GDS) or held in memory. + .ldRefHandle(.qtlGenotypeSe(x)) }) +# The genotype experiment's variants, one row per panel row: SNP (the +# panel's own ids), CHR (canonical), BP, A1, A2. Read off its rowRanges, so +# genotypes from any backend answer alike. +# @noRd +.qtlGenotypeVariants <- function(x) { + .rangesSnpInfo(SummarizedExperiment::rowRanges(.qtlGenotypeSe(x))) +} + #' @rdname qtlDatasetFilters #' @export setMethod("mafCutoff", "QtlDataset", function(x) x@mafCutoff) @@ -799,9 +819,6 @@ setMethod("keepIndel", "QtlDataset", function(x) x@keepIndel) .qtlLiteralRegion(region, cisWindow) } -# The union span (+/- cisWindow) of a trait's rowRanges across all contexts. -# Requires cisWindow and a single shared chromosome. -# @noRd # The requested traits' ranges within one context, or NULL when it carries # none of them. # @noRd @@ -821,6 +838,9 @@ setMethod("keepIndel", "QtlDataset", function(x) x@keepIndel) hits[!is.na(hits)] } +# The union span (+/- cisWindow) of the requested traits' rowRanges across all +# contexts. Requires cisWindow and a single shared chromosome. +# @noRd .qtlTraitRegion <- function(x, traitId, cisWindow) { if (is.null(cisWindow) || length(cisWindow) != 1L || cisWindow < 0) { msg <- glue( @@ -953,16 +973,16 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { }) # Internal: map a GRanges region (one or more ranges) into 1-based snpIdx into -# handle@snpInfo. Indices are unioned across ranges in range order (first -# occurrence wins), so overlapping ranges contribute each variant once. +# the genotype experiment's rows. Indices are unioned across ranges in range +# order (first occurrence wins), so overlapping ranges contribute each +# variant once. .qtlVariantIndices <- function(x, region = NULL) { - handle <- genotypeHandle(x) + variants <- .qtlGenotypeVariants(x) if (is.null(region)) { - return(seq_len(nrow(snpInfo(handle)))) + return(seq_len(nrow(variants))) } - snpInfo <- snpInfo(handle) - siChr <- canonChrom(snpInfo$CHR) - bp <- as.integer(snpInfo$BP) + siChr <- variants$CHR + bp <- variants$BP rChr <- canonChrom(GenomicRanges::seqnames(region)) rStart <- GenomicRanges::start(region) rEnd <- GenomicRanges::end(region) @@ -1036,8 +1056,7 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { .qtlApplyFilterOverrides <- function(data, genotypeFilterParam) { .assertMethodParam( genotypeFilterParam, - "GenotypeFilterParam", - "genotypeFilter" + "GenotypeFilterParam" ) # discard(is.null), not compact(): a keepVariants of character(0) is a # real instruction ("restrict to nothing was not asked, keep all"), and @@ -1117,8 +1136,12 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { if (length(snpIdx) == 0L) { return(.qtlEmptyBlock()) } - handle <- genotypeHandle(x) - dosage <- .dosageMatrix(handle, snpIdx, meanImpute = FALSE) + se <- .qtlGenotypeSe(x) + # Labelled with the panel's own variant ids, as the rows a block reports. + dosage <- `colnames<-`( + .ldRefDosage(se, snpIdx, meanImpute = FALSE), + .ldRefVariantIds(se)[snpIdx] + ) keep <- .qtlResolveSamples(dosage, x, samples) if (length(keep) == 0L) { return(.qtlEmptyBlockNoSamples(dosage)) @@ -1138,16 +1161,16 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { # Empty block preserving the full panel sample set (no variants selected). # @noRd .qtlEmptyBlockAllSamples <- function(x) { - handle <- genotypeHandle(x) + samples <- as.character(colnames(.qtlGenotypeSe(x))) list( geno = matrix( numeric(0), - nrow = nSamples(handle), + nrow = length(samples), ncol = 0L, - dimnames = list(sampleIds(handle), character(0)) + dimnames = list(samples, character(0)) ), variantIds = character(0), - sampleIds = sampleIds(handle), + sampleIds = samples, maf = numeric(0), af = numeric(0) ) @@ -1186,18 +1209,17 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { # allele) and, unless kept, by dropping indels. Done before materialization. # @noRd .qtlNarrowSnpIdx <- function(x, snpIdx) { - handle <- genotypeHandle(x) + si <- .qtlGenotypeVariants(x) kept <- if (length(keepVariants(x)) == 0L) { snpIdx } else { - snpAll <- as.character(snpInfo(handle)$SNP[snpIdx]) + snpAll <- si$SNP[snpIdx] km <- matchVariants(snpAll, as.character(keepVariants(x))) snpIdx[replace(logical(length(snpAll)), km$idxA, TRUE)] } if (length(kept) == 0L || .qtlKeepIndel(x)) { return(kept) } - si <- snpInfo(handle) # which() (not the mask) so an NA mask drops the variant rather than # injecting an NA index. snpMask <- str_length(as.character(si$A1[kept])) == 1L & @@ -1659,11 +1681,11 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { # convention `residualizePhenotype` / `residualizeGenotype` use -- a flat # formal defaulting to TRUE could not tell "FALSE" from "not given". # @noRd -.qtlScaleResiduals <- function(x, residualizationArgs) { - if (is.null(residualizationArgs)) { +.qtlScaleResiduals <- function(x, residualizationParam) { + if (is.null(residualizationParam)) { return(scaleResiduals(x)) } - residualizationArgs$scaleResiduals %||% scaleResiduals(x) + residualizationParam$scaleResiduals %||% scaleResiduals(x) } # Internal: residualize a numeric matrix Y (n x k) against a covariate @@ -1719,7 +1741,7 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { if (length(keep) != length(requested)) { missingNames <- setdiff(requested, avail) msg <- glue( - "residualizationArgs$phenotypeCovariates: context '{ctx}' has no ", + "residualizationParam$phenotypeCovariates: context '{ctx}' has no ", "covariate(s) named: {str_flatten(missingNames, ', ')}" ) abort(msg) @@ -1866,10 +1888,6 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { # Per-context phenotype covariate matrices (colData columns from # phenoSelection), column names prefixed with the context. # @noRd -# Sample names survive the coercion because the constructor requires every -# context to name its samples, which SummarizedExperiment carries into -# rownames(colData(se)). -# @noRd .qtlPhenoCovBlocks <- function(x, contexts, phenoSelection) { compact(set_names( map( @@ -1884,6 +1902,10 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { # One context's selected covariate columns, context-qualified, or NULL when # nothing is selected there. +# +# Sample names survive the coercion because the constructor requires every +# context to name its samples, which SummarizedExperiment carries into +# rownames(colData(se)). # @noRd .qtlPhenoCovBlock <- function(ctx, x, phenoSelection) { keep <- phenoSelection[[ctx]] @@ -1998,7 +2020,7 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { region = NULL, cisWindow = NULL, samples = NULL, - residualizationArgs = ResidualizationParam() + residualizationParam = ResidualizationParam() ) { if (missing(contexts) || is.null(contexts) || length(contexts) == 0L) { msg <- glue( @@ -2011,9 +2033,8 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { abort(msg) } .assertMethodParam( - residualizationArgs, - "ResidualizationParam", - "residualizationArgs" + residualizationParam, + "ResidualizationParam" ) bad <- setdiff(contexts, contexts(x)) if (length(bad) > 0L) { @@ -2030,12 +2051,12 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { if (ncol(G) == 0L) { return(G) } - C <- .qtlResidCovariateMatrix(x, contexts, residualizationArgs) + C <- .qtlResidCovariateMatrix(x, contexts, residualizationParam) aligned <- .qtlAlignGC(G, C, contexts) .qtlResidualizeQr( aligned$G, aligned$C, - scaleResiduals = .qtlScaleResiduals(x, residualizationArgs) + scaleResiduals = .qtlScaleResiduals(x, residualizationParam) ) } @@ -2130,7 +2151,7 @@ setMethod( outlierAction = c("keep", "drop"), outlierPvalThreshold = 1e-3, outlierArgs = CovMcdOptions(), - residualizationArgs = ResidualizationParam() + residualizationParam = ResidualizationParam() ) { if (missing(contexts) || is.null(contexts) || length(contexts) == 0L) { abort("`contexts` is required for residualizedPhenotypes().") @@ -2139,16 +2160,15 @@ setMethod( outlierAction <- arg_match(outlierAction) .assertMethodOptions(outlierArgs, "CovMcdOptions", "outlierArgs") .assertMethodParam( - residualizationArgs, - "ResidualizationParam", - "residualizationArgs" + residualizationParam, + "ResidualizationParam" ) bad <- setdiff(contexts, contexts(x)) if (length(bad) > 0L) { msg <- glue("Unknown context(s): {str_flatten(bad, \', \')}") abort(msg) } - C <- .qtlResidCovariateMatrix(x, contexts, residualizationArgs) + C <- .qtlResidCovariateMatrix(x, contexts, residualizationParam) Yraw <- .qtlResidPhenoY( x, contexts, @@ -2164,7 +2184,7 @@ setMethod( outlierAction = outlierAction, outlierPvalThreshold = outlierPvalThreshold, outlierArgs = outlierArgs, - scaleResiduals = .qtlScaleResiduals(x, residualizationArgs) + scaleResiduals = .qtlScaleResiduals(x, residualizationParam) ) } @@ -2181,15 +2201,15 @@ setMethod( # they select, build the design, and apply the NA policy to it. One step, # because none of the four halves means anything without the others. # @noRd -.qtlResidCovariateMatrix <- function(x, contexts, residualizationArgs) { +.qtlResidCovariateMatrix <- function(x, contexts, residualizationParam) { # arg_match() reports on its argument by name, so it must be handed a # symbol: resolve the bundle field first, then validate it. - covariateNaAction <- residualizationArgs$covariateNaAction %||% "impute" + covariateNaAction <- residualizationParam$covariateNaAction %||% "impute" covariateNaAction <- arg_match(covariateNaAction, c("impute", "drop")) phenoSel <- .qtlResolvePhenoSelection( x, contexts, - residualizationArgs$phenotypeCovariates + residualizationParam$phenotypeCovariates ) design <- .qtlBuildResidualizationDesign( x, @@ -2197,13 +2217,13 @@ setMethod( phenoSelection = phenoSel, genoSelection = .qtlResolveGenoSelection( x, - residualizationArgs$genotypeCovariates + residualizationParam$genotypeCovariates ), # Unset means "residualize on this side": the accessors' own # historical default, now expressed as the absence of a value # rather than as a formal defaulting to TRUE. - includePheno = residualizationArgs$residualizePhenotype %||% TRUE, - includeGeno = residualizationArgs$residualizeGenotype %||% TRUE + includePheno = residualizationParam$residualizePhenotype %||% TRUE, + includeGeno = residualizationParam$residualizeGenotype %||% TRUE ) .qtlHandleCovariateNa(design, covariateNaAction) } @@ -2254,9 +2274,8 @@ setMethod("show", "QtlDataset", function(object) { .trim = FALSE )) cat(glue(" {totalTraits} unique traits across contexts\n", .trim = FALSE)) - gh <- genotypeHandle(object) cat(glue( - " Genotypes: {genotypeFormat(gh)} @ {path(gh)}\n", + " Genotypes: {.ldRefLabel(.qtlGenotypeSe(object))}\n", .trim = FALSE )) cat(glue( diff --git a/R/QtlFineMappingResult.R b/R/QtlFineMappingResult.R index f7dfe39ac..d90de27ed 100644 --- a/R/QtlFineMappingResult.R +++ b/R/QtlFineMappingResult.R @@ -4,7 +4,7 @@ # DFrame-subclass collection keyed by the identity tuple (study, context, # trait, method). Each row holds a FineMappingRow payload. Class-level # slots: -# * ldSketch GenotypeHandle (NULL for individual-level fits, the +# * ldReference GenotypeHandle (NULL for individual-level fits, the # LD-sketch handle for RSS-derived fits). # Optional columns jointStudies / jointContexts / jointTraits carry # semicolon-joined member identities for cross-axis joint fits emitted by @@ -39,7 +39,7 @@ setClass( # ---- QtlFineMappingResult validity helpers --------------------------------- # Collect all contract violations (empty vector = valid). The per-entry checks -# run only once the required columns are present; the ldSketch check always +# run only once the required columns are present; the ldReference check always # runs. # @noRd #' @importFrom checkmate makeAssertCollection assertNames checkNames @@ -92,10 +92,6 @@ setClass( str_c("missing entry payload columns: ", res) } -# @noRd - -# @noRd - # Each present joint* column must be character. # @noRd .qfmrCheckJointCols <- function(object, jointCols) { @@ -138,7 +134,7 @@ setClass( .tupleColumn(object, cn) } -# ldSketch must be a GenotypeHandle or NULL. +# ldReference must be a GenotypeHandle or NULL. # The identity-tuple vectors and the payload list are parallel: one entry per # (study, context, trait, method). A length mismatch would otherwise surface as @@ -163,8 +159,8 @@ setClass( #' @title Create a QtlFineMappingResult Collection #' @description Construct a \code{QtlFineMappingResult} DFrame-subclass #' collection from per-tuple vectors and a list of \code{FineMappingRow} -#' payloads (one per tuple). The optional \code{ldSketch} slot records the LD -#' reference used for RSS-derived fits; pass \code{NULL} (the default) for +#' payloads (one per tuple). The optional \code{ldReference} slot records the +#' LD reference used for RSS-derived fits; pass \code{NULL} (the default) for #' individual-level fits. #' @param studyName Character vector of study identifiers (per tuple). Use the #' sentinel \code{"joint"} for rows produced by a cross-study joint fit. @@ -188,7 +184,7 @@ setClass( #' @param dataSource Optional per-row label for the kind of input the fit saw, #' \code{"individual"} or \code{"sumstat"}. Recorded rather than derived: a #' combined collection can hold rows of both kinds, and its single -#' \code{ldSketch} cannot say which row came from which. +#' \code{ldReference} cannot say which row came from which. #' @param weightStandardized Optional per-row flag: whether the posterior #' effect is on the STANDARDIZED genotype scale. The posterior effect IS the #' prediction weight, so it carries the same scale question as a TWAS @@ -196,9 +192,9 @@ setClass( #' it standardizes genotypes before fitting, and the posterior mean is #' reported on the scale of the \code{X} the fit was given. The argument #' exists for a collection assembled by hand, where only the caller knows. -#' @param ldSketch An optional genotype panel (see \code{\link{readGenotypes}}) -#' (the LD reference for RSS-derived fits), or \code{NULL} for -#' individual-level fits. +#' @param ldReference An optional genotype panel (see +#' \code{\link{readGenotypes}}) (the LD reference for RSS-derived fits), or +#' \code{NULL} for individual-level fits. #' @param traitPos Optional per-row trait genomic anchor (a \code{GRanges} or #' \code{NULL}), carried forward as provenance; not part of the identity key. #' \code{NULL} (default) omits the column. @@ -232,7 +228,7 @@ QtlFineMappingResult <- function( dataType = NULL, dataSource = NULL, weightStandardized = NULL, - ldSketch = NULL + ldReference = NULL ) { .qfmrAssertArgs( studyName, @@ -264,13 +260,7 @@ QtlFineMappingResult <- function( weightStandardized, n ) - obj <- new( - "QtlFineMappingResult", - .rtlGrlWithMetadata(payloads, cols), - ldSketch = .asLdSketch(ldSketch) - ) - validObject(obj) - obj + .rtlNewValidated("QtlFineMappingResult", payloads, cols, ldReference) } # Every argument's type contract, checked before anything is built. @@ -509,10 +499,10 @@ setMethod("show", "QtlFineMappingResult", function(object) { .trim = FALSE )) } - ldSrc <- if (is.null(object@ldSketch)) { + ldSrc <- if (is.null(object@ldReference)) { "NULL (individual-level fit)" } else { - .ldSketchLabel(object@ldSketch) + .ldRefLabel(object@ldReference) } - cat(glue(" LD sketch: {ldSrc}\n", .trim = FALSE)) + cat(glue(" LD reference: {ldSrc}\n", .trim = FALSE)) }) diff --git a/R/RangedTupleList.R b/R/RangedTupleList.R index 26cece45a..83b46fc13 100644 --- a/R/RangedTupleList.R +++ b/R/RangedTupleList.R @@ -15,10 +15,10 @@ # `[[` is left alone on purpose: on a GRangesList it addresses elements, so # overloading it for columns would collide. Use `mcols(x)[i, j]` for a cell. # -# Slots hold COLLECTION-LEVEL scalars only (ldSketch, genome, qcInfo). Anything -# with one value per element belongs in mcols -- a per-element slot silently -# desyncs on subsetting, because `x[i]` narrows the elements and the mcols but -# has no idea the slot is parallel to them. +# Slots hold COLLECTION-LEVEL scalars only (ldReference, genome, qcInfo). +# Anything with one value per element belongs in mcols -- a per-element slot +# silently desyncs on subsetting, because `x[i]` narrows the elements and the +# mcols but has no idea the slot is parallel to them. # ============================================================================= #' @include AllGenerics.R @@ -128,14 +128,6 @@ methods::setValidity("RangedTupleList", function(object) { ) } -# Rebuild `x` from a new list of GRanges elements, carrying every -# collection-level slot over and narrowing mcols by `keep`. -# -# This is the ONLY supported way to produce a modified collection. `endoapply` -# via a `setAs("list", )` coercion looks like it works but silently -# drops the subclass's slots -- verified -- which is exactly the desync this -# class exists to prevent. -# @noRd # Put `x`'s seqinfo back onto a rebuilt GRangesList. Only the seqlevels the # rebuild actually spans can be kept, so this restores the genome (and any # lengths) for those, and supplies the whole seqinfo when the rebuild spans @@ -160,6 +152,14 @@ methods::setValidity("RangedTupleList", function(object) { ) } +# Rebuild `x` from a new list of GRanges elements, carrying every +# collection-level slot over and narrowing mcols by `keep`. +# +# This is the ONLY supported way to produce a modified collection. `endoapply` +# via a `setAs("list", )` coercion looks like it works but silently +# drops the subclass's slots -- verified -- which is exactly the desync this +# class exists to prevent. +# @noRd .rtlRebuild <- function(x, elements, keep) { # mcols and slots are attached BEFORE new(), not after: new() validates # during initialize(), and a subclass's validity method reads its identity @@ -352,7 +352,7 @@ setMethod("endoapply", "RangedTupleList", function(X, FUN, ...) { # Defined explicitly rather than left to the inherited machinery. Stock # `endoapply` on a subclass errors unless a `setAs("list", )` # coercion exists, and adding that coercion makes it run while silently - # DROPPING the subclass's slots (verified: genome / ldSketch come back + # DROPPING the subclass's slots (verified: genome / ldReference come back # unset). Rebuilding here keeps every collection-level slot. # # Call this as `endoapply(x, ...)`, NOT `S4Vectors::endoapply(x, ...)`: @@ -431,6 +431,20 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region) { ) } +# Build and validate a RangedTupleList subclass from its payloads and metadata +# columns -- the shared tail of the TwasWeights and QtlFineMappingResult +# constructors. +# @noRd +.rtlNewValidated <- function(Class, payloads, cols, ldReference) { + obj <- new( + Class, + .rtlGrlWithMetadata(payloads, cols), + ldReference = .asLdRef(ldReference) + ) + validObject(obj) + obj +} + # Split any multi-seqname element into one element per seqname, and report the # index each piece came from so the caller can replicate that element's # metadata row alongside it. @@ -621,7 +635,10 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region) { # on every call -- pure noise for a collection spanning several chromosomes. # @noRd .rtlRestrictOne <- function(g, win) { - onWindowChrom <- as.character(seqnames(g)) %in% as.character(seqnames(win)) + onWindowChrom <- is_in( + as.character(seqnames(g)), + as.character(seqnames(win)) + ) if (!any(onWindowChrom)) { return(g[0L]) } diff --git a/R/causalInferencePipeline.R b/R/causalInferencePipeline.R index 35512d902..80ea97dba 100644 --- a/R/causalInferencePipeline.R +++ b/R/causalInferencePipeline.R @@ -13,22 +13,25 @@ NULL #' \item \code{twasWeights} alone (no \code{fineMappingResult}): #' TWAS Z only, no MR. #' \item \code{fineMappingResult} alone (no \code{twasWeights}): -#' TWAS Z derived from SuSiE-style coefficients carried on the -#' \code{topLoci} slot of each FineMappingRow; plus MR. +#' TWAS Z derived from the SuSiE-style coefficients in each +#' row's top loci (\code{\link{topLoci}}); plus MR. #' \item both: TWAS Z computed from \code{twasWeights}; #' MR computed from \code{fineMappingResult}. #' } #' -#' @section LD-sketch compatibility check: If a QTL input (TwasWeights or -#' QtlFineMappingResult) carries a non-\code{NULL} \code{ldSketch}, it must -#' come from the same reference panel as the \code{ldSketch} on -#' \code{gwasSumStats} --- same samples, same allele orientation on the -#' shared variants. The two need NOT carry the same variants: QC-ing the two -#' sides separately trims each sketch to its own surviving variants, and a -#' partial overlap only warns. A different sample set, a swapped A1/A2 on a -#' shared variant, or no shared variant at all is a hard error. A QTL input -#' with \code{ldSketch = NULL} (the fit was learned from individual-level -#' data) skips the validation for that input. +#' @section LD reference compatibility check: If a QTL input +#' (TwasWeights or QtlFineMappingResult) carries a non-\code{NULL} +#' \code{ldReference}, it must be the same LD reference as the +#' \code{ldReference} on \code{gwasSumStats}. +#' The two must be the same kind of reference. Two genotype panels must +#' share their samples and allele orientation; two \code{LdMatrix} objects +#' must agree on the LD they share; two \code{GenotypeMixture} objects must +#' average the same panels with the same weights. The two need NOT carry +#' the same variants: QC-ing the two sides separately trims each reference +#' to its own surviving variants, and a partial overlap only warns. A +#' mismatch of any of those, or no shared variant at all, is a hard error. A +#' QTL input with \code{ldReference = NULL} (the fit was learned from +#' individual-level data) skips the validation for that input. #' #' @section Output shape: #' A long-format \code{GRanges} with one row per @@ -55,7 +58,7 @@ NULL #' supplied, drives the MR computation and (when \code{twasWeights = NULL}) #' the TWAS-Z weights via the SuSiE-style coefficients on each entry's #' \code{topLoci}. -#' @param weightSelectionArgs How one TWAS method's weights are picked per +#' @param weightSelectionParam How one TWAS method's weights are picked per #' \code{(study, context, trait, gwasStudy)} tuple, built with #' \code{\link{WeightSelectionParam}}: \code{cutoff} (minimum #' cross-validated r-squared, default \code{0}), \code{pvalCutoff} (the @@ -66,7 +69,7 @@ NULL #' gates that also produced a finite TWAS Z. Otherwise every method is #' carried through. Ports the legacy \code{twas_pipeline} #' \code{pick_best_model} / \code{update_twas_method}. -#' @param mrArgs How Mendelian randomization is run, built with +#' @param mrParam How Mendelian randomization is run, built with #' \code{\link{MrParam}}: \code{method} (\code{"ivwPerVariant"}, the #' default, or \code{"csAware"}), the PIP threshold that method reads #' (\code{pipCutoff} or \code{cpipCutoff}), and \code{pvalCutoff}, the @@ -93,25 +96,24 @@ causalInferencePipeline <- function( gwasSumStats, twasWeights = NULL, fineMappingResult = NULL, - weightSelectionArgs = WeightSelectionParam(), - mrArgs = MrParam(), + weightSelectionParam = WeightSelectionParam(), + mrParam = MrParam(), combineMethods = NULL, alleleFlip = TRUE ) { .assertMethodParam( - weightSelectionArgs, - "WeightSelectionParam", - "weightSelection" + weightSelectionParam, + "WeightSelectionParam" ) - .assertMethodParam(mrArgs, "MrParam", "mr") + .assertMethodParam(mrParam, "MrParam") .cipRun( gwasSumStats = gwasSumStats, twasWeights = twasWeights, fineMappingResult = fineMappingResult, combineMethods = combineMethods, - weightSelectionArgs = weightSelectionArgs, + weightSelectionParam = weightSelectionParam, alleleFlip = alleleFlip, - mrArgs = mrArgs + mrParam = mrParam ) } @@ -123,12 +125,12 @@ causalInferencePipeline <- function( twasWeights, fineMappingResult, combineMethods, - weightSelectionArgs, + weightSelectionParam, alleleFlip, - mrArgs + mrParam ) { .cipValidateInputs(gwasSumStats, twasWeights, fineMappingResult) - gwasLd <- .cipCheckLdSketches( + gwasLd <- .cipCheckLdRefs( gwasSumStats, twasWeights, fineMappingResult @@ -137,7 +139,7 @@ causalInferencePipeline <- function( sel <- .cipCvSelection( qtlRows = allRows, twasWeights = twasWeights, - weightSelectionArgs = weightSelectionArgs + weightSelectionParam = weightSelectionParam ) qtlRows <- sel$qtlRows outRows <- list_flatten(map( @@ -149,7 +151,7 @@ causalInferencePipeline <- function( gwasSumStats = gwasSumStats, gwasLd = gwasLd, alleleFlip = alleleFlip, - mrArgs = mrArgs + mrParam = mrParam )) if (length(outRows) == 0L) { abort( @@ -199,18 +201,18 @@ causalInferencePipeline <- function( # Require the twasWeights / fineMappingResult LD sketches to match the GWAS one; # returns the GWAS LD sketch. # @noRd -.cipCheckLdSketches <- function(gwasSumStats, twasWeights, fineMappingResult) { - gwasLd <- ldSketch(gwasSumStats) +.cipCheckLdRefs <- function(gwasSumStats, twasWeights, fineMappingResult) { + gwasLd <- ldReference(gwasSumStats) if (!is.null(twasWeights)) { - .cipRequireMatchingLdSketches( - ldSketch(twasWeights), + .cipRequireMatchingLdRefs( + ldReference(twasWeights), gwasLd, label = "twasWeights" ) } if (!is.null(fineMappingResult)) { - .cipRequireMatchingLdSketches( - ldSketch(fineMappingResult), + .cipRequireMatchingLdRefs( + ldReference(fineMappingResult), gwasLd, label = "fineMappingResult" ) @@ -256,14 +258,14 @@ causalInferencePipeline <- function( .cipCvSelection <- function( qtlRows, twasWeights, - weightSelectionArgs + weightSelectionParam ) { # The bundle's terminal. .cipMethodMetrics / .cipEligibleRowsIn below # take plain scalars, so it is unrolled once, here. - rsqCutoff <- weightSelectionArgs$cutoff - rsqPvalCutoff <- weightSelectionArgs$pvalCutoff - rsqOption <- weightSelectionArgs$metric - rsqPvalOption <- weightSelectionArgs$pvalMetric + rsqCutoff <- weightSelectionParam$cutoff + rsqPvalCutoff <- weightSelectionParam$pvalCutoff + rsqOption <- weightSelectionParam$metric + rsqPvalOption <- weightSelectionParam$pvalMetric selectionActive <- !is.null(twasWeights) && (rsqCutoff > 0 || is.finite(rsqPvalCutoff)) if (!selectionActive) { @@ -309,7 +311,7 @@ causalInferencePipeline <- function( gwasSumStats, gwasLd, alleleFlip, - mrArgs + mrParam ) { tuple <- list( qStudy = qtlRows$qtlStudy[[qi]], @@ -345,11 +347,12 @@ causalInferencePipeline <- function( gwasSumStats = gwasSumStats, gwasLd = gwasLd, alleleFlip = alleleFlip, - mrArgs = mrArgs + mrParam = mrParam )) } -# Resolve the FineMappingRow for a tuple (NULL when the fmr lacks it). +# The tuple's single-row collection from `fineMappingResult` (NULL when it +# lacks the tuple). # @noRd .cipResolveFmrEntry <- function( fineMappingResult, @@ -383,7 +386,7 @@ causalInferencePipeline <- function( gwasSumStats, gwasLd, alleleFlip, - mrArgs + mrParam ) { gStudy <- as.character(gwasSumStats$study)[[gi]] gdf <- as.data.frame( @@ -407,7 +410,7 @@ causalInferencePipeline <- function( gdf, twasOut, alleleFlip = alleleFlip, - mrArgs = mrArgs + mrParam = mrParam ) .cipResultRow(tuple, gStudy, twasOut, mrOut) } @@ -430,13 +433,13 @@ causalInferencePipeline <- function( gdf, twasOut, alleleFlip, - mrArgs + mrParam ) { # The bundle's terminal; the MR engines below take plain scalars. - mrMethod <- mrArgs$method - mrPipCutoff <- mrArgs$pipCutoff - mrCpipCutoff <- mrArgs$cpipCutoff - mrPvalCutoff <- mrArgs$pvalCutoff + mrMethod <- mrParam$method + mrPipCutoff <- mrParam$pipCutoff + mrCpipCutoff <- mrParam$cpipCutoff + mrPvalCutoff <- mrParam$pvalCutoff mrGateOpen <- mrPvalCutoff >= 1 || (!is.na(twasOut$pval) && twasOut$pval < mrPvalCutoff) if (is.null(fmrEntry) || !mrGateOpen) { @@ -525,9 +528,9 @@ causalInferencePipeline <- function( # ============================================================================= # Check two LD sketches for reference-panel compatibility. Thin wrapper over -# the shared `.requireMatchingLdSketches` helper (R/ld.R). -.cipRequireMatchingLdSketches <- function(qtlLd, gwasLd, label) { - .requireMatchingLdSketches( +# the shared `.requireMatchingLdRefs` helper (R/ld.R). +.cipRequireMatchingLdRefs <- function(qtlLd, gwasLd, label) { + .requireMatchingLdRefs( qtlLd, gwasLd, pipelineName = "causalInferencePipeline", @@ -744,7 +747,7 @@ causalInferencePipeline <- function( } # Fetch the per-tuple weight-source entry (a TwasWeightsRow from -# `twasWeights`, or a FineMappingRow from `fineMappingResult`) and resolve it +# `twasWeights`, or the tuple's row of `fineMappingResult`) and resolve it # to an aligned (variantIds, weights) pair via the shared `resolveWeights` -- # the SuSiE-style posterior effect for the FMR path. Returns NULL when the tuple # is absent or has no usable weights. @@ -805,7 +808,7 @@ causalInferencePipeline <- function( ) } -# FineMappingResult entry for a tuple (NULL when absent). +# The fine-mapping entry for a tuple (NULL when absent). # @noRd .cipWeightsFromFmr <- function( fineMappingResult, @@ -856,9 +859,7 @@ causalInferencePipeline <- function( wSub <- weights[m$idxA] * m$sign zSub <- gwasDf$z[m$idxB] gwasIds <- gwasDf$variant_id[m$idxB] - ldMat <- .ldFromSketch(gwasLd, gwasIds, label = "causalInferencePipeline") - - res <- twasZ(weights = wSub, z = zSub, R = ldMat) + res <- .cipTwasZ(wSub, zSub, gwasLd, gwasIds) zMat <- res$Z zVal <- as.numeric(zMat[1L, "Z"]) pVal <- as.numeric(zMat[1L, "pval"]) @@ -875,6 +876,22 @@ causalInferencePipeline <- function( ) } +# twasZ() of weights `w` against GWAS z-scores `z` over the GWAS variants +# `gwasIds`, needing w'Rw only: a genotype reference gives its LD factor, so +# the p x p LD is never formed; an LdMatrix gives the matrix. +# @noRd +.cipTwasZ <- function(w, z, gwasLd, gwasIds) { + label <- "causalInferencePipeline" + if (.ldIsGenotypeRef(gwasLd)) { + return(twasZ( + weights = w, + z = z, + X = .ldFactorFromRef(gwasLd, gwasIds, label) + )) + } + twasZ(weights = w, z = z, R = .ldFromRef(gwasLd, gwasIds, label)) +} + # Report how many QTL weight variants failed to match the GWAS sumstats. # Dropping below two matches yields no TWAS Z at all, which used to be a silent # NULL, so that case is called out separately. @@ -957,9 +974,6 @@ causalInferencePipeline <- function( ) } -# Instrumental variables from a FineMappingRow's topLoci: variants with PIP > -# pipCutoff. Returns list(ivVars, betaX, seX) or NULL when none qualify. -# @noRd # The per-variant top-loci table of one entry. topLoci() returns ranges and # mcols() is exactly the pre-conversion table -- as.data.frame() on the # ranges would add the standard seqnames/start/end/width/strand columns the @@ -971,6 +985,9 @@ causalInferencePipeline <- function( as.data.frame(S4Vectors::mcols(topLoci(fmrEntry))) } +# Instrumental variables from a FineMappingRow's topLoci: variants with PIP > +# pipCutoff. Returns list(ivVars, betaX, seX) or NULL when none qualify. +# @noRd .cipMrInstruments <- function(fmrEntry, pipCutoff) { tl <- .cipTopLociTable(fmrEntry) if (is.null(tl) || nrow(tl) == 0L) { @@ -1014,7 +1031,8 @@ causalInferencePipeline <- function( # # Logic: # 1. Group topLoci variants by credible set (column `cs` in topLoci, or -# first column matching ^cs). +# first column matching ^cs -- cs_95 on a stored result, whose +# "_" labels are parsed to the set index). # 2. Per CS, compute cumulative PIP; drop CSs with cpip < cpipCutoff. # 3. Per surviving CS, compute a PIP-weighted composite Wald ratio # `composite_bhat = sum((bhatY/bhatX * pip) / cpip)` with the @@ -1083,7 +1101,10 @@ causalInferencePipeline <- function( # with NA cs / non-positive cs / NA pip / NA beta. Returns NULL when none valid. # @noRd .cipCsAwareRaw <- function(tl, cols) { - cs <- as.integer(tl[[cols$cs[[1L]]]]) + csCol <- tl[[cols$cs[[1L]]]] + # A stored topLoci table labels each variant's set "_" + # (cs_95); a caller-built table may carry the bare integer instead. + cs <- if (is.character(csCol)) .csLabelIndex(csCol) else as.integer(csCol) pip <- as.numeric(tl[[cols$pip[[1L]]]]) bhatX <- as.numeric(tl[[cols$beta[[1L]]]]) sbhatX <- as.numeric(tl[[cols$se[[1L]]]]) @@ -1367,9 +1388,9 @@ causalInferencePipeline <- function( list_c(pieces) } -# One combined row: the group's first row re-stamped with the combined -# p-value for method `m`. The per-method statistics do not carry over, so -# they are blanked rather than inherited. +# One combined row: the group's first row, carrying the combined p-value for +# method `m` in place of its own. The per-method statistics do not carry +# over, so they are blanked rather than inherited. # @noRd .cipCombinedRow <- function(m, mc, rows, cp) { mutate( @@ -1473,17 +1494,39 @@ causalInferencePipeline <- function( V } -# R / X path: covY = W^T R W (R computed from X when R is absent). +# R / X path: covY = W^T R W. From a genotype matrix X the LD is never formed: +# W^T R W = crossprod(F W) / (n - 1) for F, X's LD factor +# (.ldFactorFromDosage()), which is computeLd()'s LD exactly. # @noRd .twasZCovYR <- function(weights, R, X, rn) { - if (is.null(R)) { - if (is.null(X)) { - abort("twasZ: provide R, X, or the (V, D, nSketch) SVD triplet.") + if (!is.null(R)) { + rSub <- .twasZAlignR(R, rn, nrow(weights)) + return(list(covY = crossprod(weights, rSub) %*% weights)) + } + if (is.null(X)) { + abort("twasZ: provide R, X, or the (V, D, nSketch) SVD triplet.") + } + factor <- .ldFactorFromDosage(.twasZAlignX(X, rn, nrow(weights))) + list(covY = crossprod(factor %*% weights) / (nrow(factor) - 1)) +} + +# Column-align X to the weights (by name when available, else positionally). +# @noRd +#' @importFrom checkmate assertMatrix +.twasZAlignX <- function(X, rn, nW) { + if (!is.null(colnames(X)) && !is.null(rn)) { + idx <- match(rn, colnames(X)) + if (anyNA(idx)) { + msg <- glue( + "twasZ: X is missing columns for {sum(is.na(idx))} ", + "variant(s) named in weights." + ) + abort(msg) } - R <- computeLd(X) + return(X[, idx, drop = FALSE]) } - rSub <- .twasZAlignR(R, rn, nrow(weights)) - list(covY = crossprod(weights, rSub) %*% weights) + assertMatrix(X, ncols = nW, .var.name = "X (positional alignment)") + X } # Symmetric-align R to the weights (by name when available, else positionally). @@ -1528,8 +1571,10 @@ causalInferencePipeline <- function( #' The SVD path (\code{V}, \code{D}, \code{nSketch}) lets the caller avoid #' materializing the full LD matrix: \code{covY = (V^TW * sqrt(Lambda))^T (V^TW #' * sqrt(Lambda))} with \code{Lambda_i = D_i^2 / (nSketch - 1)}. Use the -#' \code{R} path when an LD correlation matrix is already available; use the -#' \code{X} path to compute \code{R} from a genotype matrix. +#' \code{R} path when an LD correlation matrix is already available; the +#' \code{X} path works from a genotype matrix directly, as +#' \code{covY = (F W)^T (F W) / (n - 1)} for its standardized dosages +#' \code{F}, never forming \code{R}. #' #' @param weights Numeric vector of weights (single tuple) or a numeric matrix #' with one column per tuple (method / context). When a vector, the column @@ -1537,8 +1582,9 @@ causalInferencePipeline <- function( #' @param z Numeric vector of GWAS Z-scores aligned to the rows of #' \code{weights}. #' @param R Optional LD correlation matrix. -#' @param X Optional genotype matrix used to compute \code{R} when \code{R} is -#' missing. +#' @param X Optional genotype matrix (samples x variants) standing in for +#' \code{R} when \code{R} is missing; its LD is taken as +#' \code{\link{computeLd}}'s, without forming it. #' @param V,D,nSketch SVD components of the LD sketch (right-singular vectors, #' singular values, panel sample size). Supplying all three selects the SVD #' path. diff --git a/R/colocPipeline.R b/R/colocPipeline.R index f3e301843..d297e2267 100644 --- a/R/colocPipeline.R +++ b/R/colocPipeline.R @@ -25,9 +25,9 @@ NULL # The three argument groups, checked in one place so the pipeline body does # not open with three near-identical lines. # @noRd -.colocAssertGroups <- function(priors, lbfFilterArgs, methodArgs) { - .assertMethodParam(priors, "ColocPriorParam", "priors") - .assertMethodParam(lbfFilterArgs, "ColocLbfFilterParam", "lbfFilter") +.colocAssertGroups <- function(priors, colocLbfFilterParam, methodArgs) { + .assertMethodParam(priors, "ColocPriorParam") + .assertMethodParam(colocLbfFilterParam, "ColocLbfFilterParam") .assertMethodOptions(methodArgs, "ColocOptions", "methodArgs") } @@ -175,8 +175,8 @@ setClass( #' \code{\link{fineMappingPipeline}}; the settings that pipeline exposes #' but that cannot apply here are deliberately absent: #' \code{fineMappingResult} (the pipeline is being asked to produce one), -#' \code{crossValidation} (refused on summary statistics) and -#' \code{residualization} (nothing to regress out). +#' \code{crossValidationParam} (refused on summary statistics) and +#' \code{residualizationParam} (nothing to regress out). #' #' The whole bundle is inert when \code{gwasInput} is already a #' fine-mapping result, since no fit is run. @@ -260,7 +260,7 @@ GwasFineMappingParam <- function( #' \item \strong{fSuSiE support}: the LBF matrix lives at a different #' slot for fSuSiE fits (\code{fsusie_result$lBF}) and gets stacked #' into a single matrix. -#' \item \strong{Effect filtering}: \code{lbfFilter}'s +#' \item \strong{Effect filtering}: \code{colocLbfFilterParam}'s #' \code{filterLbfCs} keeps only effects that produced a credible #' set, its \code{secondary} keeps effects at a secondary coverage; #' otherwise the default filter drops effects whose prior variance is @@ -282,16 +282,18 @@ GwasFineMappingParam <- function( #' inline fine-mapping. #' } #' -#' @section LD-sketch compatibility check: If -#' \code{ldSketch(qtlFineMappingResult)} is non-\code{NULL}, it must come -#' from the same reference panel as the LD sketch on \code{gwasInput}: the -#' same samples, and the same allele orientation on the variants the two -#' carry in common. The two need NOT carry the same variants --- running -#' \code{\link{summaryStatsQc}} on the two sides separately normally leaves -#' each sketch trimmed to its own surviving variants, and LD is looked up per -#' variant, so a partial overlap only warns (once per session). No shared -#' variant at all, a different sample set, or a swapped A1/A2 on a shared -#' variant is a hard error. When the first side's \code{ldSketch} is +#' @section LD reference compatibility check: If +#' \code{ldReference(qtlFineMappingResult)} is non-\code{NULL}, it must be +#' the same LD reference as the one on \code{gwasInput}. +#' The two must be the same kind of reference. Two genotype panels must +#' share their samples and allele orientation; two \code{LdMatrix} objects +#' must agree on the LD they share; two \code{GenotypeMixture} objects must +#' average the same panels with the same weights. The two need NOT +#' carry the same variants --- running \code{\link{summaryStatsQc}} on the +#' two sides separately normally leaves each reference trimmed to its own +#' surviving variants, and LD is looked up per variant, so a partial overlap +#' only warns (once per session). No shared variant at all, or a mismatch of +#' any of those, is a hard error. When the first side's \code{ldReference} is #' \code{NULL} (individual-level fit), the validation is skipped on that side #' and the second side's panel is what the result carries forward. #' @@ -302,7 +304,7 @@ GwasFineMappingParam <- function( #' \code{\link{GwasFineMappingResult}}, or the summary statistics to #' fine-map inline (\code{\link{QtlSumStats}} or #' \code{\link{GwasSumStats}}). -#' @param lbfFilterArgs Credible-set filtering applied before scoring, +#' @param colocLbfFilterParam Credible-set filtering applied before scoring, #' built with #' \code{\link{ColocLbfFilterParam}}. \code{filterLbfCs} keeps only effects #' that produced a credible set; supplying \code{secondary} instead runs a @@ -317,7 +319,7 @@ GwasFineMappingParam <- function( #' \code{\link{ColocPriorParam}}: \code{p1} (QTL signal), \code{p2} (GWAS #' signal) and \code{p12} (shared). Mutually exclusive with #' \code{enrichment}, which derives the same three. -#' @param gwasFineMappingArgs How \code{gwasInput} is fine-mapped when it is +#' @param gwasFineMappingParam How \code{gwasInput} is fine-mapped when it is #' summary statistics rather than a fine-mapping result, built with #' \code{\link{GwasFineMappingParam}}: \code{methods}, #' \code{credibleSetParam}, \code{susieRssParam}, @@ -405,8 +407,8 @@ colocPipeline <- function( qtlFineMappingResult, gwasInput, priors = ColocPriorParam(), - lbfFilterArgs = ColocLbfFilterParam(), - gwasFineMappingArgs = GwasFineMappingParam(), + colocLbfFilterParam = ColocLbfFilterParam(), + gwasFineMappingParam = GwasFineMappingParam(), returnGwasFineMapping = FALSE, enrichment = NULL, adjustPips = TRUE, @@ -417,17 +419,17 @@ colocPipeline <- function( qtlFineMappingResult = qtlFineMappingResult, gwasInput = gwasInput, priors = priors, - gwasFineMappingArgs = gwasFineMappingArgs, + gwasFineMappingParam = gwasFineMappingParam, enrichment = enrichment, adjustPips = adjustPips, methodArgs = methodArgs, - lbfFilterArgs = lbfFilterArgs, + colocLbfFilterParam = colocLbfFilterParam, priorsMissing = missing(priors) ) - # Pre-extract per-GWAS-tuple LBF matrices: group the GWAS FMR by study, - # stack each study's LBF rows, and store per-(study, method) batched - # matrices (reproduces the legacy row-wise combine per xQTL). - gwasLbfByPair <- .colocPreextractGwasLbf(prepared$gwasFmr, lbfFilterArgs) + gwasLbfByPair <- .colocPreextractGwasLbf( + prepared$gwasFmr, + colocLbfFilterParam + ) # Both exits -- no scorable GWAS effect, and the scored result -- shape # their output from the same five values, so they are named once. shape <- list( @@ -443,7 +445,7 @@ colocPipeline <- function( results <- .colocScoreAll( prepared, gwasLbfByPair, - lbfFilterArgs = lbfFilterArgs, + colocLbfFilterParam = colocLbfFilterParam, enrichment = enrichment, priors = priors, alleleFlip = alleleFlip @@ -456,7 +458,7 @@ colocPipeline <- function( .colocScoreAll <- function( prepared, gwasLbfByPair, - lbfFilterArgs, + colocLbfFilterParam, enrichment, priors, alleleFlip @@ -466,7 +468,7 @@ colocPipeline <- function( .colocScoreQtlTuple, qtlFineMappingResult = prepared$qtlFineMappingResult, gwasLbfByPair = gwasLbfByPair, - lbfFilterArgs = lbfFilterArgs, + colocLbfFilterParam = colocLbfFilterParam, useEnrichment = prepared$useEnrichment, enrichment = enrichment, priors = priors, @@ -484,14 +486,14 @@ colocPipeline <- function( qtlFineMappingResult, gwasInput, priors, - gwasFineMappingArgs, + gwasFineMappingParam, enrichment, adjustPips, methodArgs, - lbfFilterArgs, + colocLbfFilterParam, priorsMissing ) { - .colocAssertGroups(priors, lbfFilterArgs, methodArgs) + .colocAssertGroups(priors, colocLbfFilterParam, methodArgs) .colocRefusePriorsWithEnrichment(priors, enrichment, priorsMissing) useEnrichment <- !is.null(enrichment) .colocValidateInputs( @@ -500,10 +502,10 @@ colocPipeline <- function( enrichment = enrichment, useEnrichment = useEnrichment ) - rawGwasFmr <- .colocResolveGwasFmr(gwasInput, gwasFineMappingArgs) - .colocRequireMatchingLdSketches( - ldSketch(qtlFineMappingResult), - ldSketch(rawGwasFmr) + rawGwasFmr <- .colocResolveGwasFmr(gwasInput, gwasFineMappingParam) + .colocRequireMatchingLdRefs( + ldReference(qtlFineMappingResult), + ldReference(rawGwasFmr) ) adjusted <- .colocMaybeAdjustPips( adjustPips = adjustPips, @@ -598,17 +600,16 @@ colocPipeline <- function( # Resolve the second side to a fine-mapping collection (fine-map QC'd sumstats # when summary statistics are passed, whichever flavour they are). # @noRd -.colocResolveGwasFmr <- function(gwasInput, gwasFineMappingArgs) { +.colocResolveGwasFmr <- function(gwasInput, gwasFineMappingParam) { if (methods::is(gwasInput, "FineMappingResultBase")) { # Already fine-mapped: nothing in the bundle applies, so a setting # given here would be dropped rather than honoured. - .colocAssertGwasFmrUnset(gwasFineMappingArgs, class(gwasInput)[[1L]]) + .colocAssertGwasFmrUnset(gwasFineMappingParam, class(gwasInput)[[1L]]) return(gwasInput) } .assertMethodParam( - gwasFineMappingArgs, - "GwasFineMappingParam", - "gwasFineMapping" + gwasFineMappingParam, + "GwasFineMappingParam" ) if (length(qcInfo(gwasInput)) == 0L) { msg <- glue( @@ -619,44 +620,44 @@ colocPipeline <- function( } # The bundle's terminal: fineMappingPipeline takes these as its own # arguments, so it is unrolled once, here. + withSusieInf <- gwasFineMappingParam$initializeWithSusieInf %||% TRUE fineMappingPipeline( gwasInput, - methods = gwasFineMappingArgs$methods %||% "susie", - credibleSetParam = gwasFineMappingArgs$credibleSetParam %||% + methods = gwasFineMappingParam$methods %||% "susie", + credibleSetParam = gwasFineMappingParam$credibleSetParam %||% CredibleSetParam(), - susieRssParam = gwasFineMappingArgs$susieRssParam %||% SusieRssParam(), - panelFilterParam = gwasFineMappingArgs$panelFilterParam %||% + susieRssParam = gwasFineMappingParam$susieRssParam %||% SusieRssParam(), + panelFilterParam = gwasFineMappingParam$panelFilterParam %||% PanelFilterParam(), - initializeWithSusieInf = gwasFineMappingArgs$initializeWithSusieInf %||% - TRUE, - fitRetention = gwasFineMappingArgs$fitRetention %||% "slim" + initializeWithSusieInf = withSusieInf, + fitRetention = gwasFineMappingParam$fitRetention %||% "slim" ) } -# `gwasFineMapping` configures the fine-mapping run colocPipeline does on a -# raw GWAS input. A caller who has already fine-mapped the GWAS has no such +# `gwasFineMappingParam` configures the fine-mapping run colocPipeline does on +# a raw GWAS input. A caller who has already fine-mapped the GWAS has no such # run, so a non-default bundle is an instruction that cannot be carried out. # @noRd -.colocAssertGwasFmrUnset <- function(gwasFineMappingArgs, inputClass) { - if (!.isMethodParam(gwasFineMappingArgs)) { +.colocAssertGwasFmrUnset <- function(gwasFineMappingParam, inputClass) { + if (!.isMethodParam(gwasFineMappingParam)) { return(invisible(NULL)) } defaults <- GwasFineMappingParam() set <- keep( names(defaults), .colocGwasFmrFieldSet, - given = gwasFineMappingArgs, + given = gwasFineMappingParam, defaults = defaults ) if (length(set) == 0L) { return(invisible(NULL)) } abort(glue( - "colocPipeline: `gwasFineMapping` ", + "colocPipeline: `gwasFineMappingParam` ", "({str_flatten(str_c(set, ' ='), ', ')}) configures the GWAS ", "fine-mapping run, but `gwasInput` is already a ", "{inputClass} -- there is no run to configure. ", - "Drop `gwasFineMapping`, or pass the raw GwasSumStats instead." + "Drop `gwasFineMappingParam`, or pass the raw GwasSumStats instead." )) } @@ -695,12 +696,12 @@ colocPipeline <- function( # The LD reference the result carries forward, so colocCredibleSets() can # recompute purity (section 3.7) without being handed a sketch separately. The # two sides' sketches are already required to match by -# .colocRequireMatchingLdSketches, so either one identifies the panel -- but a +# .colocRequireMatchingLdRefs, so either one identifies the panel -- but a # first side fit on individual-level data carries none, and then the second # side's panel is the only one there is. # @noRd -.colocLdSketch <- function(qtlFineMappingResult, gwasFmr) { - ldSketch(qtlFineMappingResult) %||% ldSketch(gwasFmr) +.colocLdRef <- function(qtlFineMappingResult, gwasFmr) { + ldReference(qtlFineMappingResult) %||% ldReference(gwasFmr) } # Empty-result early return (attaching the GWAS fine-mapping when requested). @@ -714,7 +715,7 @@ colocPipeline <- function( ) { out <- .colocEmptyResult( enriched = useEnrichment, - ldSketch = .colocLdSketch(qtlFineMappingResult, gwasFmr) + ldReference = .colocLdRef(qtlFineMappingResult, gwasFmr) ) .colocAttachGwasFm(out, returnGwasFineMapping, gwasInput, gwasFmr) } @@ -725,7 +726,7 @@ colocPipeline <- function( qi, qtlFineMappingResult, gwasLbfByPair, - lbfFilterArgs, + colocLbfFilterParam, useEnrichment, enrichment, priors, @@ -735,7 +736,7 @@ colocPipeline <- function( q <- .colocQtlTupleInfo(qi, qtlFineMappingResult) qLbfInfo <- .colocExtractLbfFromEntry( q$parts, - lbfFilterArgs, + colocLbfFilterParam, label = q$label ) if (is.null(qLbfInfo)) { @@ -1050,7 +1051,7 @@ colocPipeline <- function( out <- .colocAssemble( results, useEnrichment, - .colocLdSketch(qtlFineMappingResult, gwasFmr) + .colocLdRef(qtlFineMappingResult, gwasFmr) ) .colocAttachGwasFm(out, returnGwasFineMapping, gwasInput, gwasFmr) } @@ -1067,13 +1068,16 @@ colocPipeline <- function( # Row-bind + column-order the per-pair summary rows (empty result when none). # @noRd -.colocAssemble <- function(results, useEnrichment, ldSketch = NULL) { +.colocAssemble <- function(results, useEnrichment, ldReference = NULL) { if (length(results) == 0L) { - return(.colocEmptyResult(enriched = useEnrichment, ldSketch = ldSketch)) + return(.colocEmptyResult( + enriched = useEnrichment, + ldReference = ldReference + )) } rows <- bind_rows(map(map(results, "rows"), .colocStandardiseRow)) variants <- list_c(map(results, "variants")) - ColocResult(.colocOrderColumns(rows, useEnrichment), variants, ldSketch) + ColocResult(.colocOrderColumns(rows, useEnrichment), variants, ldReference) } # Identity columns first, then everything coloc produced. @@ -1101,11 +1105,11 @@ colocPipeline <- function( # ============================================================================= # LD-sketch compatibility check. Thin wrapper over the shared -# `.requireMatchingLdSketches` helper (R/ld.R). Shared with +# `.requireMatchingLdRefs` helper (R/ld.R). Shared with # qtlEnrichmentPipeline. # @noRd -.colocRequireMatchingLdSketches <- function(qtlLd, gwasLd) { - .requireMatchingLdSketches(qtlLd, gwasLd, pipelineName = "colocPipeline") +.colocRequireMatchingLdRefs <- function(qtlLd, gwasLd) { + .requireMatchingLdRefs(qtlLd, gwasLd, pipelineName = "colocPipeline") } # SuSiE credible-set concentration filter. Given a trimmed SuSiE fit @@ -1136,7 +1140,8 @@ colocPipeline <- function( # Extract an LBF matrix (effects x variants) from a FineMappingRow, # applying the same filtering knobs as the legacy .extractLbfMatrix, now -# carried as one `lbfFilter` bundle rather than three loose arguments: +# carried as one `colocLbfFilterParam` bundle rather than three loose +# arguments: # - filterLbfCs (CS-only) # - secondary (secondary coverage CS, with a concentration cutoff) # - priorTol drop on V (default) @@ -1146,7 +1151,7 @@ colocPipeline <- function( # @noRd .colocExtractLbfFromEntry <- function( parts, - lbfFilterArgs, + colocLbfFilterParam, label = "entry" ) { fit <- susieFit(parts) @@ -1161,7 +1166,7 @@ colocPipeline <- function( # stays a skip; it is only an ABSENT LBF that is an error. allRows <- .colocLbfMatrix(fit, label) allMass <- .colocEffectRetainedMass(fit, nrow(allRows)) - keep <- .colocSelectLbfRows(allRows, fit, lbfFilterArgs) + keep <- .colocSelectLbfRows(allRows, fit, colocLbfFilterParam) kept <- allRows[keep, , drop = FALSE] mass <- allMass[keep] if (nrow(kept) == 0L) { @@ -1223,25 +1228,28 @@ colocPipeline <- function( # matching when the exact name is absent, so a fit carrying `sets_secondary` # but no `sets` would silently filter on the wrong element. # @noRd -.colocSelectLbfRows <- function(lbfMatrix, fit, lbfFilterArgs) { +.colocSelectLbfRows <- function(lbfMatrix, fit, colocLbfFilterParam) { # Read off the bundle like the other three filter fields, rather than # taken as a second copy of a value the caller already has in hand. - priorTol <- lbfFilterArgs$priorTol %||% 1e-9 + priorTol <- colocLbfFilterParam$priorTol %||% 1e-9 # The only place the filter's fields are read. Every function between # here and colocPipeline carries the bundle whole, so the names cannot # drift apart on the way down. allRows <- seq_len(nrow(lbfMatrix)) - if (isTRUE(lbfFilterArgs$filterLbfCs) && is.null(lbfFilterArgs$secondary)) { + if ( + isTRUE(colocLbfFilterParam$filterLbfCs) && + is.null(colocLbfFilterParam$secondary) + ) { csIdx <- fit[["sets"]][["cs_index"]] if (!is.null(csIdx) && length(csIdx) > 0L) { return(csIdx) } - } else if (!is.null(lbfFilterArgs$secondary)) { + } else if (!is.null(colocLbfFilterParam$secondary)) { secIdx <- try_fetch( .colocFilterCsByConcentration( fit, - coverage = lbfFilterArgs$secondary, - concentration = lbfFilterArgs$concentration + coverage = colocLbfFilterParam$secondary, + concentration = colocLbfFilterParam$concentration ), error = function(cnd) NULL ) @@ -1299,7 +1307,7 @@ colocPipeline <- function( # another's. Nothing downstream indexes this list by name, so positional # records make the collision impossible instead of merely unlikely. # @noRd -.colocPreextractGwasLbf <- function(gwasFmr, lbfFilterArgs) { +.colocPreextractGwasLbf <- function(gwasFmr, colocLbfFilterParam) { if (nrow(gwasFmr) == 0L) { return(list()) } @@ -1309,7 +1317,7 @@ colocPipeline <- function( gwasFmr = gwasFmr, blockIds = .colocGwasBlockIds(gwasFmr), side = .fmrSideName(gwasFmr), - lbfFilterArgs = lbfFilterArgs + colocLbfFilterParam = colocLbfFilterParam )) } @@ -1321,14 +1329,14 @@ colocPipeline <- function( gwasFmr, blockIds, side, - lbfFilterArgs + colocLbfFilterParam ) { ident <- .colocTupleIdentity(gwasFmr, ri) blockId <- blockIds[[ri]] label <- .fmrTupleLabel(side, ident, block = blockId) info <- .colocExtractLbfFromEntry( .fmrRowParts(gwasFmr, ri), - lbfFilterArgs, + colocLbfFilterParam, label = label ) if (is.null(info)) { @@ -1387,7 +1395,7 @@ colocPipeline <- function( # do not have to special-case a NULL return. When `enriched = TRUE` the # enrichment + p12Used columns are appended (the enloc-mode schema). # @noRd -.colocEmptyResult <- function(enriched = FALSE, ldSketch = NULL) { +.colocEmptyResult <- function(enriched = FALSE, ldReference = NULL) { base <- tibble( study = character(0), context = character(0), @@ -1414,7 +1422,7 @@ colocPipeline <- function( ColocResult( mutate(base, !!!.colocEnrichmentCols(enriched, NULL)), list(), - ldSketch = ldSketch + ldReference = ldReference ) } @@ -1542,9 +1550,6 @@ colocPipeline <- function( # ---- map/apply helpers (lambda-free callbacks) --------------------------- -# The variant ids of one fine-mapping entry (S4 slot; not pluckable by name). -# @noRd - # Score the first side's LBF against one second-side record -> a summary row # (or NULL). # @noRd diff --git a/R/colocboostPipeline.R b/R/colocboostPipeline.R index 592ad5c77..633b86dfc 100644 --- a/R/colocboostPipeline.R +++ b/R/colocboostPipeline.R @@ -8,7 +8,7 @@ #' extracted from the dataset (filtering knobs on the #' constructor apply lazily inside the accessors). #' \item \code{QtlSumStats} -- summary-statistic-only QTL data with a -#' shared LD reference (\code{ldSketch}). Must already have +#' shared LD reference (\code{ldReference}). Must already have #' been passed through \code{\link{summaryStatsQc}} (the #' pipeline rejects inputs whose \code{qcInfo()} is empty). #' Every analysis variant is available on this input, including @@ -21,7 +21,7 @@ #' GWAS is optional and always passed separately as a #' \code{GwasSumStats} object (must also be QC'd). #' -#' \code{colocboostPipeline} does \strong{not} accept a \code{FineMappingResult} +#' \code{colocboostPipeline} does \strong{not} accept a fine-mapping result #' for either side; colocboost has its own variable-selection algorithm. #' #' @section QC contract: @@ -32,17 +32,17 @@ #' \code{genotypes()} / \code{residualizedGenotypes()}. #' The pipeline does \emph{not} run a separate #' individual-level QC pass. -#' \item \code{panelFilter} acts at ANALYSIS time on the sumstat +#' \item \code{panelFilterParam} acts at ANALYSIS time on the sumstat #' sides, measured against the \strong{LD reference panel}: a #' variant whose panel genotypes fall below its cutoffs is dropped #' before the LD matrix is built. It applies to a #' \code{QtlSumStats} QTL side and to a \code{GwasSumStats} GWAS #' side (so it still bites when the QTL side is #' individual-level). Its defaults filter nothing. Unlike -#' \code{summaryStatsQc(imputeArgs = ...)}, which only bounds what +#' \code{summaryStatsQc(raissParam = ...)}, which only bounds what #' RAISS will impute, these discard \emph{observed} variants. #' \item All summary-statistic QC (variant filters, harmonization -#' against the \code{ldSketch}, LD-mismatch detection, RAISS +#' against the \code{ldReference}, LD-mismatch detection, RAISS #' imputation, etc.) lives in #' \code{\link{summaryStatsQc}}. The pipeline rejects any #' \code{QtlSumStats} or \code{GwasSumStats} where @@ -96,7 +96,7 @@ #' GWAS study focal. #' @param xqtlColoc,jointGwas,separateGwas Logical flags selecting which #' colocboost variants to run. -#' @param signalScreenArgs Individual-level pre-filter (ports the legacy +#' @param signalScreenParam Individual-level pre-filter (ports the legacy #' \code{pip_cutoff_to_skip_ind}), built with #' \code{\link{SignalScreenParam}}. For each context every outcome is fit #' with a single-effect SuSiE (\code{L = 1}) and dropped unless the chosen @@ -121,7 +121,7 @@ #' below its cutoffs is dropped before the LD matrix is built. The defaults #' filter nothing. See the Details section for how these relate to the #' individual-level cutoffs recorded on a \code{QtlDataset}. -#' @param residualizationArgs Covariate residualization settings for +#' @param residualizationParam Covariate residualization settings for #' individual-level input, built with \code{\link{ResidualizationParam}}. #' Reaches both \code{\link{residualizedGenotypes}} and #' \code{\link{residualizedPhenotypes}}, so it governs what is regressed @@ -243,16 +243,16 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # Helpers (private) # ============================================================================= -# Build the LD / X_ref slot of the colocboost call from a list of LD -# matrices. When any matrix is non-square it is treated as a samples x -# variants genotype reference and routed to X_ref; otherwise routed to LD. -.cbBuildLdArgs <- function(ldList) { +# Build the LD / X_ref slot of the colocboost call from a bundle's LD list. +# `ldArg` says which the list holds -- LD matrices ("LD") or factors of them +# ("X_ref"), which colocboost correlates itself -- as .cbMergeSumstatBundles() +# records it; a factor can be square by coincidence, so its shape cannot say. +.cbBuildLdArgs <- function(ldList, ldArg = "LD") { ldList <- compact(ldList) if (length(ldList) == 0L) { return(list()) } - isGeno <- any(map_lgl(ldList, .cbIsNonSquare)) - if (isGeno) list(X_ref = ldList) else list(LD = ldList) + set_names(list(ldList), ldArg) } # Reject SumStats objects that have not been passed through @@ -308,7 +308,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { cisWindow = NULL, samples = NULL, pipCutoffToSkip = 0, - residualizationArgs = ResidualizationParam() + residualizationParam = ResidualizationParam() ) { contexts <- .cbResolveBundleContexts(qd, contexts) p <- list( @@ -318,7 +318,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { cisWindow = cisWindow, samples = samples, pipCutoffToSkip = pipCutoffToSkip, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ) built <- compact(map(contexts, .cbBuildContextXY, p = p)) if (length(built) == 0L) { @@ -373,7 +373,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ctx, p$traitId, p$region, - p$residualizationArgs + p$residualizationParam ) if (is.null(rawY) || ncol(rawY) == 0L) { return(NULL) @@ -385,7 +385,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { p$region, p$cisWindow, p$samples, - p$residualizationArgs + p$residualizationParam ) if (is.null(rawX) || ncol(rawX) == 0L) { return(NULL) @@ -425,7 +425,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ctx, traitId, region, - residualizationArgs = ResidualizationParam() + residualizationParam = ResidualizationParam() ) { try_fetch( residualizedPhenotypes( @@ -433,7 +433,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { contexts = ctx, traitId = traitId, region = region, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ), error = function(cnd) { msg <- glue( @@ -455,7 +455,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { region, cisWindow, samples, - residualizationArgs = ResidualizationParam() + residualizationParam = ResidualizationParam() ) { try_fetch( residualizedGenotypes( @@ -465,7 +465,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { region = region, cisWindow = cisWindow, samples = samples, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ), error = function(cnd) { msg <- glue( @@ -621,10 +621,10 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # Build a single (sumstat data.frame, LD correlation matrix) pair from a # QtlSumStats / GwasSumStats entry. Returns NULL when the entry has no -# variants overlapping the ldSketch panel. +# variants overlapping the ldReference panel. .cbSumstatPair <- function( df, - ldSketch, + ldReference, varY = NULL, nCase = NULL, nControl = NULL, @@ -644,35 +644,42 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # the two. wanted <- variantIds[.panelKeepMask( variantIds, - ldSketch, + ldReference, cutoffs, ".cbSumstatPair" )] if (length(wanted) == 0L) { return(NULL) } - # Use the shared `.ldFromSketch` helper in "drop" mode so missing-from-panel - # variants are silently filtered (the colocboost path expects to operate - # only on the overlap). - R <- .ldFromSketch( - ldSketch, - wanted, - label = ".cbSumstatPair", - onMissing = "drop" - ) - if (is.null(R)) { + ld <- .cbPairLd(ldReference, wanted) + if (is.null(ld)) { return(NULL) } - keptIds <- attr(R, "keptVariantIds") + keptIds <- attr(ld, "keptVariantIds") kept <- filter(df, is_in(variantIds, keptIds)) ss <- .cbSumstatFrame(kept, keptIds, nCase, nControl, varY) list( sumstat = ss, - LD = `attr<-`(R, "keptVariantIds", NULL), - variantIds = keptIds + LD = `attr<-`(ld, "keptVariantIds", NULL), + variantIds = keptIds, + isFactor = .ldIsGenotypeRef(ldReference) ) } +# The LD of the `wanted` variants the panel holds, the rest dropped (the +# colocboost path expects to operate only on the overlap): a genotype +# reference's factor, which colocboost takes as X_ref and correlates itself, +# or an LdMatrix's matrix. +# @noRd +.cbPairLd <- function(ldReference, wanted) { + ldFrom <- if (.ldIsGenotypeRef(ldReference)) { + .ldFactorFromRef + } else { + .ldFromRef + } + ldFrom(ldReference, wanted, label = ".cbSumstatPair", onMissing = "drop") +} + # The colocboost sumstat frame for one entry, over the variants the LD panel # kept. `var_y` is added only when supplied: colocboost treats its absence as # "z-scale", so writing NA would change the model rather than say nothing. @@ -734,7 +741,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { if (is.null(ss) || nrow(ss) == 0L) { return(list()) } - ldSketch <- ldSketch(ss) + ldReference <- ldReference(ss) byContext <- if (!is.null(contexts) && length(contexts) > 0L) { is_in(as.character(ss$context), contexts) } else { @@ -756,7 +763,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { rows, .cbQtlEntryPair, ss = ss, - ldSketch = ldSketch, + ldReference = ldReference, cutoffs = cutoffs ), map_chr(rows, .cbQtlEntryLabel, ss = ss) @@ -775,7 +782,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # One QTL entry's (sumstat, LD) pair, or NULL when it has no panel overlap. # @noRd -.cbQtlEntryPair <- function(i, ss, ldSketch, cutoffs) { +.cbQtlEntryPair <- function(i, ss, ldReference, cutoffs) { .cbSumstatPair( df = as.data.frame( ss, @@ -784,7 +791,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { trait = as.character(ss$trait)[[i]], require = "Z" ), - ldSketch = ldSketch, + ldReference = ldReference, varY = .cbTupleValue(ss, "varY", i), cutoffs = cutoffs ) @@ -807,13 +814,13 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { if (is.null(gws) || nrow(gws) == 0L) { return(list()) } - ldSketch <- ldSketch(gws) + ldReference <- ldReference(gws) compact(set_names( map( seq_len(nrow(gws)), .cbGwasEntryPair, gws = gws, - ldSketch = ldSketch, + ldReference = ldReference, cutoffs = cutoffs ), as.character(gws$study) @@ -822,14 +829,14 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # One GWAS entry's (sumstat, LD) pair, or NULL when it has no panel overlap. # @noRd -.cbGwasEntryPair <- function(i, gws, ldSketch, cutoffs) { +.cbGwasEntryPair <- function(i, gws, ldReference, cutoffs) { .cbSumstatPair( df = as.data.frame( gws, studyName = as.character(gws$study)[[i]], require = "Z" ), - ldSketch = ldSketch, + ldReference = ldReference, varY = .cbTupleValue(gws, "varY", i), nCase = .cbTupleValue(gws, "nCase", i), nControl = .cbTupleValue(gws, "nControl", i), @@ -838,12 +845,12 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { } # Check two LD sketches for the reference-panel compatibility contract. Thin -# wrapper over the shared `.requireMatchingLdSketches` helper (R/ld.R) +# wrapper over the shared `.requireMatchingLdRefs` helper (R/ld.R) # using the "lenient" null policy: a NULL on either side skips the check # (only colocboostPipeline allows that, since some bundles only have a # QTL side or only a GWAS side). -.cbRequireMatchingLdSketches <- function(qtlLd, gwasLd) { - .requireMatchingLdSketches( +.cbRequireMatchingLdRefs <- function(qtlLd, gwasLd) { + .requireMatchingLdRefs( qtlLd, gwasLd, pipelineName = "colocboostPipeline", @@ -853,15 +860,26 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # Combine sumstat bundles into the (sumstat-list, LD-list, dict) shape # colocboost expects. Deduplicates identical LD matrices so dict_sumstatLD -# can point multiple sumstats at one LD. +# can point multiple sumstats at one LD, and records in `ldArg` whether the +# list holds LD matrices ("LD") or factors of them ("X_ref"). Every side of +# a run reads one LD reference (.cbRequireMatchingLdRefs()), so the bundles +# never mix the two. .cbMergeSumstatBundles <- function(bundles) { if (length(bundles) == 0L) { return(list( sumstat = list(), LD = list(), - dict_sumstatLD = matrix(integer(0), ncol = 2L) + dict_sumstatLD = matrix(integer(0), ncol = 2L), + ldArg = "LD" )) } + kinds <- unique(map_lgl(bundles, .cbPairIsFactor)) + if (length(kinds) > 1L) { + abort( + "colocboost inputs mix LD matrices and genotype factors.", + .internal = TRUE + ) + } # Same shape as .cbDedupX: every bundle resolves to the first bundle # carrying an identical LD matrix, so the unique set and the back-mapping # both fall out without carrying state. @@ -874,7 +892,8 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { dict_sumstatLD = cbind( sumstat = seq_along(bundles), LD = match(firstIdx, keepIdx) - ) + ), + ldArg = if (kinds) "X_ref" else "LD" ) } @@ -903,10 +922,6 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ) } -# A requested analysis with nothing to run on would otherwise be a silent -# no-op: the caller gets an empty ColocBoostResult whose computingTime() -# entries are all NULL, with no indication of why. Say so. -# @noRd # TRUE when an analysis was requested and has the data to run. When it was # requested but cannot run, warn and answer FALSE, so the caller's compact() # drops it instead of skipping it silently. @@ -922,6 +937,10 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { FALSE } +# A requested analysis with nothing to run on would otherwise be a silent +# no-op: the caller gets an empty ColocBoostResult whose computingTime() +# entries are all NULL, with no indication of why. Say so. +# @noRd .cbWarnNoData <- function(flag, needed) { msg <- glue( "colocboostPipeline: {flag} = TRUE was requested, but there is no ", @@ -933,48 +952,25 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { } # Shared dispatch: accepts a fully-prepared individual bundle (possibly -# NULL) plus a sumstat bundle (possibly empty) and runs the three -# colocboost variants the user requested. `qtlSumstatBundle` is the QTL-side -# subset of `sumstatBundle` (see .cbDriver); only the xQTL-only run uses it, -# so that a GWAS study never becomes an xQTL-only outcome. -# The analyses that were requested AND have data to run on, keyed by the -# result slot each fills. .cbCanRun warns in the "requested but cannot" case -# so the skip is never silent, and compact() drops what did not run. +# NULL) plus a sumstat bundle (possibly empty) and runs the colocboost +# variants `run` (from .cbResolveRuns) switched on. `qtlSumstatBundle` is the +# QTL-side subset of `sumstatBundle` (see .cbDriver); only the xQTL-only run +# uses it, so that a GWAS study never becomes an xQTL-only outcome. The +# result is keyed by the result slot each run fills; compact() drops what did +# not run. # @noRd .cbDispatchRuns <- function( individualBundle, sumstatBundle, qtlSumstatBundle, - xqtlColoc, - jointGwas, - separateGwas, + run, hasInd, - hasSs, - hasQtlSs, focalTrait, methodArgs, - gwasRunBundles = list(), - hasGwasSs = FALSE + gwasRunBundles = list() ) { - # Resolved first, in the order the runs are listed: .cbCanRun() warns - # when a requested analysis has no data for it, and hoisting keeps those - # warnings in the same order they were emitted inline. - ssNeeded <- "summary-statistic data" - runXqtl <- .cbCanRun( - xqtlColoc, - hasInd || hasQtlSs, - "xqtlColoc", - "QTL data" - ) - runJoint <- .cbCanRun(jointGwas, hasSs, "jointGwas", ssNeeded) - runSeparate <- .cbCanRun( - separateGwas, - hasGwasSs, - "separateGwas", - "GWAS summary statistics" - ) compact(list( - xqtl_coloc = if (runXqtl) { + xqtl_coloc = if (run$xqtl) { .cbRunXqtlOnly( individualBundle, qtlSumstatBundle, @@ -983,7 +979,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { methodArgs ) }, - joint_gwas = if (runJoint) { + joint_gwas = if (run$joint) { .cbRunJointGwas( individualBundle, sumstatBundle, @@ -992,7 +988,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { gwasNames = names(gwasRunBundles) ) }, - separate_gwas = if (runSeparate) { + separate_gwas = if (run$separate) { .cbRunSeparateGwas( individualBundle, gwasRunBundles, @@ -1003,6 +999,45 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { )) } +# Which analyses were requested AND have data to run on. .cbCanRun warns in +# the "requested but cannot" case so the skip is never silent; the flags are +# resolved in the order the runs are listed, so those warnings keep that +# order. separateGwas needs a GWAS, not merely "some summary statistics": a +# QTL-only sumstat input used to satisfy a `hasSs` guard and then run one +# focal pass per QTL study. +# @noRd +.cbResolveRuns <- function( + xqtlColoc, + jointGwas, + separateGwas, + hasInd, + hasSs, + qtlSumstatBundle, + gwasRunBundles +) { + hasQtlSs <- length(qtlSumstatBundle$sumstat) > 0L + list( + xqtl = .cbCanRun( + xqtlColoc, + hasInd || hasQtlSs, + "xqtlColoc", + "QTL data" + ), + joint = .cbCanRun( + jointGwas, + hasSs, + "jointGwas", + "summary-statistic data" + ), + separate = .cbCanRun( + separateGwas, + length(gwasRunBundles) > 0L, + "separateGwas", + "GWAS summary statistics" + ) + ) +} + # Each run's result and timing folded into the empty result skeleton, so a # slot no analysis filled keeps the skeleton's own (empty) value. # @noRd @@ -1044,7 +1079,9 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { Y[, keep, drop = FALSE] } - +# Run the requested colocboost analyses over the prepared bundles and fold +# them into a ColocBoostResult (an empty one when no QTL input remains). +# @noRd .cbRunVariants <- function( individualBundle, sumstatBundle, @@ -1053,19 +1090,13 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { separateGwas, focalTrait, methodArgs, - qtlLdSketch = NULL, + qtlLdReference = NULL, qtlSumstatBundle = NULL, gwasRunBundles = list() ) { - empty <- .cbEmptyResult() hasInd <- !is.null(individualBundle) hasSs <- length(sumstatBundle$sumstat) > 0L qtlSumstatBundle <- qtlSumstatBundle %||% .cbMergeSumstatBundles(list()) - hasQtlSs <- length(qtlSumstatBundle$sumstat) > 0L - # separateGwas needs a GWAS, not merely "some summary statistics": a - # QTL-only sumstat input used to satisfy the old `hasSs` guard and then - # run one focal pass per QTL study. - hasGwasSs <- length(gwasRunBundles) > 0L if (!hasInd && !hasSs) { msg <- glue( "colocboostPipeline: no QTL inputs remain after selection. ", @@ -1074,26 +1105,30 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { inform(msg) return(.cbEmptyResultObject()) } - runs <- .cbDispatchRuns( - individualBundle, - sumstatBundle, - qtlSumstatBundle, + run <- .cbResolveRuns( xqtlColoc, jointGwas, separateGwas, hasInd, hasSs, - hasQtlSs, + qtlSumstatBundle, + gwasRunBundles + ) + runs <- .cbDispatchRuns( + individualBundle, + sumstatBundle, + qtlSumstatBundle, + run, + hasInd, focalTrait, methodArgs, - gwasRunBundles = gwasRunBundles, - hasGwasSs = hasGwasSs + gwasRunBundles = gwasRunBundles ) - results <- .cbMergeRuns(empty, runs) + results <- .cbMergeRuns(.cbEmptyResult(), runs) .cbToResultObject( results, .cbOutcomeInfo(individualBundle, sumstatBundle, hasInd), - qtlLdSketch + qtlLdReference ) } @@ -1110,14 +1145,6 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ) } -# Flatten the three raw colocboost runs into one ColocBoostResult. -# -# The three analyses are NOT parallel structures: xqtl_coloc and joint_gwas are -# each a single colocboost object, while separate_gwas is a NAMED LIST of them, -# one per GWAS study -- one level deeper. That is why `gwasStudy` exists as a -# key: without it the separate-GWAS sets would be indistinguishable from each -# other once flattened. -# @noRd # @noRd .cbJointRun <- function(nm, results) { if (is.null(results[[nm]])) { @@ -1143,7 +1170,15 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { map_chr(entries, field) } -.cbToResultObject <- function(results, outcomeInfo, ldSketch = NULL) { +# Flatten the three raw colocboost runs into one ColocBoostResult. +# +# The three analyses are NOT parallel structures: xqtl_coloc and joint_gwas are +# each a single colocboost object, while separate_gwas is a NAMED LIST of them, +# one per GWAS study -- one level deeper. That is why `gwasStudy` exists as a +# key: without it the separate-GWAS sets would be indistinguishable from each +# other once flattened. +# @noRd +.cbToResultObject <- function(results, outcomeInfo, ldReference = NULL) { sep <- results$separate_gwas sepRuns <- if (is.null(sep) || length(sep) == 0L) { list() @@ -1170,7 +1205,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { analysis = .cbEntryField(entries, "analysis"), gwasStudy = .cbEntryField(entries, "gwasStudy"), outcomeInfo = outcomeInfo, - ldSketch = ldSketch, + ldReference = ldReference, computingTime = results$computing_time %||% list() ) } @@ -1219,7 +1254,11 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { nCtx <- if (hasInd) length(individualBundle$Y) else 0L nSs <- length(sumstatBundle$sumstat) .cbAnnounceXqtl(nCtx, nSs) - ldArgs <- if (nSs > 0L) .cbBuildLdArgs(sumstatBundle$LD) else list() + ldArgs <- if (nSs > 0L) { + .cbBuildLdArgs(sumstatBundle$LD, sumstatBundle$ldArg) + } else { + list() + } args <- c( list( X = if (hasInd) individualBundle$X else NULL, @@ -1298,7 +1337,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { if (hasInd) individualBundle$outcomeNames else character(), ssNames ) - ldArgs <- .cbBuildLdArgs(sumstatBundle$LD) + ldArgs <- .cbBuildLdArgs(sumstatBundle$LD, sumstatBundle$ldArg) # The merged bundle holds QTL sumstats as well as GWAS, so split the # labels rather than calling every sumstat a GWAS: a context is any # outcome that is not one of the GWAS studies, whether it arrived as @@ -1381,7 +1420,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # `runBundle` carries every QTL sumstat followed by this one GWAS, so the # whole LD list and its dict come along -- the same shape as the joint # run, but focal on the last outcome. - ldArgs <- .cbBuildLdArgs(runBundle$LD) + ldArgs <- .cbBuildLdArgs(runBundle$LD, runBundle$ldArg) traits <- c( if (hasInd) individualBundle$outcomeNames else character(), names(runBundle$sumstat) @@ -1443,9 +1482,10 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # Relabel a (sumstat, LD) pair to the canonical coding: flip the z-score and the # LD sign-submatrix for variants swapped relative to canonical -# (LD_ij -> sign_i * sign_j * LD_ij), drop unmatched variants, and relabel to -# canonical. The sumstat and its LD share one sign vector, so they stay -# consistent. Returns NULL when no variant matches. +# (LD_ij -> sign_i * sign_j * LD_ij; on a factor, the swapped columns are +# negated), drop unmatched variants, and relabel to canonical. The sumstat +# and its LD share one sign vector, so they stay consistent. Returns NULL +# when no variant matches. # @noRd .cbFlipPairToCanonical <- function(p, canonical) { mm <- matchVariants(p$sumstat$variant, canonical) @@ -1461,11 +1501,31 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { z = .data$z * sgn, variant = canonical[ib] ) - ld <- `dimnames<-`( - p$LD[ia, ia, drop = FALSE] * outer(sgn, sgn), - list(canonical[ib], canonical[ib]) + isFactor <- .cbPairIsFactor(p) + ld <- if (isFactor) { + `colnames<-`( + sweep(p$LD[, ia, drop = FALSE], 2L, sgn, FUN = "*"), + canonical[ib] + ) + } else { + `dimnames<-`( + p$LD[ia, ia, drop = FALSE] * outer(sgn, sgn), + list(canonical[ib], canonical[ib]) + ) + } + list( + sumstat = ss, + LD = ld, + variantIds = canonical[ib], + isFactor = isFactor ) - list(sumstat = ss, LD = ld, variantIds = canonical[ib]) +} + +# TRUE when a (sumstat, LD) pair carries a factor of its LD rather than the +# matrix. +# @noRd +.cbPairIsFactor <- function(p) { + isTRUE(p$isFactor) } # Harmonize the allele coding of every colocboost input (individual X columns, @@ -1528,6 +1588,12 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # are per-tuple lists of `list(sumstat, LD)` produced by the per-class # bundle helpers; they are merged here so dict_sumstatLD can dedupe # identical LD matrices across QTL and GWAS sides. +# +# The xQTL-only run gets its own bundle over just the QTL-side pairs, so a +# GWAS study is never treated as an xQTL outcome. Rebuilding it through +# .cbMergeSumstatBundles (rather than subsetting the merged one) keeps the +# deduplicated LD list and dict_sumstatLD consistent for the subset. +# @noRd .cbDriver <- function( individualBundle, qtlPairs, @@ -1537,7 +1603,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { separateGwas, focalTrait, methodArgs, - qtlLdSketch = NULL, + qtlLdReference = NULL, alleleFlip = TRUE, cutoffs = NULL ) { @@ -1548,7 +1614,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { combinedPairs <- .cbAppendGwasPairs( qtlPairs, gwasSumStats, - qtlLdSketch, + qtlLdReference, cutoffs = cutoffs ) harmonized <- .cbMaybeHarmonize( @@ -1557,29 +1623,9 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { alleleFlip ) sumstatBundle <- .cbMergeSumstatBundles(harmonized$pairs) - # The xQTL-only run gets its own bundle over just the QTL-side pairs, so - # a GWAS study is never treated as an xQTL outcome. Rebuilding it through - # .cbMergeSumstatBundles (rather than subsetting the merged one) keeps the - # deduplicated LD list and dict_sumstatLD consistent for the subset. qtlKeys <- intersect(names(harmonized$pairs), names(qtlPairs)) qtlSumstatBundle <- .cbMergeSumstatBundles(harmonized$pairs[qtlKeys]) - # The separate-GWAS runs are FOCAL: each is one GWAS tested against the - # whole QTL side, so each needs its own bundle of (every QTL pair + that - # one GWAS). Built the same way and for the same reason as the xQTL - # bundle above -- the deduplicated LD list and dict_sumstatLD have to - # match the subset, which subsetting the merged bundle would not give. - # Without this the separate loop ran over EVERY merged label and treated - # each QTL study as a focal GWAS in its own right. - gwasKeys <- setdiff(names(harmonized$pairs), qtlKeys) - gwasRunBundles <- set_names( - map( - gwasKeys, - .cbGwasRunBundle, - pairs = harmonized$pairs, - qtlKeys = qtlKeys - ), - gwasKeys - ) + gwasRunBundles <- .cbGwasRunBundles(harmonized$pairs, qtlKeys) .cbRunVariants( harmonized$individualBundle, sumstatBundle, @@ -1588,12 +1634,28 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { separateGwas, focalTrait, methodArgs, - qtlLdSketch = qtlLdSketch, + qtlLdReference = qtlLdReference, qtlSumstatBundle = qtlSumstatBundle, gwasRunBundles = gwasRunBundles ) } +# The separate-GWAS run bundles, keyed by GWAS label. The runs are FOCAL: each +# is one GWAS tested against the whole QTL side, so each needs its own bundle +# of (every QTL pair + that one GWAS). Built through .cbMergeSumstatBundles +# for the same reason as the xQTL bundle in .cbDriver -- the deduplicated LD +# list and dict_sumstatLD have to match the subset, which subsetting the +# merged bundle would not give. Without this the separate loop ran over EVERY +# merged label and treated each QTL study as a focal GWAS in its own right. +# @noRd +.cbGwasRunBundles <- function(pairs, qtlKeys) { + gwasKeys <- setdiff(names(pairs), qtlKeys) + set_names( + map(gwasKeys, .cbGwasRunBundle, pairs = pairs, qtlKeys = qtlKeys), + gwasKeys + ) +} + # Append the GWAS sumstat pairs to the QTL pairs, QC-gating gwasSumStats and # make.unique-ing colliding labels. (Sequential key resolution -- kept as a # loop.) @@ -1601,15 +1663,15 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { .cbAppendGwasPairs <- function( qtlPairs, gwasSumStats, - qtlLdSketch, + qtlLdReference, cutoffs = NULL ) { if (is.null(gwasSumStats)) { return(qtlPairs) } .cbRequireSumStatsQc(gwasSumStats, "gwasSumStats") - if (!is.null(qtlLdSketch)) { - .cbRequireMatchingLdSketches(qtlLdSketch, ldSketch(gwasSumStats)) + if (!is.null(qtlLdReference)) { + .cbRequireMatchingLdRefs(qtlLdReference, ldReference(gwasSumStats)) } gwasPairs <- .cbGwasSumStatsBundle(gwasSumStats, cutoffs = cutoffs) if (length(gwasPairs) == 0L) { @@ -1647,12 +1709,12 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { separateGwas, samples, panelFilterParam, - signalScreenArgs, + signalScreenParam, alleleFlip, methodArgs, - residualizationArgs + residualizationParam ) { - screenSpec <- .screenResolve(signalScreenArgs) + screenSpec <- .screenResolve(signalScreenParam) indBundle <- .cbIndividualBundle( qtlData, contexts = contexts, @@ -1661,7 +1723,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { cisWindow = cisWindow, samples = samples, pipCutoffToSkip = screenSpec, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ) .cbDriver( indBundle, @@ -1698,9 +1760,9 @@ setMethod( separateGwas = FALSE, samples = NULL, panelFilterParam = PanelFilterParam(), - signalScreenArgs = SignalScreenParam(), + signalScreenParam = SignalScreenParam(), alleleFlip = TRUE, - residualizationArgs = ResidualizationParam(), + residualizationParam = ResidualizationParam(), # `list()`, not ColocboostOptions(): the formal shadows the # constructor, so a constructor-call default is a recursive # reference. An empty list is the "no options" spelling @@ -1722,10 +1784,10 @@ setMethod( separateGwas = separateGwas, samples = samples, panelFilterParam = panelFilterParam, - signalScreenArgs = signalScreenArgs, + signalScreenParam = signalScreenParam, alleleFlip = alleleFlip, methodArgs = methodArgs, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ) } ) @@ -1767,7 +1829,7 @@ setMethod( separateGwas = separateGwas, focalTrait = focalTrait, methodArgs = methodArgs, - qtlLdSketch = ldSketch(qtlData), + qtlLdReference = ldReference(qtlData), alleleFlip = alleleFlip, cutoffs = cutoffs ) @@ -1792,9 +1854,9 @@ setMethod( separateGwas = FALSE, samples = NULL, panelFilterParam = PanelFilterParam(), - signalScreenArgs = SignalScreenParam(), + signalScreenParam = SignalScreenParam(), alleleFlip = TRUE, - residualizationArgs = ResidualizationParam(), + residualizationParam = ResidualizationParam(), # `list()`, not ColocboostOptions(): the formal shadows the # constructor, so a constructor-call default is a recursive # reference. An empty list is the "no options" spelling @@ -1816,10 +1878,10 @@ setMethod( separateGwas = separateGwas, samples = samples, panelFilterParam = panelFilterParam, - signalScreenArgs = signalScreenArgs, + signalScreenParam = signalScreenParam, alleleFlip = alleleFlip, methodArgs = methodArgs, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ) } ) @@ -1840,12 +1902,12 @@ setMethod( separateGwas, samples, panelFilterParam, - signalScreenArgs, + signalScreenParam, alleleFlip, methodArgs, - residualizationArgs + residualizationParam ) { - screenSpec <- .screenResolve(signalScreenArgs) + screenSpec <- .screenResolve(signalScreenParam) indBundle <- .cbMultiStudyIndBundle( qtlData = qtlData, contexts = contexts, @@ -1854,7 +1916,7 @@ setMethod( cisWindow = cisWindow, samples = samples, screenSpec = screenSpec, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ) cutoffs <- .panelCutoffs(panelFilterParam) ss <- .cbMultiStudySumstats( @@ -1872,17 +1934,12 @@ setMethod( separateGwas, focalTrait, methodArgs, - qtlLdSketch = ss$qtlLdSketch, + qtlLdReference = ss$qtlLdReference, alleleFlip = alleleFlip, cutoffs = cutoffs ) } -# Aggregate the individual-level bundles across all QtlDataset members. Per- -# study trait names are prefixed with "{study}:" so colocboost sees distinct -# outcomes when two studies share a trait. Returns the combined bundle or NULL. -# (Sequential offset-shifted merge -- kept as a loop.) -# @noRd # One study's bundle with its names study-prefixed, or NULL when it has # nothing to contribute. # @noRd @@ -1895,7 +1952,7 @@ setMethod( cisWindow, samples, screenSpec, - residualizationArgs = ResidualizationParam() + residualizationParam = ResidualizationParam() ) { sub <- .cbIndividualBundle( qtlDatasets[[studyName]], @@ -1905,7 +1962,7 @@ setMethod( cisWindow = cisWindow, samples = samples, pipCutoffToSkip = screenSpec, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ) if (is.null(sub)) { return(NULL) @@ -1931,6 +1988,12 @@ setMethod( cbind(Y = d[, "Y"] + yOffsets[[i]], X = d[, "X"] + xOffsets[[i]]) } +# The individual-level bundle across every study of a MultiStudyQtlDataset. +# Each study's dict indexes its own X and Y, so it shifts by however many +# entries the studies before it contributed -- a cumulative count, known once +# all the bundles are in hand rather than tracked while looping. +# NULL when no study has anything to contribute. +# @noRd .cbMultiStudyIndBundle <- function( qtlData, contexts, @@ -1939,7 +2002,7 @@ setMethod( cisWindow, samples, screenSpec, - residualizationArgs = ResidualizationParam() + residualizationParam = ResidualizationParam() ) { qtlDatasets <- qtlDatasets(qtlData) subs <- compact(map( @@ -1952,14 +2015,11 @@ setMethod( cisWindow = cisWindow, samples = samples, screenSpec = screenSpec, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam )) if (length(subs) == 0L) { return(NULL) } - # Each study's dict indexes its own X and Y, so it shifts by however many - # entries the studies before it contributed -- a cumulative count, known - # once all the bundles are in hand rather than tracked while looping. xOffsets <- .cbOffsets(map_int(subs, .cbFieldLength, field = "X")) yOffsets <- .cbOffsets(map_int(subs, .cbFieldLength, field = "Y")) combinedX <- .cbConcat(map(subs, "X")) @@ -1985,7 +2045,8 @@ setMethod( } # Prefix a study's X names + outcome names with "{study}:" (Y names track the -# outcome names). +# outcome names), so colocboost sees distinct outcomes when two studies share +# a trait. # @noRd .cbPrefixStudyNames <- function(sub, studyName) { outcomeNames <- str_c(studyName, sub$outcomeNames, sep = ":") @@ -2014,7 +2075,7 @@ setMethod( } # Sumstat side of a MultiStudyQtlDataset: bundle any embedded QtlSumStats. -# Returns list(qtlPairs, qtlLdSketch). +# Returns list(qtlPairs, qtlLdReference). # @noRd .cbMultiStudySumstats <- function( qtlData, @@ -2024,7 +2085,7 @@ setMethod( ) { embeddedSs <- sumStats(qtlData) if (is.null(embeddedSs)) { - return(list(qtlPairs = list(), qtlLdSketch = NULL)) + return(list(qtlPairs = list(), qtlLdReference = NULL)) } .cbRequireSumStatsQc(embeddedSs, "MultiStudyQtlDataset@sumStats") list( @@ -2034,18 +2095,12 @@ setMethod( traitId = traitId, cutoffs = cutoffs ), - qtlLdSketch = ldSketch(embeddedSs) + qtlLdReference = ldReference(embeddedSs) ) } # ---- map/apply helpers (lambda-free callbacks) --------------------------- -# TRUE when a matrix is non-square (a samples x variants genotype reference). -# @noRd -.cbIsNonSquare <- function(m) { - nrow(m) != ncol(m) -} - # Single-effect screen decision for outcome column `j` (drop on failure). # @noRd .cbScreenOutcome <- function(j, X, Y, spec) { diff --git a/R/cpp11.R b/R/cpp11.R index 725ad5d98..141781dea 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -1,25 +1,61 @@ # Generated by cpp11: do not edit by hand +bgenDosageCpp <- function(data, nSamples, alleles) { + .Call(`_pecotmr_bgenDosageCpp`, data, nSamples, alleles) +} + +bgenSampleIdsCpp <- function(ids, nSamples) { + .Call(`_pecotmr_bgenSampleIdsCpp`, ids, nSamples) +} + dentistIterativeImpute <- function(ldMatR, nSample, zScoreR, pValueThreshold, propSVD, gcControl, nIter, gPvalueThreshold, numThreads, correctChenEtAlBug, verbose, seed) { .Call(`_pecotmr_dentistIterativeImpute`, ldMatR, nSample, zScoreR, pValueThreshold, propSVD, gcControl, nIter, gPvalueThreshold, numThreads, correctChenEtAlBug, verbose, seed) } -lassosumRssRcpp <- function(zR, LD, lambdaR, thr, maxiter) { - .Call(`_pecotmr_lassosumRssRcpp`, zR, LD, lambdaR, thr, maxiter) +dentistIterativeImputeFactor <- function(factorR, nSample, zScoreR, pValueThreshold, propSVD, gcControl, nIter, gPvalueThreshold, numThreads, correctChenEtAlBug, verbose, seed) { + .Call(`_pecotmr_dentistIterativeImputeFactor`, factorR, nSample, zScoreR, pValueThreshold, propSVD, gcControl, nIter, gPvalueThreshold, numThreads, correctChenEtAlBug, verbose, seed) +} + +lassosumRssCpp <- function(zR, LD, shrink, lambdaR, thr, maxiter) { + .Call(`_pecotmr_lassosumRssCpp`, zR, LD, shrink, lambdaR, thr, maxiter) +} + +lassosumRssFactorCpp <- function(zR, factorR, shrink, lambdaR, thr, maxiter) { + .Call(`_pecotmr_lassosumRssFactorCpp`, zR, factorR, shrink, lambdaR, thr, maxiter) +} + +ldThresholdComponents <- function(standardized, threshold, stripe) { + .Call(`_pecotmr_ldThresholdComponents`, standardized, threshold, stripe) +} + +penalizedRssCpp <- function(zR, LD, shrink, lambdaR, penaltyStr, gamma, alpha, lambda0, lambda2, thr, maxiter, maxSwaps) { + .Call(`_pecotmr_penalizedRssCpp`, zR, LD, shrink, lambdaR, penaltyStr, gamma, alpha, lambda0, lambda2, thr, maxiter, maxSwaps) +} + +penalizedRssFactorCpp <- function(zR, factorR, shrink, lambdaR, penaltyStr, gamma, alpha, lambda0, lambda2, thr, maxiter, maxSwaps) { + .Call(`_pecotmr_penalizedRssFactorCpp`, zR, factorR, shrink, lambdaR, penaltyStr, gamma, alpha, lambda0, lambda2, thr, maxiter, maxSwaps) +} + +prsCsCpp <- function(a, b, phi, bhat, maf, n, ldBlk, nIter, nBurnin, thin, verbose, seed) { + .Call(`_pecotmr_prsCsCpp`, a, b, phi, bhat, maf, n, ldBlk, nIter, nBurnin, thin, verbose, seed) +} + +prsCsFactorCpp <- function(a, b, phi, bhat, maf, n, factorR, nIter, nBurnin, thin, verbose, seed) { + .Call(`_pecotmr_prsCsFactorCpp`, a, b, phi, bhat, maf, n, factorR, nIter, nBurnin, thin, verbose, seed) } -penalizedRssRcpp <- function(zR, LD, lambdaR, penaltyStr, gamma, alpha, lambda0, lambda2, thr, maxiter, maxSwaps) { - .Call(`_pecotmr_penalizedRssRcpp`, zR, LD, lambdaR, penaltyStr, gamma, alpha, lambda0, lambda2, thr, maxiter, maxSwaps) +qtlEnrichmentCpp <- function(rGwasPip, rQtlSusieFit, piGwas, piQtl, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, seed) { + .Call(`_pecotmr_qtlEnrichmentCpp`, rGwasPip, rQtlSusieFit, piGwas, piQtl, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, seed) } -prsCsRcpp <- function(a, b, phi, bhat, maf, n, ldBlk, nIter, nBurnin, thin, verbose, seed) { - .Call(`_pecotmr_prsCsRcpp`, a, b, phi, bhat, maf, n, ldBlk, nIter, nBurnin, thin, verbose, seed) +sdprCpp <- function(bhatR, LD, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed) { + .Call(`_pecotmr_sdprCpp`, bhatR, LD, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed) } -qtlEnrichmentRcpp <- function(rGwasPip, rQtlSusieFit, piGwas, piQtl, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, seed) { - .Call(`_pecotmr_qtlEnrichmentRcpp`, rGwasPip, rQtlSusieFit, piGwas, piQtl, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, seed) +sdprFactorCpp <- function(bhatR, factorR, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed) { + .Call(`_pecotmr_sdprFactorCpp`, bhatR, factorR, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed) } -sdprRcpp <- function(bhatR, LD, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed) { - .Call(`_pecotmr_sdprRcpp`, bhatR, LD, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed) +vcfGtDosageCpp <- function(gt, alleles) { + .Call(`_pecotmr_vcfGtDosageCpp`, gt, alleles) } diff --git a/R/crossValidation.R b/R/crossValidation.R index 90b0384a6..b3d5f356f 100644 --- a/R/crossValidation.R +++ b/R/crossValidation.R @@ -347,17 +347,15 @@ NULL samplePartitions } -# @noRd # multicoreWorkers() rather than bpworkers(MulticoreParam()): the two answer # the same number, but constructing a MulticoreParam costs ~0.6s (almost all # of it garbage collection) and this runs on every fit. +# @noRd .cvNumCores <- function(numThreads) { avail <- multicoreWorkers() min(if (numThreads == -1) avail else numThreads, avail) } -# Run each fold (parallel via BiocParallel when >= 2 cores). -# @noRd # MulticoreParam for CV / weight-fitting parallelism. A NULL seed keeps the # historical default RNGseed = 1L (reproducible); a caller-supplied seed # overrides it so the parallel L'Ecuyer streams are reproducible under it. This @@ -383,6 +381,8 @@ NULL } } +# Run each fold (parallel via BiocParallel when >= 2 cores). +# @noRd .cvRunFolds <- function(foldIds, cvState, numCores) { if (numCores >= 2) { return(bplapply( @@ -528,19 +528,43 @@ setClass( numThreads = "numeric", samplePartition = "list_OR_NULL", maxVariants = "numeric_OR_NULL", - weightMethods = "list_OR_NULL" + weightMethods = "list_OR_NULL", + fitFullData = "logical" ) ) +setValidity("CrossValidationParam", function(object) { + problems <- .cvFitFullDataProblem(object@fitFullData, object@folds) + if (length(problems) == 0L) TRUE else problems +}) + +# `fitFullData = FALSE` asks for cross-validation results alone, which is only +# a request for something when cross-validation runs: without folds there +# would be no fit of any kind. Checked here, at construction, rather than +# separately by each pipeline that reads it. +# @noRd +.cvFitFullDataProblem <- function(fitFullData, folds) { + if (length(fitFullData) != 1L || is.na(fitFullData)) { + return("`fitFullData` must be a single TRUE or FALSE.") + } + if (!fitFullData && !.cvEnabled(list(folds = folds))) { + return(str_c( + "fitFullData = FALSE requires cross-validation (folds >= 2): ", + "without folds there would be no fit at all." + )) + } + NULL +} + #' @title Cross-Validation Settings #' @description How cross-validation runs, shared by #' \code{\link{fineMappingPipeline}} and \code{\link{twasWeightsPipeline}}. #' -#' \code{folds}, \code{numThreads} and \code{samplePartition} mean the same -#' thing in both. \code{maxVariants} and \code{weightMethods} are honoured -#' by \code{\link{twasWeightsPipeline}} only and are \strong{ignored} by -#' \code{\link{fineMappingPipeline}}, so one bundle can be handed to -#' either pipeline unchanged. +#' \code{folds}, \code{numThreads}, \code{samplePartition} and +#' \code{fitFullData} mean the same thing in both. \code{maxVariants} and +#' \code{weightMethods} are honoured by \code{\link{twasWeightsPipeline}} +#' only and are \strong{ignored} by \code{\link{fineMappingPipeline}}, so +#' one bundle can be handed to either pipeline unchanged. #' @param folds Integer. Number of folds; \code{0} (the default) or #' \code{1} skips cross-validation. The same value in both pipelines --- #' \code{twasWeightsPipeline} used to default to \code{5}, which made an @@ -561,16 +585,24 @@ setClass( #' \strong{\code{twasWeightsPipeline} only} --- #' \code{fineMappingPipeline} ignores it, because its \code{methods=} are #' fine-mapping methods and its CV refits all of them. +#' @param fitFullData Logical. \code{TRUE} (default) fits the final model on +#' the full data as well as cross-validating it; \code{FALSE} keeps only +#' the cross-validation results, and requires \code{folds >= 2}. A row +#' from such a run carries its \code{cvResult} and nothing else, so it +#' cannot be exported and cannot supply full-data weights or fits +#' downstream. #' @return A \code{CrossValidationParam} object, a \code{\link{MethodParam}}. #' @examples #' CrossValidationParam(folds = 10, numThreads = 4) +#' CrossValidationParam(folds = 5, fitFullData = FALSE) #' @export CrossValidationParam <- function( folds = 0, numThreads = 1, samplePartition = NULL, maxVariants = NULL, - weightMethods = NULL + weightMethods = NULL, + fitFullData = TRUE ) { new( "CrossValidationParam", @@ -578,22 +610,24 @@ CrossValidationParam <- function( numThreads = numThreads, samplePartition = samplePartition, maxVariants = maxVariants, - weightMethods = weightMethods + weightMethods = weightMethods, + fitFullData = fitFullData ) } # The fields a pipeline reads, as a plain list so call sites index it without # caring that the caller passed a constructor result. # @noRd -.cvResolve <- function(crossValidationArgs) { +.cvResolve <- function(crossValidationParam) { list( - folds = crossValidationArgs$folds %||% 0, - numThreads = crossValidationArgs$numThreads %||% 1, - samplePartition = crossValidationArgs$samplePartition, + folds = crossValidationParam$folds %||% 0, + numThreads = crossValidationParam$numThreads %||% 1, + samplePartition = crossValidationParam$samplePartition, # -1 is twasWeightsCv()'s "no cap" sentinel. fineMappingPipeline # resolves these two as well but never reads them. - maxVariants = crossValidationArgs$maxVariants %||% -1, - weightMethods = crossValidationArgs$weightMethods + maxVariants = crossValidationParam$maxVariants %||% -1, + weightMethods = crossValidationParam$weightMethods, + fitFullData = crossValidationParam$fitFullData %||% TRUE ) } @@ -601,8 +635,8 @@ CrossValidationParam <- function( # and anything that needs out-of-fold predictions has to ask this rather than # testing `folds` itself. # @noRd -.cvEnabled <- function(crossValidationArgs) { - folds <- crossValidationArgs$folds %||% 0 +.cvEnabled <- function(crossValidationParam) { + folds <- crossValidationParam$folds %||% 0 !is.null(folds) && length(folds) == 1L && !is.na(folds) && folds >= 2L } @@ -611,9 +645,9 @@ CrossValidationParam <- function( # unimplemented but meaningless -- saying so beats running to completion and # returning results that were never cross-validated. # @noRd -.cvRefuseOnSumstats <- function(crossValidationArgs, pipeline, cls) { - set <- names(crossValidationArgs)[ - map_lgl(as.list(crossValidationArgs), .cvFieldIsSet) +.cvRefuseOnSumstats <- function(crossValidationParam, pipeline, cls) { + set <- names(crossValidationParam)[ + map_lgl(as.list(crossValidationParam), .cvFieldIsSet) ] if (length(set) == 0L) { return(invisible(NULL)) @@ -627,9 +661,10 @@ CrossValidationParam <- function( # A field counts as "set" when it differs from the constructor's own default, # so passing CrossValidationParam() unchanged is not mistaken for a request. +# fitFullData = TRUE is that field's default. # @noRd .cvFieldIsSet <- function(x) { - if (is.null(x)) { + if (is.null(x) || isTRUE(x)) { return(FALSE) } # numThreads = 1 and folds = 0 are the no-op defaults. @@ -648,10 +683,14 @@ CrossValidationParam <- function( # two pipelines disagreed on what an unspecified `cvFolds` meant; converging # on "off unless asked" makes one bundle mean one thing. The knock-on is that # the SR-TWAS ensemble, which needs out-of-fold predictions, no longer runs by -# default -- so `ensemble` defaults to FALSE too, and asking for an ensemble +# default -- so `EnsembleParam(enabled =)` defaults to FALSE too, and asking +# for an ensemble # without folds is an error rather than a silently missing row. # -# Two of the five fields are honoured by twasWeightsPipeline() only, and are +# `fitFullData` means the same thing in both pipelines: keep only the +# cross-validation results, skipping the full-data fit. +# +# Two of the six fields are honoured by twasWeightsPipeline() only, and are # IGNORED rather than rejected by fineMappingPipeline() -- one bundle the # caller can hand to either pipeline without rewriting it: # diff --git a/R/ctwasPipeline.R b/R/ctwasPipeline.R index f4b0599e6..aa02011ab 100644 --- a/R/ctwasPipeline.R +++ b/R/ctwasPipeline.R @@ -158,21 +158,19 @@ BoundaryMergeParam <- function( # in the messages are the pipeline's own, which drop the `Args` suffix. # @noRd .ctwasAssertBundles <- function( - ctwasPriorArgs, - variantPruningArgs, - boundaryMergeArgs, + ctwasPriorParam, + variantPruningParam, + boundaryMergeParam, methodArgs ) { - .assertMethodParam(ctwasPriorArgs, "CtwasPriorParam", "ctwasPrior") + .assertMethodParam(ctwasPriorParam, "CtwasPriorParam") .assertMethodParam( - variantPruningArgs, - "VariantPruningParam", - "variantPruning" + variantPruningParam, + "VariantPruningParam" ) .assertMethodParam( - boundaryMergeArgs, - "BoundaryMergeParam", - "boundaryMerge" + boundaryMergeParam, + "BoundaryMergeParam" ) .assertMethodOptions(methodArgs, "CtwasOptions", "methodArgs") } @@ -180,7 +178,7 @@ BoundaryMergeParam <- function( #' @title Causal TWAS Pipeline (cTWAS, multi LD block) #' @description Pipeline that hands a per-block set of #' \code{\link{GwasSumStats}} of GWAS Z-scores together with the matching -#' per-block per-gene TWAS weights and LD sketches to +#' per-block per-gene TWAS weights and LD references to #' \code{ctwas::ctwas_sumstats}, producing per-gene posterior inclusion #' probabilities for causal genes. Optionally accepts a precomputed TWAS-Z #' \code{GRanges} from \code{\link{causalInferencePipeline}} as the @@ -191,18 +189,28 @@ BoundaryMergeParam <- function( #' \code{blockId} column -- build it with #' \code{loadGwasSumStatsFromManifest(..., ldBlocks = )}. Per-block #' \code{region_info}, \code{LD_map}, and \code{snp_map} entries are built -#' automatically from the LD sketch and concatenated before the call to +#' automatically from the LD reference and concatenated before the call to #' \code{ctwas::ctwas_sumstats}. A single-block input is rejected: cTWAS's EM #' cannot converge on a single region, so callers must supply at least two #' blocks. #' -#' @section LD-sketch compatibility check: Per block: -#' \code{ldSketch(twasWeights)} (when non-NULL) must come from the same -#' reference panel as \code{ldSketch(gwasSumStats)} --- same samples, same -#' allele orientation on the shared variants. The two need NOT carry the same -#' variants; a partial overlap, which is what QC-ing the two sides separately -#' produces, only warns. A different sample set, a swapped A1/A2 on a shared -#' variant, or no shared variant at all is a hard error. +#' @section cTWAS's log: cTWAS narrates each of its steps through the +#' \code{logging} package, which writes to the console with \code{cat()}, +#' out of reach of \code{suppressMessages()}. The pipeline keeps that +#' narration off the console, cTWAS's warnings excepted. To keep the full +#' log, give a step a log file through its options, e.g. +#' \code{CtwasEstParamOptions(logfile = "est_param.log")}. +#' +#' @section LD reference compatibility check: Per block: +#' \code{ldReference(twasWeights)} (when non-NULL) must be the same LD +#' reference as \code{ldReference(gwasSumStats)}. +#' The two must be the same kind of reference. Two genotype panels must +#' share their samples and allele orientation; two \code{LdMatrix} objects +#' must agree on the LD they share; two \code{GenotypeMixture} objects must +#' average the same panels with the same weights. The two need NOT carry the +#' same variants; a partial overlap, which is what QC-ing the two sides +#' separately produces, only warns. A mismatch of any of those, or no shared +#' variant at all, is a hard error. #' #' @param gwasSumStats A \code{\link{GwasSumStats}} whose elements are LD #' blocks (at least two), keyed by its \code{blockId} column, with @@ -242,17 +250,18 @@ BoundaryMergeParam <- function( #' fine-mapping. Default \code{5}. Pass-through to #' \code{ctwas::ctwas_sumstats}. #' @param numThreads Number of cores. Default \code{1}. -#' @param ctwasPriorArgs The EM stage that estimates cTWAS's group priors, built -#' with \code{\link{CtwasPriorParam}}: \code{thin}, \code{niterPrefit}, -#' \code{niter}, \code{varStructure} and \code{fallbackToPrefit}. Handed -#' whole to \code{\link{estCtwasGroupPriors}}. -#' @param variantPruningArgs Which variants survive into each gene's weight +#' @param ctwasPriorParam The EM stage that estimates cTWAS's group priors, +#' built with \code{\link{CtwasPriorParam}}: \code{thin}, +#' \code{niterPrefit}, \code{niter}, \code{varStructure} and +#' \code{fallbackToPrefit}. Handed whole to +#' \code{\link{estCtwasGroupPriors}}. +#' @param variantPruningParam Which variants survive into each gene's weight #' matrix, built with \code{\link{VariantPruningParam}}: #' \code{weightCutoff}, \code{csMinCor}, \code{pipRescue} and #' \code{maxVariants}. Handed whole to #' \code{\link{assembleCtwasInputs}}. The \code{csMinCor} / #' \code{pipRescue} rescues need a \code{fineMappingResult}. -#' @param boundaryMergeArgs Whether a high-PIP gene straddling an LD-block +#' @param boundaryMergeParam Whether a high-PIP gene straddling an LD-block #' boundary has its regions merged and re-fine-mapped, built with #' \code{\link{BoundaryMergeParam}}: \code{enabled} (default #' \code{FALSE}), \code{pipThreshold}, \code{filterCs} and @@ -291,12 +300,13 @@ BoundaryMergeParam <- function( #' IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000)), #' blockId = c("chr22_1", "chr22_2")) #' gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", -#' ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) +#' ldReference = ldStem, region = "chr22:10000000-19000000", +#' ldBlocks = blocks) #' gwasByRegion <- summaryStatsQc(gss, #' panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) #' ctwasPipeline(gwasSumStats = gwasByRegion, #' twasWeights = list(ctwasWeightsExample), -#' ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, +#' ctwasPriorParam = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, #' fallbackToPrefit = TRUE), #' methodArgs = CtwasOptions( #' regionData = CtwasRegionDataOptions(min_group_size = 1), @@ -313,16 +323,16 @@ ctwasPipeline <- function( method = NULL, maxNumSingleEffects = 5L, numThreads = 1L, - ctwasPriorArgs = CtwasPriorParam(), - variantPruningArgs = VariantPruningParam(), - boundaryMergeArgs = BoundaryMergeParam(), + ctwasPriorParam = CtwasPriorParam(), + variantPruningParam = VariantPruningParam(), + boundaryMergeParam = BoundaryMergeParam(), keepSnps = FALSE, methodArgs = CtwasOptions() ) { .ctwasAssertBundles( - ctwasPriorArgs, - variantPruningArgs, - boundaryMergeArgs, + ctwasPriorParam, + variantPruningParam, + boundaryMergeParam, methodArgs ) .ctwasRequireNamedLists(gwasSumStats, twasWeights) @@ -335,11 +345,11 @@ ctwasPipeline <- function( twasWeights = twasWeights, twasZ = twasZ, fineMappingResult = fineMappingResult, - variantPruningArgs = variantPruningArgs, - ctwasPriorArgs = ctwasPriorArgs, + variantPruningParam = variantPruningParam, + ctwasPriorParam = ctwasPriorParam, numThreads = numThreads, maxNumSingleEffects = maxNumSingleEffects, - boundaryMergeArgs = boundaryMergeArgs, + boundaryMergeParam = boundaryMergeParam, gwasStudy = gwasStudy, keepSnps = keepSnps, methodArgs = methodArgs @@ -362,15 +372,15 @@ ctwasPipeline <- function( # @noRd .ctwasRunStages <- function( inputs, - ctwasPriorArgs, - boundaryMergeArgs, + ctwasPriorParam, + boundaryMergeParam, maxNumSingleEffects, numThreads, methodArgs ) { est <- estCtwasGroupPriors( inputs, - ctwasPriorArgs = ctwasPriorArgs, + ctwasPriorParam = ctwasPriorParam, numThreads = numThreads, methodArgs = methodArgs ) @@ -385,12 +395,12 @@ ctwasPipeline <- function( numThreads = numThreads, methodArgs = methodArgs ) - if (!isTRUE(boundaryMergeArgs$enabled)) { + if (!isTRUE(boundaryMergeParam$enabled)) { return(finemap) } .ctwasMaybeMerge( finemap, - boundaryMergeArgs = boundaryMergeArgs, + boundaryMergeParam = boundaryMergeParam, maxNumSingleEffects = maxNumSingleEffects, numThreads = numThreads, methodArgs = methodArgs @@ -407,11 +417,11 @@ ctwasPipeline <- function( twasWeights, twasZ, fineMappingResult, - variantPruningArgs, - ctwasPriorArgs, + variantPruningParam, + ctwasPriorParam, numThreads, maxNumSingleEffects, - boundaryMergeArgs, + boundaryMergeParam, gwasStudy, keepSnps, methodArgs @@ -422,12 +432,12 @@ ctwasPipeline <- function( twasZ = twasZ, fineMappingResult = fineMappingResult, method = m, - variantPruningArgs = variantPruningArgs + variantPruningParam = variantPruningParam ) merged <- .ctwasRunStages( inputs, - ctwasPriorArgs = ctwasPriorArgs, - boundaryMergeArgs = boundaryMergeArgs, + ctwasPriorParam = ctwasPriorParam, + boundaryMergeParam = boundaryMergeParam, maxNumSingleEffects = maxNumSingleEffects, numThreads = numThreads, methodArgs = methodArgs @@ -445,15 +455,15 @@ ctwasPipeline <- function( # @noRd .ctwasMaybeMerge <- function( posteriors, - boundaryMergeArgs, + boundaryMergeParam, maxNumSingleEffects, numThreads, methodArgs ) { # The bundle's terminal; mergeCtwasBoundaryRegions() takes scalars. - mergePipThresh <- boundaryMergeArgs$pipThreshold - mergeFilterCs <- boundaryMergeArgs$filterCs - mergeMaxSNP <- boundaryMergeArgs$maxSnp + mergePipThresh <- boundaryMergeParam$pipThreshold + mergeFilterCs <- boundaryMergeParam$filterCs + mergeMaxSNP <- boundaryMergeParam$maxSnp # methodArgs stays a record all the way down: mergeCtwasBoundaryRegions # takes one, and c()-ing it into an argument list would append the S4 # object as a single element rather than splice its entries. @@ -499,7 +509,8 @@ ctwasPipeline <- function( #' IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000)), #' blockId = c("chr22_1", "chr22_2")) #' gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", -#' ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) +#' ldReference = ldStem, region = "chr22:10000000-19000000", +#' ldBlocks = blocks) #' gwasByRegion <- summaryStatsQc(gss, #' panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) #' assembleCtwasInputs(gwasSumStats = gwasByRegion, @@ -511,18 +522,17 @@ assembleCtwasInputs <- function( twasZ = NULL, fineMappingResult = NULL, method = NULL, - variantPruningArgs = VariantPruningParam() + variantPruningParam = VariantPruningParam() ) { .assertMethodParam( - variantPruningArgs, - "VariantPruningParam", - "variantPruning" + variantPruningParam, + "VariantPruningParam" ) # The bundle's terminal: .ctwasBuildWeights and below take scalars. - twasWeightCutoff <- variantPruningArgs$weightCutoff - csMinCor <- variantPruningArgs$csMinCor - minPipCutoff <- variantPruningArgs$pipRescue - maxNumVariants <- variantPruningArgs$maxVariants + twasWeightCutoff <- variantPruningParam$weightCutoff + csMinCor <- variantPruningParam$csMinCor + minPipCutoff <- variantPruningParam$pipRescue + maxNumVariants <- variantPruningParam$maxVariants .ctwasValidateGwasList(gwasSumStats) globalPanelInfo <- .ctwasGlobalPanelInfo(gwasSumStats) gwasSumStats <- .ctwasGwasByBlock(gwasSumStats) @@ -618,8 +628,8 @@ assembleCtwasInputs <- function( } # One single-element GwasSumStats per LD block, keyed by blockId -- the shape -# the two-pass assembly consumes. The collection's own ldSketch rides along on -# each subset, so per-region LD lookups are unchanged. +# the two-pass assembly consumes. The collection's own ldReference rides along +# on each subset, so per-region LD lookups are unchanged. # @noRd .ctwasGwasByBlock <- function(gwasSumStats) { set_names( @@ -629,7 +639,7 @@ assembleCtwasInputs <- function( } # One block's slice of the collection. `[` carries the collection-level -# ldSketch through verbatim, and combineGwasSumStats() deliberately UNIONS +# ldReference through verbatim, and combineGwasSumStats() deliberately UNIONS # the per-piece panels, so without narrowing here every block references the # whole chromosome and its LD panel would cover all of it (a # chr19-wide panel runs to ~155 GB). Narrowed to the block's own variants @@ -637,13 +647,13 @@ assembleCtwasInputs <- function( # @noRd .ctwasPickBlock <- function(i, x) { block <- x[i] - sketch <- ldSketch(block) + sketch <- ldReference(block) if (is.null(sketch)) { return(block) } methods::initialize( block, - ldSketch = .subsetSketchToIds(sketch, as.list(block)) + ldReference = .subsetLdRefToIds(sketch, as.list(block)) ) } @@ -722,13 +732,6 @@ assembleCtwasInputs <- function( } } -# First pass: cache LD panels + build z_snp / region_info / snp_map per region. -# We need the union of GWAS variant ids ACROSS all blocks before filtering each -# per-block TwasWeights (a gene's weight variants can straddle adjacent blocks). -# Returns list(ldPanelsByRegion, zSnpPieces, regionInfoPieces, snpMap, -# ldFileByRegion). -# @noRd -# One region's GWAS LD sketch, checked against the region's weights. # The ctwas-shaped snpInfo for the whole collection's panel, captured BEFORE # .ctwasGwasByBlock() narrows each block's sketch to its own variants. A # gene's cis SPAN has to cover every block it reaches or @@ -739,26 +742,27 @@ assembleCtwasInputs <- function( # that case with its own message, so this must not pre-empt it. # @noRd .ctwasGlobalPanelInfo <- function(gwasSumStats) { - sketch <- ldSketch(gwasSumStats) + sketch <- ldReference(gwasSumStats) if (is.null(sketch)) { return(NULL) } .ctwasSnpInfoForBlock(sketch) } +# One region's GWAS LD sketch, checked against the region's weights. # @noRd .ctwasRegionGwasLd <- function(rid, gwasSumStats, twasWeights) { - gwasLd <- ldSketch(gwasSumStats[[rid]]) + gwasLd <- ldReference(gwasSumStats[[rid]]) if (is.null(gwasLd)) { msg <- glue( "ctwasPipeline: GwasSumStats for region '{rid}' carries no ", - "ldSketch (ldSketch = NULL); cTWAS requires an LD reference." + "ldReference (ldReference = NULL); cTWAS requires an LD reference." ) abort(msg) } tw <- twasWeights[[rid]] if (!is.null(tw)) { - .ctwasRequireMatchingLdSketches(ldSketch(tw), gwasLd) + .ctwasRequireMatchingLdRefs(ldReference(tw), gwasLd) } gwasLd } @@ -935,7 +939,11 @@ assembleCtwasInputs <- function( ) list( z_snp = zSnp, - z_gene = if (!is.null(twasZ)) .ctwasBuildZGene(twasZ) else NULL, + z_gene = if (!is.null(twasZ)) { + .ctwasBuildZGene(twasZ) + } else { + .ctwasGeneZ(weightsList, zSnp) + }, weights = weightsList, region_info = regionInfo, snp_map = fp$snpMap, @@ -946,6 +954,11 @@ assembleCtwasInputs <- function( ) } +# estCtwasGroupPriors(): CtwasPriorParam is the bundle's terminal; the EM +# helpers take its fields as plain scalars. assemble_region_data does not echo +# z_gene back, so the precomputed z_gene passed in is propagated onto the +# result (inputs$z_gene is NULL when twasZ was not supplied) so $z_gene +# resolves to the right entry. #' Estimate cTWAS group prior + prior variance #' #' @description Step 2 of the three-step \code{\link{ctwasPipeline}}: assembles @@ -955,7 +968,7 @@ assembleCtwasInputs <- function( #' \code{boundary_genes}, \code{z_gene}, and \code{param}. #' #' @param inputs A list returned by \code{\link{assembleCtwasInputs}}. -#' @param ctwasPriorArgs The EM settings, built with +#' @param ctwasPriorParam The EM settings, built with #' \code{\link{CtwasPriorParam}}: \code{thin} (SNP thinning when #' assembling region data), \code{niterPrefit} and \code{niter} (prefit / #' accurate EM iterations), \code{varStructure}, and @@ -971,7 +984,7 @@ assembleCtwasInputs <- function( #' @examples #' data(ctwasInputsExample) #' estCtwasGroupPriors(ctwasInputsExample, -#' ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, +#' ctwasPriorParam = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, #' fallbackToPrefit = TRUE), #' methodArgs = CtwasOptions( #' regionData = CtwasRegionDataOptions(min_group_size = 1), @@ -982,17 +995,11 @@ assembleCtwasInputs <- function( #' @export estCtwasGroupPriors <- function( inputs, - ctwasPriorArgs = CtwasPriorParam(), + ctwasPriorParam = CtwasPriorParam(), numThreads = 1L, methodArgs = CtwasOptions() ) { - .assertMethodParam(ctwasPriorArgs, "CtwasPriorParam", "ctwasPrior") - # The bundle's terminal: the EM helpers below take plain scalars. - thin <- ctwasPriorArgs$thin - niterPrefit <- ctwasPriorArgs$niterPrefit - niter <- ctwasPriorArgs$niter - groupPriorVarStructure <- ctwasPriorArgs$varStructure - fallbackToPrefit <- ctwasPriorArgs$fallbackToPrefit + .assertMethodParam(ctwasPriorParam, "CtwasPriorParam") .assertMethodOptions(methodArgs, "CtwasOptions", "methodArgs") if (!requireNamespace("ctwas", quietly = TRUE)) { abort("Package 'ctwas' is required for estCtwasGroupPriors.") @@ -1003,7 +1010,7 @@ estCtwasGroupPriors <- function( regionData <- .ctwasAssembleRegionData( inputs, zGene, - thin, + ctwasPriorParam$thin, numThreads, methodArgs$regionData ) @@ -1014,17 +1021,14 @@ estCtwasGroupPriors <- function( ) paramRes <- .ctwasEstParamOrFallback( regionData, - niterPrefit, - niter, - groupPriorVarStructure, + ctwasPriorParam$niterPrefit, + ctwasPriorParam$niter, + ctwasPriorParam$varStructure, numThreads, - thin, - fallbackToPrefit, + ctwasPriorParam$thin, + ctwasPriorParam$fallbackToPrefit, methodArgs$estParam ) - # assemble_region_data does not echo z_gene back, so propagate the - # precomputed z_gene we passed in (inputs$z_gene is NULL when twasZ was not - # supplied) so $z_gene resolves to the right entry. c( list_assign(inputs, z_gene = zGene), list( @@ -1121,13 +1125,14 @@ estCtwasGroupPriors <- function( #' IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000)), #' blockId = c("chr22_1", "chr22_2")) #' gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", -#' ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) +#' ldReference = ldStem, region = "chr22:10000000-19000000", +#' ldBlocks = blocks) #' gwasByRegion <- summaryStatsQc(gss, #' panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) #' inp <- assembleCtwasInputs(gwasSumStats = gwasByRegion, #' twasWeights = list(ctwasWeightsExample)) #' est <- estCtwasGroupPriors(inp, -#' ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, +#' ctwasPriorParam = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, #' fallbackToPrefit = TRUE), #' methodArgs = CtwasOptions( #' regionData = CtwasRegionDataOptions(min_group_size = 1), @@ -1257,7 +1262,7 @@ mergeCtwasBoundaryRegions <- function( # as a positional argument. user <- as.list(methodArgs$merge) callArgs <- c(fa$args, user[setdiff(names(user), names(fa$args))]) - res <- exec(fa$fn, !!!callArgs) + res <- .ctwasQuietly(fa$fn, callArgs) .ctwasApplyMergeResult(finemapResult, res) } @@ -1323,15 +1328,10 @@ mergeCtwasBoundaryRegions <- function( # meant for a sibling step doesn't crash this one -- and so args # that fn would otherwise forward via its own `...` (e.g. into # susie_rss) don't bleed into incompatible downstream functions. - formalsFn <- try_fetch(names(formals(fn)), error = function(cnd) NULL) - usable <- if (is.null(formalsFn)) { - deduped - } else { - deduped[intersect(names(deduped), setdiff(formalsFn, "..."))] - } - args <- c(args, usable) + accepted <- setdiff(names(formals(fn)), "...") + args <- c(args, deduped[intersect(names(deduped), accepted)]) } - exec(fn, !!!args) + .ctwasQuietly(fn, args) } # Run ONLY ctwas's prefit EM step against `region_data` and return a @@ -1365,18 +1365,13 @@ mergeCtwasBoundaryRegions <- function( ) prefit <- .ctwasInvoke(fitEm, fitArgs, extra) adj <- .ctwasApplyThin(prefit$group_prior, prefit$group_size, thin) - groupSize <- if (length(adj$groupPrior) > 0L) { - adj$groupSize[names(adj$groupPrior)] - } else { - adj$groupSize - } list( group_prior = adj$groupPrior, group_prior_var = prefit$group_prior_var, group_prior_iters = prefit$group_prior_iters, group_prior_var_iters = prefit$group_prior_var_iters, group_prior_var_structure = groupPriorVarStructure, - group_size = groupSize, + group_size = adj$groupSize[names(adj$groupPrior)], p_single_effect = data.frame( region_id = names(region_data), p_single_effect = NA_real_, @@ -1422,12 +1417,9 @@ mergeCtwasBoundaryRegions <- function( } # Scale the "SNP" entry of a per-group vector, leaving the molecular groups -# alone. A vector without a SNP group passes through unchanged. +# alone. fit_EM always reports a SNP group. # @noRd .ctwasScaleSnpGroup <- function(groups, factor) { - if (!is_in("SNP", names(groups))) { - return(groups) - } replace(groups, "SNP", groups[["SNP"]] * factor) } @@ -1436,9 +1428,9 @@ mergeCtwasBoundaryRegions <- function( # ============================================================================= # LD-sketch compatibility check. Thin wrapper over the shared -# `.requireMatchingLdSketches` helper (R/ld.R). -.ctwasRequireMatchingLdSketches <- function(twLd, gwasLd) { - .requireMatchingLdSketches(twLd, gwasLd, pipelineName = "ctwasPipeline") +# `.requireMatchingLdRefs` helper (R/ld.R). +.ctwasRequireMatchingLdRefs <- function(twLd, gwasLd) { + .requireMatchingLdRefs(twLd, gwasLd, pipelineName = "ctwasPipeline") } # Resolve which TWAS method's weights to feed into ctwas given a @@ -1564,16 +1556,6 @@ mergeCtwasBoundaryRegions <- function( abort(msg) } -# Parse cTWAS block-manifest keys ("chr1_1000_2000" / "chr1:1000-2000") into a -# per-key GRanges. -# -# This is cTWAS's OWN `region_id` concept, not pecotmr's: cTWAS keys its -# region_info, snp_map and per-region data by these strings, so the package has -# to be able to read them even though pecotmr's own collections now key on the -# element range instead (section 4.4). A key that carries no coordinates -# becomes a 0-width chrUn sentinel, which matches no anchor and so yields the -# documented "NA when the anchor falls in no block". -# @noRd # One block id parsed into chrom/start/end, or the unplaced sentinel when it # does not parse as a range. # @noRd @@ -1596,6 +1578,16 @@ mergeCtwasBoundaryRegions <- function( ) } +# Parse cTWAS block-manifest keys ("chr1_1000_2000" / "chr1:1000-2000") into a +# per-key GRanges. +# +# This is cTWAS's OWN `region_id` concept, not pecotmr's: cTWAS keys its +# region_info, snp_map and per-region data by these strings, so the package has +# to be able to read them even though pecotmr's own collections now key on the +# element range instead (section 4.4). A key that carries no coordinates +# becomes a 0-width chrUn sentinel, which matches no anchor and so yields the +# documented "NA when the anchor falls in no block". +# @noRd .ctwasBlockGrFromIds <- function(ids) { coords <- map(ids, .ctwasBlockCoords) GenomicRanges::GRanges( @@ -1675,16 +1667,12 @@ mergeCtwasBoundaryRegions <- function( length(g) == 0L } -# Bucket a flat weight source into a per-region named list keyed to the block -# grid, homing each gene by start(region). Each per-block sub-collection carries -# that block's GWAS LD sketch (the panel its weights are harmonized against, and -# what the downstream match-check expects). -# @noRd # The genes homed into region `rid`, carrying that region's LD sketch, or # NULL when nothing landed there. `slot<-` applied as a function returns a # copy rather than writing into the subset in place. # @noRd #' @importFrom methods slot<- +# @noRd .ctwasBucketForRegion <- function(rid, combined, home, gwasSumStats) { idx <- which(home == rid) if (length(idx) == 0L) { @@ -1692,11 +1680,16 @@ mergeCtwasBoundaryRegions <- function( } `slot<-`( combined[idx, ], - "ldSketch", - value = ldSketch(gwasSumStats[[rid]]) + "ldReference", + value = ldReference(gwasSumStats[[rid]]) ) } +# Bucket a flat weight source into a per-region named list keyed to the block +# grid, homing each gene by start(region). Each per-block sub-collection carries +# that block's GWAS LD sketch (the panel its weights are harmonized against, and +# what the downstream match-check expects). +# @noRd .ctwasBucketWeights <- function(weights, gwasSumStats) { combined <- .ctwasCombineWeightSources(weights) # Placement anchors on the GENE's own position, not on a stored analysis @@ -2074,7 +2067,7 @@ mergeCtwasBoundaryRegions <- function( return(ri) } cols <- names(ri) - if (!all(c("chrom", "start", "stop") %in% cols)) { + if (!all(is_in(c("chrom", "start", "stop"), cols))) { return(ri) } gr <- GenomicRanges::GRanges( @@ -2315,14 +2308,9 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { } # Row subset carries every column forward (joint* / region / ...); the old # hand-listed rebuild silently dropped them. - methods::initialize(tw[keep, ], ldSketch = ldSketch(tw)) + methods::initialize(tw[keep, ], ldReference = ldReference(tw)) } -# Build the per-variant Z data.frame ctwas expects from a GwasSumStats. -# Stacks each study row's GRanges via the shared `.entryToSumstatDf` -# helper (R/sumstatsQc.R), then projects to ctwas's column shape and -# bolts on the `study` column ctwas uses to disambiguate stacked rows. -# @noRd # Match variant ids against the LD panel's ids the way every other LD consumer # in the package does -- by (chrom, pos, allele) with ref/alt swaps tolerated -- # rather than by exact string identity. @@ -2330,7 +2318,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # ctwas already harmonizes TWAS weights this way (see # `.ctwasHarmonizeWeights()` below). The GWAS side used plain string joins, so # one variant could be kept for the weights and dropped for the z-scores. -# `removeStrandAmbiguous = FALSE` matches `.ldFromSketchMatch()`, the shared +# `removeStrandAmbiguous = FALSE` matches `.ldFromRefMatch()`, the shared # entry point: the panel defines the frame, so an A/T variant is not discarded # merely for being palindromic. # @noRd @@ -2390,6 +2378,11 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) } +# Build the per-variant Z data.frame ctwas expects from a GwasSumStats. +# Stacks each study row's GRanges via the shared `.entryToSumstatDf` +# helper (R/sumstatsQc.R), then projects to ctwas's column shape and +# bolts on the `study` column ctwas uses to disambiguate stacked rows. +# @noRd .ctwasBuildZSnp <- function(gwasSumStats, panelIds) { pieces <- map( seq_len(nrow(gwasSumStats)), @@ -2399,10 +2392,6 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { .ctwasHarmonizeZToPanel(bind_rows(pieces), panelIds) } -# Derive the single-row region_info from the LD sketch's snpInfo -# (min/max BP per chromosome). The sketch is assumed to cover exactly -# one block. -# @noRd # @noRd .ctwasEntryPositions <- function(i, gss) { gr <- gss[[i]] @@ -2428,11 +2417,15 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { list_c(pieces) } +# The single-row region_info for block `regionId`: its chromosome and the +# [start, stop] span of the GWAS variants it holds. An empty block, or one +# spanning several chromosomes, is an error. +# @noRd .ctwasBuildSingleRegionInfo <- function(regionId, gss) { # Derive the block's [start, stop] from the GWAS variants actually in this # block (the GwasSumStats entry GRanges) -- NOT the LD sketch. When many # blocks share one whole-chromosome LD payload (the common one-file-per-chr - # layout), snpInfo(ldSketch) spans the entire chromosome, so every region + # layout), snpInfo(ldReference) spans the entire chromosome, so every region # would collapse to the same whole-chromosome [start, stop] and every SNP # would be assigned to every region (inflating SNP group_size N-fold and # diluting the gene prior to ~0). @@ -2476,9 +2469,9 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # supported by the downstream cTWAS model. # @noRd .ctwasSnpInfoForBlock <- function(gwasLd) { - gr <- .ldSketchRanges(gwasLd) + gr <- .ldRefRanges(gwasLd) mc <- S4Vectors::mcols(gr) - # `.ldSketchMatchIds()`, not the raw SNP label: this id becomes the R + # `.ldRefMatchIds()`, not the raw SNP label: this id becomes the R # dimnames, the `variance` names, `panelSnps` and the weight-harmonization # reference id all at once, and every one of those is compared against a # harmonized (reference-allele) id from the GWAS or the weights. A panel @@ -2489,8 +2482,8 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # (df[, "pos"] -> vector for region-bound min/max); a tibble column is a # 1-col list and errors min(). data.frame( - chrom = as.integer(.ldSketchChrom(gwasLd)), - id = .ldSketchMatchIds(gwasLd), + chrom = as.integer(.ldRefChrom(gwasLd)), + id = .ldRefMatchIds(gwasLd), pos = as.integer(GenomicRanges::start(gr)), alt = as.character(mc$A1), ref = as.character(mc$A2), @@ -2502,9 +2495,10 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # from so the expensive part can be built later. Returns a list with: # snpInfo : ctwas-shaped per-block table (chrom, id, pos, alt, ref) # -- both the snp_map element and the snpinfo loader return. -# variance : named numeric vector of per-variant dosage variance from the -# LD reference, used to scale non-standardized TWAS weights to -# the correlation scale ctwas expects. +# variance : named numeric vector of per-variant genotype variance from +# the LD reference (see .ldRefVariance()), used to scale +# non-standardized TWAS weights to the correlation scale ctwas +# expects. # sketch : the block's narrowed LD sketch, retained because the n x n # correlation is deliberately NOT built here. # @@ -2513,21 +2507,16 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # O(n^2) apiece on panels that are frequently never read at all. # @noRd .ctwasPanelFor <- function(gwasLd) { - # Share the validator with `.ldFromSketch()`, the entry point every other + # Share the validator with `.ldFromRef()`, the entry point every other # pipeline uses: skipping the guard meant a NULL or non-panel sketch # surfaced as "unable to find an inherited method for 'snpInfo'" # instead of saying the LD reference was missing. - .ldFromSketchValidate(gwasLd, "ctwasPipeline") + .ldFromRefValidate(gwasLd, "ctwasPipeline") snpInfo <- .ctwasSnpInfoForBlock(gwasLd) - geno <- .ldSketchDosage( - gwasLd, - seq_len(nrow(snpInfo)), - meanImpute = TRUE - ) list( snpInfo = snpInfo, variance = set_names( - apply(geno, 2, stats::var, na.rm = TRUE), + .ldRefVariance(gwasLd, seq_len(nrow(snpInfo))), snpInfo$id ), sketch = gwasLd @@ -2549,51 +2538,9 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) } -# The correlation over `vids` alone. Identical to slicing the full matrix -- -# mean imputation is per column, so correlating a subset of the dosages gives -# the same pairwise values -- at O(|vids|^2) instead of O(n^2). -# @noRd -.ctwasPanelLdSubset <- function(panel, vids) { - idx <- match(vids, panel$snpInfo$id) - if (anyNA(idx)) { - msg <- glue( - "ctwasPipeline: {sum(is.na(idx))} weight variant(s) absent from ", - "the block's LD panel." - ) - abort(msg) - } - if (!is.null(panel$R)) { - return(panel$R[vids, vids, drop = FALSE]) - } - .ctwasPanelLdFor(panel, idx, vids) -} - # @noRd .ctwasPanelLdFor <- function(panel, idx, ids) { - geno <- .ldSketchDosage(panel$sketch, idx, meanImpute = TRUE) - `dimnames<-`( - computeLd(geno, method = "sample"), - list(ids, ids) - ) -} - -# Whether to build the block's full correlation once and slice it per gene, -# or to compute one small correlation per gene. Per-gene submatrices are what -# keep a block ctwas never fine-maps from ever forming its n x n matrix, but -# g genes on |vids| variants each cost sum(|vids|^2) against n^2 for the -# whole block, so the full matrix wins once the weights are dense enough. -# Returns the full matrix in that case and NULL in the other. -# @noRd -.ctwasRWgtSource <- function(ldPanel, nVids) { - # Already built: slicing it is free, so there is nothing to weigh up. - if (!is.null(ldPanel$R)) { - return(ldPanel$R) - } - n <- as.numeric(nrow(ldPanel$snpInfo)) - if (length(nVids) == 0L || sum(as.numeric(nVids)^2) < n^2) { - return(NULL) - } - .ctwasPanelLd(ldPanel) + `dimnames<-`(.ldRefLdAt(panel$sketch, idx), list(ids, ids)) } # Harmonize TWAS weight variants against the LD reference panel. Same @@ -2729,10 +2676,12 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # Build the weights list ctwas expects: keyed by per-tuple gene id, # each element a list with wgt (variants x 1 matrix; rownames = SNP id), -# R_wgt (per-gene LD submatrix), and gene metadata. ctwas's compute_gene_z -# pulls rownames(wgt) for the SNP IDs and computes z.gene = crossprod(wgt, -# z.s) / sqrt(t(wgt) %*% R_wgt %*% wgt), so wgt must be a numeric matrix -# (not a vector) and R_wgt must be the LD submatrix over the same SNPs. +# wgt_var (the weight variance w'Rw), and gene metadata. ctwas's +# compute_gene_z would compute z.gene = crossprod(wgt, z.s) / +# sqrt(t(wgt) %*% R_wgt %*% wgt) from a per-gene LD submatrix R_wgt; the +# pipeline computes the same z from wgt_var instead (.ctwasGeneZ()) and +# supplies it, so wgt must still be a numeric matrix (not a vector) but no +# weight LD matrix is formed. # # The panel variants a gene's cis span may reach. # @@ -2770,10 +2719,9 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # table wherever the two overlap, so nothing about the in-block result # changes. # -# Genes are prepared in one sweep and given their `R_wgt` in a second, so -# that choice is made with every gene's fitted size in hand -- which is what -# lets a block no gene needs densely skip its n x n correlation entirely. -# .ctwasRWgtSource() picks, and says why. Variants absent from the panel are +# Genes are prepared in one sweep and given their weight variances in a +# second, so the block's LD is read once, over every gene's fitted variants +# together (.ctwasWeightVariances()). Variants absent from the panel are # dropped from that gene's row set. # @noRd .ctwasBuildWeights <- function( @@ -2812,12 +2760,10 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { twasWeights = twasWeights, ctx = ctx )) - fullR <- .ctwasRWgtSource(ldPanel, map_int(prepared, .ctwasPreparedSize)) - genes <- map( + genes <- map2( prepared, + .ctwasWeightVariances(ldPanel, prepared), .ctwasGeneEntryFor, - ldPanel = ldPanel, - fullR = fullR, spanInfo = spanInfo ) # Later genes overwrite an earlier one sharing a key, which is what the @@ -2913,19 +2859,23 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (anyNA(varLookup)) { msg <- glue( ".ctwasBuildWeights: missing genotype variance for ", - "{sum(is.na(varLookup))} variant(s) in the LD panel." + "{sum(is.na(varLookup))} variant(s) in the LD panel; an LdMatrix ", + "needs an `AF` column to scale non-standardized weights." ) abort(msg) } renormalized * sqrt(varLookup) } -# The ctwas per-gene weight entry (weight matrix, LD submatrix, chrom/BP span, -# plus identity metadata). +# The ctwas per-gene weight entry (weight matrix, weight variance w'Rw, +# chrom/BP span, plus identity metadata). ctwas would read the weights' LD +# submatrix (R_wgt) only to compute the gene z (compute_gene_z); the pipeline +# supplies that z itself (.ctwasGeneZ()), so the entry carries the scalar +# w'Rw instead. # # `spanVids` is the variant set the chrom/p0/p1 span is measured over, and it is # deliberately allowed to be WIDER than the fitted `vids`: ctwas fine-maps one -# region at a time, so `wgt` / `R_wgt` must stay inside that region, while +# region at a time, so `wgt` must stay inside that region, while # `ctwas::get_boundary_genes` reads p0/p1 to decide which genes straddle a # region boundary. Measuring the span over the fitted subset would clip a # boundary gene down to its home region and hide it from merge_regions. @@ -2933,19 +2883,19 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { .ctwasGeneEntry <- function( vids, w, - rWgt, + wgtVar, meta, spanVids = vids, spanInfo ) { - # Span coordinates come from the whole-panel table, while `rWgt` was + # Span coordinates come from the whole-panel table, while `wgtVar` was # computed on the block's own panel: ctwas fine-maps one region at a # time, but a boundary gene's span has to reach past it. panelInfo <- spanInfo rowIdx <- match(spanVids, panelInfo$id) list( wgt = matrix(w, ncol = 1L, dimnames = list(vids, "wgt")), - R_wgt = rWgt, + wgt_var = wgtVar, type = meta$context, context = meta$context, gene_name = meta$trait, @@ -2984,7 +2934,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # @noRd .ctwasGenePrepared <- function(i, twasWeights, ctx) { # Polymorphic: the weight source may be a TwasWeights or a - # FineMappingResult, so the payload comes from the class-aware bridge. + # fine-mapping result, so the payload comes from the class-aware bridge. parts <- .rowParts(twasWeights, i) aligned <- .ctwasAlignGeneWeights(parts, ctx$refVariants, ctx$panelSnps) if (is.null(aligned)) { @@ -3021,9 +2971,8 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (!any(inRegion)) { return(NULL) } - # No LD yet. R_wgt is built in a second sweep, once every gene's fitted - # size is known and the block can choose between forming one full - # correlation and one small correlation per gene. + # No LD yet: the weight variances come in a second sweep, from one read + # of the block's LD over every gene's fitted variants together. list( key = meta$key, vids = kept$vids[inRegion], @@ -3033,27 +2982,15 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) } +# One prepared gene's ctwas entry, given its weight variance w'Rw. # @noRd -.ctwasPreparedSize <- function(g) { - length(g$vids) -} - -# One prepared gene's ctwas entry. `fullR` is the block's correlation when -# .ctwasRWgtSource() chose to form it, and NULL when each gene computes its -# own small one. -# @noRd -.ctwasGeneEntryFor <- function(g, ldPanel, fullR, spanInfo) { - rWgt <- if (is.null(fullR)) { - .ctwasPanelLdSubset(ldPanel, g$vids) - } else { - fullR[g$vids, g$vids, drop = FALSE] - } +.ctwasGeneEntryFor <- function(g, wgtVar, spanInfo) { list( key = g$key, entry = .ctwasGeneEntry( g$vids, g$w, - rWgt, + wgtVar, g$meta, spanVids = g$spanVids, spanInfo = spanInfo @@ -3061,6 +2998,102 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) } +# Each prepared gene's weight variance w'Rw, from one read of the block's LD +# over the union of the genes' weight variants. ctwas reads a gene's weight +# LD only for this quadratic form (compute_gene_z), so the pipeline computes +# the gene z itself (.ctwasGeneZ()) and no per-gene or block-wide LD matrix +# is ever formed for it. +# @noRd +.ctwasWeightVariances <- function(ldPanel, prepared) { + if (length(prepared) == 0L) { + return(numeric(0)) + } + vids <- unique(list_c(map(prepared, "vids"))) + ld <- .ctwasPanelWeightLd(ldPanel, vids) + map_dbl(prepared, .ctwasWeightVariance, ld = ld) +} + +# The block's LD over `vids`, for weight variances: list(F = ) holding a +# genotype reference's factor (.ldRefFactor()), or list(R = ) holding the +# matrix a panel already carries -- a caller who computed it, or a payload it +# travelled with -- or an LdMatrix's. +# @noRd +.ctwasPanelWeightLd <- function(ldPanel, vids) { + idx <- match(vids, ldPanel$snpInfo$id) + if (anyNA(idx)) { + msg <- glue( + "ctwasPipeline: {sum(is.na(idx))} weight variant(s) absent from ", + "the block's LD panel." + ) + abort(msg) + } + if (!is.null(ldPanel$R)) { + return(list(R = ldPanel$R[vids, vids, drop = FALSE])) + } + if (.ldIsGenotypeRef(ldPanel$sketch)) { + factor <- .ldRefFactor(ldPanel$sketch, idx) + return(list(F = `colnames<-`(factor, vids))) + } + list(R = .ctwasPanelLdFor(ldPanel, idx, vids)) +} + +# One gene's weight variance w'Rw from .ctwasPanelWeightLd()'s LD. +# @noRd +.ctwasWeightVariance <- function(g, ld) { + if (!is.null(ld$F)) { + f <- ld$F[, g$vids, drop = FALSE] + return(sum((f %*% g$w)^2) / (nrow(f) - 1)) + } + r <- ld$R[g$vids, g$vids, drop = FALSE] + as.numeric(crossprod(g$w, r %*% g$w)) +} + +# The gene z-scores ctwas::compute_gene_z() would compute, +# w'z / sqrt(w'Rw), from each entry's weights and the weight variance the +# pipeline already holds (`wgt_var`), with ctwas's columns and its rule of +# dropping a gene whose z is infinite. +# @noRd +.ctwasGeneZ <- function(weightsList, zSnp) { + if (length(weightsList) == 0L) { + return(NULL) + } + zGene <- list_rbind(map2( + weightsList, + names(weightsList), + .ctwasGeneZRow, + zSnp = zSnp + )) + infinite <- is.infinite(zGene$z) + if (any(infinite)) { + warn(glue( + "ctwasPipeline: dropped {sum(infinite)} gene(s) with an infinite ", + "z-score." + )) + } + as.data.frame(filter(zGene, !infinite)) +} + +# One gene's z row. Every weight variant must carry a GWAS z, as +# compute_gene_z() requires. +# @noRd +.ctwasGeneZRow <- function(entry, id, zSnp) { + wgt <- entry$wgt + zs <- zSnp$z[match(rownames(wgt), zSnp$id)] + if (anyNA(zs)) { + abort(glue( + "ctwasPipeline: {sum(is.na(zs))} weight variant(s) of gene ", + "'{id}' have no GWAS z-score." + )) + } + tibble( + id = id, + z = as.numeric(crossprod(wgt, zs)) / sqrt(entry$wgt_var), + type = entry$type, + context = entry$context, + group = str_c(entry$context, "|", entry$type) + ) +} + # Which of a gene's weight variants lie in the region being fine-mapped. A NULL # region set means the caller supplied none, so nothing is restricted. # @noRd @@ -3073,7 +3106,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # Look up the per-(study, context, trait, method) PIP vector and the # 95% credible-set membership / purity for one gene from the supplied -# FineMappingResult. Returns NULL when no FineMappingResult was passed +# fine-mapping result. Returns NULL when none was passed # or no matching tuple exists. Output is a list with: # pip : named numeric vector keyed by variant_id # csMembers : list of character vectors (one per CS at 95% coverage) @@ -3118,10 +3151,6 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { list(pip = pip, csMembers = cs$csMembers, csPurity = cs$csPurity) } -# Per-CS membership + purity at 95% coverage from a topLoci table. cs_95 stores -# `_` where idx == 0 means "not in any CS"; cs_95_purity (when -# present) broadcasts one purity value across a CS's rows. -# @noRd # One credible set's member variants and its purity. # @noRd .ctwasCsEntry <- function(k, tl, csIdx, keepIdx) { @@ -3134,11 +3163,15 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { list(members = as.character(tl$variant_id)[inCs], purity = purity) } +# Per-CS membership + purity at 95% coverage from a topLoci table. cs_95 stores +# `_` where idx == 0 means "not in any CS"; cs_95_purity (when +# present) broadcasts one purity value across a CS's rows. +# @noRd .ctwasCsMembership <- function(tl) { if (!is_in("cs_95", names(tl))) { return(list(csMembers = list(), csPurity = numeric(0))) } - csIdx <- suppressWarnings(as.integer(str_remove(tl$cs_95, "^.*_"))) + csIdx <- .csLabelIndex(tl$cs_95) keepIdx <- !is.na(csIdx) & csIdx > 0L entries <- map( sort(unique(csIdx[keepIdx])), @@ -3265,9 +3298,6 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) } -# Variants that must survive the cap: members of any high-purity (>= csMinCor) -# credible set, plus any with PIP > minPipCutoff. Empty when no finemapAux. -# @noRd # Variants rescued by credible set `k`, when that set is pure enough. # @noRd .ctwasCsRescued <- function(k, finemapAux, vids, csMinCor) { @@ -3277,6 +3307,9 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { intersect(finemapAux$csMembers[[k]], vids) } +# Variants that must survive the cap: members of any high-purity (>= csMinCor) +# credible set, plus any with PIP > minPipCutoff. Empty when no finemapAux. +# @noRd .ctwasMustKeep <- function(vids, finemapAux, csMinCor, minPipCutoff) { if (is.null(finemapAux)) { return(character(0)) @@ -3349,10 +3382,10 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # A cTWAS payload's `LD_file` token does double duty: ctwas asserts the file # exists, and pecotmr dispatches on the same string into the cached per-region -# LD panels. Both make the token machine-specific, so a payload that was -# serialised (the bundled ctwas*Example objects) carries a path from whatever -# machine built it. Re-point it at this installation on the way in, using the -# same "pecotmr://extdata/" convention the genotype handles use. +# LD panels. Each token is a sentinel in the session's tempdir +# (.ctwasMintLdTokens()), so a payload that was serialised (the bundled +# ctwas*Example objects) carries tokens a later session no longer has; they +# are re-minted on the way in. # # The panels themselves travel with the closures and are never re-read, so # this only has to keep the token and the cache keys agreeing with each other. @@ -3366,10 +3399,9 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { return(payload) } stored <- as.character(ldMap[["LD_file"]]) - resolved <- map_chr(stored, .resolveCtwasLdToken) resolved <- .ctwasRemintMissingTokens( - resolved, - .ctwasLdMapRegionIds(ldMap, length(resolved)) + stored, + .ctwasLdMapRegionIds(ldMap, length(stored)) ) if (identical(resolved, stored)) { return(payload) @@ -3397,16 +3429,6 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { as.character(rid) } -# Only "pecotmr://" tokens move; an ordinary path is the caller's own and is -# left alone (an unresolvable bundled reference is an error worth hearing). -# @noRd -.resolveCtwasLdToken <- function(token) { - if (!str_detect(token, "^pecotmr://")) { - return(token) - } - .resolveGenotypeResourcePath(token) -} - # Rebuild the loader closures over a cache re-keyed to the resolved tokens, # so `LD_loader_fun(LD_file)` still finds its panel after the rename. # @noRd @@ -3427,8 +3449,8 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) } -# The panel cache the loader closures were built over, or NULL when the -# payload carries loaders this package did not create. +# The panel cache a payload's loader carries, or NULL when the payload +# carries loaders this package did not create. # @noRd .ctwasCachedPanels <- function(payload) { loader <- payload$LD_loader_fun @@ -3442,57 +3464,70 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # `LD_loader_fun(LD_file)` per region during region_data assembly and # fine-mapping; we dispatch by `LD_file` (the same string set on # `LD_map$LD_file`) into the cached per-sketch ldPanel. +# +# ctwas passes the loader that one argument and nothing else, so the panel +# cache travels on the function object itself, as its `ldPanelsByRegion` +# attribute: .ctwasLoadRegionLd() reads it back through sys.function(), and +# .ctwasCachedPanels() reads the same attribute, so the cache has one home. # @noRd .ctwasMultiBlockLdLoader <- function(ldPanelsByRegion) { - force(ldPanelsByRegion) - fn <- function(LD_file) { - panel <- ldPanelsByRegion[[LD_file]] - if (is.null(panel)) { - msg <- glue( - "ctwasPipeline LD loader: no cached panel for ", - "LD_file = '{LD_file}'" - ) - abort(msg) - } - # Built here rather than up front: this is the only place a region's - # full LD is actually needed, and ctwas reaches it only for regions - # that survived screening. - .ctwasPanelLd(panel) - } - # Published explicitly so .ctwasCachedPanels can recover the cache from a - # loader we built, instead of looking the name up inside the closure's - # environment. - `attr<-`(fn, "ldPanelsByRegion", ldPanelsByRegion) + `attr<-`(.ctwasLoadRegionLd, "ldPanelsByRegion", ldPanelsByRegion) +} + +# The LD loader ctwas calls: region `LD_file`'s full LD, from the panel cache +# carried on this function's own attribute (see .ctwasMultiBlockLdLoader()). +# Built here rather than up front: this is the only place a region's full LD +# is actually needed, and ctwas reaches it only for regions that survived +# screening. +# @noRd +.ctwasLoadRegionLd <- function(LD_file) { + .ctwasPanelLd(.ctwasLoaderPanel(sys.function(), LD_file, "LD loader")) } # Multi-block SNP-info loader for ctwas. Mirrors the LD loader. # @noRd .ctwasMultiBlockSnpInfoLoader <- function(ldPanelsByRegion) { - force(ldPanelsByRegion) - function(LD_file) { - panel <- ldPanelsByRegion[[LD_file]] - if (is.null(panel)) { - msg <- glue( - "ctwasPipeline snpInfo loader: no cached panel for ", - "LD_file = '{LD_file}'" - ) - abort(msg) - } - panel$snpInfo + `attr<-`(.ctwasLoadRegionSnpInfo, "ldPanelsByRegion", ldPanelsByRegion) +} + +# The snpInfo loader ctwas calls, reading the same attribute. +# @noRd +.ctwasLoadRegionSnpInfo <- function(LD_file) { + .ctwasLoaderPanel(sys.function(), LD_file, "snpInfo loader")$snpInfo +} + +# The cached panel `loader` carries for `LD_file`; an error naming the token +# when its cache has none. +# @noRd +.ctwasLoaderPanel <- function(loader, LD_file, what) { + panel <- attr(loader, "ldPanelsByRegion")[[LD_file]] + if (is.null(panel)) { + msg <- glue( + "ctwasPipeline {what}: no cached panel for ", + "LD_file = '{LD_file}'" + ) + abort(msg) } + panel } -# Derive the LD_file token for ctwas from a GenotypeHandle. We point -# at the on-disk file that already backs the sketch's data, so the -# `file.exists(LD_map$LD_file)` assertion in ctwas::ctwas_sumstats -# passes WITHOUT pecotmr doing any new I/O. The token also serves as -# the dispatch key for the multi-block LD / snpInfo loaders, so two -# blocks sharing the same on-disk LD payload share one cached panel. +# The on-disk file that backs an LD panel's data, checked to exist before the +# panel builder reads dosages out of it. An LdMatrix holds its LD in memory, +# and a panel held in memory its dosages, so neither has a payload to find. # @noRd .ctwasLdPanelKey <- function(sketch) { - handle <- .ldSketchHandle(sketch) - fmt <- genotypeFormat(handle) - stem <- .genotypeReadPath(handle) + if (.ldIsMatrixRef(sketch)) { + return(invisible(NULL)) + } + if (.ldIsMixtureRef(sketch)) { + walk(.gmComponents(sketch), .ctwasLdPanelKey) + return(invisible(NULL)) + } + fmt <- .ldRefFormat(sketch) + if (is.null(fmt)) { + return(invisible(NULL)) + } + stem <- .ldRefReadPath(sketch) candidates <- switch( fmt, "plink2" = c(str_c(stem, ".pgen")), @@ -3504,8 +3539,8 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { hit <- candidates[file.exists(candidates)] if (length(hit) == 0L) { msg <- glue( - "ctwasPipeline: could not derive an existing LD-file token for ", - "the GenotypeHandle (format={fmt}, path={stem}). Looked for: ", + "ctwasPipeline: could not find the file behind the LD panel ", + "(format={fmt}, path={stem}). Looked for: ", "{str_flatten(candidates, ', ')}" ) abort(msg) @@ -3543,7 +3578,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # Sentinels live in the session tempdir, so a payload serialised in one # session carries tokens that no longer exist in the next -- and ctwas # asserts file.exists() on every one. Mint replacements; the caller re-keys -# the cached panels onto them, exactly as it does for a "pecotmr://" move. +# the cached panels onto them. # @noRd .ctwasRemintMissingTokens <- function(tokens, regionIds) { gone <- !file.exists(tokens) @@ -3572,11 +3607,6 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { invisible(NULL) } -# Build a per-block snpInfo table restricted to variants present in the -# GwasSumStats entry. Mirrors `.ctwasSnpInfoForBlock` but restricts to -# the block's GWAS variants (intersected against the cached panel) so -# snp_map[[region_id]] is sized to the block, not the whole panel. -# @noRd # One entry's variant ids, or none when it does not carry a SNP column. # @noRd .ctwasEntrySnpIds <- function(i, gwasSumStats) { @@ -3587,6 +3617,11 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { as.character(mc$SNP) } +# Build a per-block snpInfo table restricted to variants present in the +# GwasSumStats entry. Mirrors `.ctwasSnpInfoForBlock` but restricts to +# the block's GWAS variants (intersected against the cached panel) so +# snp_map[[region_id]] is sized to the block, not the whole panel. +# @noRd .ctwasSnpInfoForGwasBlock <- function(gwasSumStats, panelSnpInfo) { blockIds <- unique(.ctwasConcatChr(map( seq_len(nrow(gwasSumStats)), diff --git a/R/ctwasWrapper.R b/R/ctwasWrapper.R index 7595b0a99..790151539 100644 --- a/R/ctwasWrapper.R +++ b/R/ctwasWrapper.R @@ -7,6 +7,37 @@ # forwards arguments to one of those calls. # ============================================================================= +# Run a ctwas step with its console log lowered to warnings. ctwas narrates +# every step through the logging package, whose console handler writes to +# stdout with cat(), so neither suppressMessages() nor knitr's message = FALSE +# can hide it. Only that handler is lowered: a log file asked of the step +# (`logfile=`) still receives every record. A handler the step adds is removed +# after it, as ctwas never removes the one it opens for `logfile=`, which +# would otherwise go on receiving every later step's records. +# @noRd +.ctwasQuietly <- function(fn, args) { + if (!requireNamespace("logging", quietly = TRUE)) { + return(exec(fn, !!!args)) + } + before <- names(logging::getLogger()[["handlers"]]) + on.exit(.ctwasDropAddedHandlers(before), add = TRUE) + console <- logging::getHandler("basic.stdout") + if (!is.null(console)) { + level <- console[["level"]] + logging::setLevel("WARN", console) + on.exit(logging::setLevel(level, console), add = TRUE) + } + exec(fn, !!!args) +} + +# Remove the log handlers added since `before` was taken. +# @noRd +.ctwasDropAddedHandlers <- function(before) { + added <- setdiff(names(logging::getLogger()[["handlers"]]), before) + walk(added, logging::removeHandler) + invisible(NULL) +} + # z_gene for assemble_region_data (which requires it non-NULL): use the caller's # inputs$z_gene, else compute via ctwas::compute_gene_z (mirrors # ctwas_sumstats). Routed through .ctwasInvoke so `methodArgs` reaches it -- diff --git a/R/enloc.R b/R/enloc.R index 35c6605cf..5dd1c5c74 100644 --- a/R/enloc.R +++ b/R/enloc.R @@ -30,7 +30,7 @@ NULL # The GWAS Bayes factors fastenloc recovers from fine-mapped PIPs, contrasting # against "every variant in the cluster has no effect" (controller.cc): # log10bf = log10(pip) - log10(P_gwas) + log10(1 - P_gwas) - log10(1 - cpip) -# A zero PIP is floored, as upstream does, so the log is finite. +# A zero PIP is floored, as the original fastenloc does, so the log is finite. # @noRd .enlocGwasLog10Bf <- function(gwasPip, pGwas, clusterPip) { floored <- replace(gwasPip, gwasPip == 0, 1e-10) @@ -93,8 +93,8 @@ enlocClusterProbabilities <- function( )) } bf <- 10^gwasLog10Bf - # The cluster's total eQTL posterior, capped as upstream does so that - # log(1 - clusterPip) stays finite. + # The cluster's total eQTL posterior, capped as the original fastenloc + # does so that log(1 - clusterPip) stays finite. clusterPip <- min(sum(qtlPip), 1 - 1e-8) pri <- .enlocConfigPriors(pi1e, pi1ne, p) # case 4, split by whether the GWAS hit is the causal eQTL @@ -124,7 +124,7 @@ enlocClusterProbabilities <- function( # enloc's priors from the enrichment parameters, as # fastenloc's set_enrich_params(a0, a1) computes them. `a1` is capped first, -# matching the --cap_a1 option upstream. +# matching the original fastenloc's --cap_a1 option. # @noRd .enlocPriorsFromEnrichment <- function(a0, a1, pQtl, capA1 = Inf) { a1 <- min(a1, capA1) diff --git a/R/exampleData.R b/R/exampleData.R index 3527bba39..9c12051bf 100644 --- a/R/exampleData.R +++ b/R/exampleData.R @@ -80,8 +80,8 @@ NULL #' chr22) keyed by \code{study_1} / \code{susie}, carrying the SuSiE-RSS fit #' and a per-variant table with the standard post-processing columns #' (\code{pip}, \code{logBF}, \code{cs_95} / \code{cs_70} / \code{cs_50} and -#' their purities, marginal statistics). Four credible sets. \code{ldSketch} is -#' the bundled \code{toy_canonical} genotype panel, present +#' their purities, marginal statistics). Four credible sets. \code{ldReference} +#' is the bundled \code{toy_canonical} genotype panel, present #' because \code{\link{qtlEnrichmentPipeline}} requires the GWAS collection to #' carry one as its RSS-derived marker; the LD actually used for the fit is an #' in-memory correlation matrix computed from \code{\link{eqtlRegionExample}}. @@ -264,7 +264,7 @@ NULL #' @description A pre-QC'd \code{\link{QtlSumStats}} collection covering the #' same (study, context, trait) tuple as \code{\link{qtlDatasetExample}}; #' the per-variant Z / BETA / SE / N values were computed from the synthetic -#' phenotype by per-variant linear regression. The \code{ldSketch} slot +#' phenotype by per-variant linear regression. The \code{ldReference} slot #' references the same toy PLINK1 panel. #' #' @format A \code{QtlSumStats} S4 collection with one row (study1, brain, @@ -319,7 +319,7 @@ NULL #' synthetic trait (\code{"trait1"}, N = 50,000). The signal pattern shares #' one causal variant with \code{\link{qtlSumStatsExample}} (for #' colocalization demos) and adds a second GWAS-only causal variant. -#' The \code{ldSketch} slot references the same toy PLINK1 panel used +#' The \code{ldReference} slot references the same toy PLINK1 panel used #' for the QTL example. #' #' @format A \code{GwasSumStats} S4 collection with one row (trait1) @@ -605,7 +605,10 @@ NULL #' #' @format A list with the cTWAS input components \code{z_snp}, \code{z_gene}, #' \code{weights}, \code{region_info}, \code{snp_map}, \code{LD_map}, and the -#' LD / SNP-info loader closures. +#' LD / SNP-info loader closures. Each \code{weights} entry carries the +#' weights \code{wgt} and their variance \code{wgt_var} (w'Rw), from which +#' the pipeline computes \code{z_gene}, in place of ctwas's per-gene LD +#' matrix \code{R_wgt}. #' #' @keywords data #' @@ -673,16 +676,18 @@ NULL #' @description An \code{LdEigen} reference for the eigendecomposition-based #' heritability estimators (\code{\link{estimateH2}} with #' \code{method = "lder"} or \code{"hdl"}, and -#' \code{\link{computeLdScores}}). Built by \code{\link{buildLdEigen}} from -#' the first 14 chr22 LD blocks of the de-identified \code{protocol_example} -#' reference panel, so the LD is real rather than simulated. Describes the -#' same variants as \code{\link{ldScoreExample}}, so the four estimators can -#' be compared on one reference. -#' -#' The panel behind it has \code{nSamples = 1000}. That is small enough that -#' \code{method = "hdl"}, which models reference-panel noise explicitly, -#' shrinks its estimate hard -- correct behaviour for a panel this size -#' rather than a fault. +#' \code{\link{computeLdScores}}). Built by \code{\link{buildLdEigen}} +#' over the first 14 chr22 LD blocks of the de-identified +#' \code{protocol_example} reference. Describes the same variants as +#' \code{\link{ldScoreExample}}, so the four estimators can be compared on +#' one reference. +#' +#' The LD is that of a panel of 20,000 people simulated from the +#' \code{protocol_example} panel's own LD, which is a sketch of 60 people: +#' the estimators correct for the noise in a reference's LD, and at 60 that +#' correction swamps the signal. A large simulated panel keeps the LD +#' structure real while giving the reference a realistic size +#' (\code{nSamples = 20000}); see \code{inst/scripts/build_h2_examples.R}. #' #' @format An \code{LdEigen} object (extends \code{LdStatistic}) with an #' \code{eigenList} of per-block \code{values} / \code{vectors} / @@ -706,10 +711,10 @@ NULL #' @description An \code{LdScore} reference (per-variant LD scores, weights, #' and per-block LD matrices) for the LD-score-based heritability estimators #' (\code{\link{estimateH2}} with \code{method = "sldsc"} or -#' \code{"gldsc"}). Built by \code{\link{buildLdScore}} from the first 14 -#' chr22 LD blocks of the de-identified \code{protocol_example} reference -#' panel, so the LD is real rather than simulated. Describes the same variants -#' as \code{\link{ldEigenExample}}. +#' \code{"gldsc"}). Built by \code{\link{buildLdScore}} over the first 14 +#' chr22 LD blocks of the de-identified \code{protocol_example} reference, +#' from the same simulated 20,000-person panel as +#' \code{\link{ldEigenExample}}, and describes the same variants. #' #' The per-block LD matrices are retained because \code{"gldsc"} and #' stratified \code{"sldsc"} both need them; unstratified \code{"sldsc"} diff --git a/R/fineMappingPipeline.R b/R/fineMappingPipeline.R index 8b6ffcb50..34e15d514 100644 --- a/R/fineMappingPipeline.R +++ b/R/fineMappingPipeline.R @@ -64,13 +64,13 @@ #' @section QC contract: All \code{QtlSumStats} and \code{GwasSumStats} inputs #' must have been QC'd via \code{\link{summaryStatsQc}}; the pipeline errors #' on inputs where \code{length(qcInfo(x)) == 0L}. \code{summaryStatsQc} -#' also drops variants absent from the \code{ldSketch}, so by the time +#' also drops variants absent from the \code{ldReference}, so by the time #' per-entry processing runs every variant is guaranteed to be present in the #' LD panel and a local LD matrix can be built with #' \code{extractBlockGenotypes} + \code{computeLd("sample")}. #' #' @section Optional resume cache: Supplying \code{fineMappingResult} of an -#' existing \code{FineMappingResult} skips re-fitting any \code{(study, +#' existing fine-mapping result skips re-fitting any \code{(study, #' context, trait, method)} tuple that already has a matching row; cached #' entries are merged with the newly-fit entries in the returned collection. #' @@ -82,8 +82,8 @@ #' \itemize{ #' \item TWAS weights computation (\code{twasWeights = TRUE} path): #' lives in \code{\link{twasWeightsPipeline}} now. -#' \item Filtering knobs (now \code{genotypeFilter} / -#' \code{panelFilter}, \code{ldReferenceMetaFile}): individual- +#' \item Filtering knobs (now \code{genotypeFilterParam} / +#' \code{panelFilterParam}, \code{ldReferenceMetaFile}): individual- #' level QC lives on the \code{QtlDataset} constructor; sumstat #' QC lives in \code{summaryStatsQc()}. No filtering happens #' inside this pipeline. @@ -97,10 +97,10 @@ #' \item \code{loadRssData} and explicit #' \code{ldReferenceMetaFile} arguments: the new #' \code{QtlSumStats} / \code{GwasSumStats} carry the -#' (already-QC'd) sumstats and \code{ldSketch} directly. +#' (already-QC'd) sumstats and \code{ldReference} directly. #' \item Verbose \code{methodName} suffixing (e.g. #' \code{"susie_rss_NO_QC"}, \code{"susie_rss_SLALOM_RAISS_imputed"}): -#' the method column on the returned \code{FineMappingResult} +#' the method column on the returned collection #' carries the bare token (\code{"susie"}, #' \code{"susieInf"}, \code{"mvsusie"}, ...) only. QC #' provenance is recorded on the sumstats' \code{qcInfo}. @@ -131,10 +131,21 @@ #' by the pipeline (e.g. you can override \code{model_init} #' even when fitting from a susieInf chain). #' } -#' @param contexts Optional character vector of context names. Default -#' \code{NULL} (all contexts). -#' @param traitId Optional character vector of trait names to restrict -#' processing to. +#' @param contexts Optional context selection; \code{NULL} (the default) uses +#' every context. A character vector applies to every study: a context no +#' study has is an error, and one only some studies lack is skipped for +#' those, with a warning. A list keyed by study name picks each study's +#' contexts separately (\code{list(A = "liver")}); studies it does not name +#' keep all of theirs. +#' @param traitId Optional trait selection; \code{NULL} (the default) uses +#' every trait, or those overlapping \code{region} when one is given. A +#' character vector applies to every study. A list keyed by study name +#' picks each study's traits separately (\code{list(A = "ENSG1")}), and a +#' study's entry may itself be a list keyed by context +#' (\code{list(A = list(brain = "ENSG1"))}). Studies and contexts the list +#' does not name keep all of their traits. A joint fit spanning a study's +#' contexts uses every trait selected in any of them, minus the (context, +#' trait) pairs a per-context entry leaves out. #' @param region Optional variant window for QtlDataset trait selection: a #' \code{GRanges}, a \code{"chr:start-end"} string, or a one-row data.frame #' with \code{chrom}/\code{start}/\code{end}. Mutually exclusive with @@ -172,15 +183,22 @@ #' \code{maxNumSingleEffectsGreedy} are the exception: they are seeded #' onto each SuSiE-family token's own arguments, so changing them needs a #' refit. -#' @param fineMappingResult Optional existing \code{FineMappingResult} to use as -#' a resume cache; tuples already present are not refit. -#' @param crossValidationArgs Cross-validation settings, built with +#' @param fineMappingResult Optional existing \code{QtlFineMappingResult} or +#' \code{GwasFineMappingResult} to use as a resume cache; tuples already +#' present are not refit. +#' @param crossValidationParam Cross-validation settings, built with #' \code{\link{CrossValidationParam}}: \code{folds} (default \code{0}, no #' CV), \code{numThreads} for the per-fold refits, and \code{samplePartition} #' to reuse a fixed partition across methods. When \code{folds > 1} each #' method is refit on every fold's training samples and used to predict the #' held-out ones; the partition, the out-of-fold predictions and the metrics #' are stored on each \code{FineMappingRow}'s \code{cvResult} slot. +#' \code{fitFullData = FALSE} keeps only that: each row carries its +#' \code{cvResult} and no full-data fit, variants or top loci. A +#' \code{fineMappingResult} resume cache is only reused where it carries +#' what the run asks for -- a full-data fit unless the run is +#' cross-validation-only, and a \code{cvResult} when the run +#' cross-validates -- and the other tuples are refit. #' #' Cross-validation holds out \strong{samples}, so it is not possible on #' \code{QtlSumStats} / \code{GwasSumStats} input. Those methods accept @@ -194,7 +212,7 @@ #' reproducible fits; the global RNG state is restored on return. Default #' \code{NULL} #' (no seeding). -#' @param signalScreenArgs Individual-level single-effect (SER) pre-screen +#' @param signalScreenParam Individual-level single-effect (SER) pre-screen #' applied to each residualized \code{(X, y)} block before a full fit, #' built with \code{\link{SignalScreenParam}}. A susie model with #' \code{L = 1} is fit and the block is skipped unless the chosen metric @@ -211,38 +229,45 @@ #' \code{\link{SignalScreenParam}} enforces when you build it. Unset (the #' default) screens nothing. The summary-statistics analog lives in #' \code{\link{summaryStatsQc}}. -#' @param usePCA Logical (length 1). \code{QtlDataset} only. When \code{TRUE} +#' @param usePCA Logical (length 1). Individual-level data only: a +#' \code{QtlDataset}, or the \code{QtlDataset} components of a +#' \code{MultiStudyQtlDataset}. When \code{TRUE} #' (default \code{FALSE}), each multi-trait context's PCA-reduced phenotype is #' fine-mapped with univariate SuSiE on its top principal components (ports #' the legacy \code{fsusie.R} \code{susie_on_top_pc}). Each PC becomes a #' pseudo-trait row keyed \code{trait = "topPC\{i\}"}, \code{method = #' "susie"}. Single-trait contexts have no PCA and are skipped. -#' @param nPCs Integer (length 1). \code{QtlDataset} only. Caps the number of -#' top principal components fine-mapped per context when \code{usePCA = TRUE} -#' (default \code{10}). The effective count is \code{min(nPCs, usable -#' traits)}. -#' @param jointSpecification Optional joint-fit specification (NULL by default). -#' When NULL, the pipeline runs the implicit multi-context / multi-trait -#' mvSuSiE / fSuSiE branches as before. When non-NULL, the argument is parsed -#' and validated via the joint-spec grammar documented under -#' \code{parseJointSpecification} (a character vector of axes, or a list of -#' \code{list(axes, scope)} specs); the per-spec axis dispatcher -#' implementation is in progress and a non-NULL value currently errors with an -#' informative message. See the design notes in \code{R/jointSpecification.R} -#' for the accepted grammar. +#' @param nPCs Integer (length 1). Individual-level data only. Caps the +#' number of top principal components fine-mapped per context when +#' \code{usePCA = TRUE} (default \code{10}). The effective count is +#' \code{min(nPCs, usable traits)}. +#' @param jointSpecification Optional joint-fit specification saying which +#' axes \code{mvsusie} / \code{fsusie} fit across. When NULL (the default) +#' they fit across traits if the input has two or more, else across +#' contexts. Otherwise give a character vector of axes (one spec) or a list +#' of specs. A spec is a character vector drawn from \code{"study"}, +#' \code{"context"} and \code{"trait"}, or +#' \code{list(axes = , scope = )}, where \code{scope} +#' (keys \code{study}, \code{context}, \code{trait}) limits the fit to the +#' listed values, each of which must exist in \code{data}. A list-form +#' spec always goes inside the outer list, even on its own. Other methods +#' run per (study, context, trait) as usual. The \code{"study"} axis needs +#' summary statistics: it is rejected on a \code{QtlDataset}, and on a +#' \code{MultiStudyQtlDataset} only the summary-statistics studies take +#' part. #' @section Panel filters on the RSS path: On \code{QtlSumStats} / #' \code{GwasSumStats} input there is no genotype matrix to filter, so -#' \code{panelFilter}'s \code{mafCutoff} / \code{macCutoff} / +#' \code{panelFilterParam}'s \code{mafCutoff} / \code{macCutoff} / #' \code{imissCutoff} are measured against the \strong{LD reference panel} #' instead: a variant whose panel genotypes fall below the cutoffs is #' dropped before the z-scores and LD matrix are built. The thresholds mean -#' the same thing as \code{genotypeFilter}'s on the \code{QtlDataset} path -#' (MAC is converted to a MAF equivalent and the stricter of the two +#' the same thing as \code{genotypeFilterParam}'s on the \code{QtlDataset} +#' path (MAC is converted to a MAF equivalent and the stricter of the two #' applies), so one number carries across input types. The defaults filter #' nothing. #' #' This discards \emph{observed} variants, unlike -#' \code{summaryStatsQc(imputeArgs = ...)}, which only bounds which variants +#' \code{summaryStatsQc(raissParam = ...)}, which only bounds which variants #' RAISS will impute. Use it when the panel cannot support the LD estimate a #' rare variant would need. #' @@ -266,7 +291,7 @@ #' @param naAction Character. How to handle missing values in the extracted #' phenotype/genotype data. #' @param verbose Verbosity (0 silent, 1 default). Default \code{1}. -#' @param residualizationArgs Covariate residualization settings, built with +#' @param residualizationParam Covariate residualization settings, built with #' \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and #' \code{genotypeCovariates} name which covariates to regress out #' (\code{NULL}, the default, uses every available one), and @@ -276,7 +301,8 @@ #' Only meaningful for \code{QtlDataset} / \code{MultiStudyQtlDataset} #' input. A \code{QtlSumStats} / \code{GwasSumStats} run has no covariates #' to regress out, so the bundle is \strong{ignored} there rather than -#' refused --- unlike \code{crossValidation}, which errors. Residualization +#' refused --- unlike \code{crossValidationParam}, which errors. +#' Residualization #' is on by default, so refusing a non-default value would reject the #' default bundle; CV is off by default, so a non-default value there is an #' explicit request for something the input cannot do. @@ -291,7 +317,7 @@ #' posterior #' matrices. The per-variant \code{topLoci} table is fully populated #' either way --- its per-credible-set columns are governed by -#' \code{credibleSet}'s \code{perCsColumns}, not by this. +#' \code{credibleSetParam}'s \code{perCsColumns}, not by this. #' @param susieRssParam Summary-statistics solver settings for #' \code{QtlSumStats} / \code{GwasSumStats} input, built with #' \code{\link{SusieRssParam}}: \itemize{ @@ -311,7 +337,7 @@ #' \code{R_finite} correction. \code{NULL} (default) uses susieR's #' own, except when a finite/EB mode is active (\code{serFallback} or #' \code{rMismatch != "none"}), where it falls back to the LD panel's -#' \code{nSamples(ldSketch)}. +#' \code{nSamples(ldReference)}. #' \item \code{rMismatch} (default \code{"none"}) --- LD-mismatch #' correction forwarded as \code{R_mismatch}: also \code{"eb"} or #' \code{"eb_mix"}. @@ -349,10 +375,12 @@ #' is the scale the LD correlations and z-scores behind a TWAS Z are already #' on. #' -#' @return A \code{FineMappingResult} collection keyed by \code{(study, context, -#' trait, method)}. The \code{ldSketch} slot is set automatically: \code{NULL} +#' @return A \code{QtlFineMappingResult} keyed by \code{(study, context, +#' trait, method)} -- for \code{GwasSumStats} input, a +#' \code{GwasFineMappingResult} keyed by \code{(study, method)} and range. +#' The \code{ldReference} slot is set automatically: \code{NULL} #' for individual-level (QtlDataset / all-individual-level -#' MultiStudyQtlDataset) fits, the input's \code{ldSketch} for RSS-derived +#' MultiStudyQtlDataset) fits, the input's \code{ldReference} for RSS-derived #' fits. #' @examples #' data(qtlDatasetExample) @@ -408,24 +436,21 @@ setGeneric("fineMappingPipeline", function(data, ...) { sumstatImpl = "susieR::susie_rss", multivariate = FALSE, gwasAllowed = TRUE, - unmappableEffects = "none", - args = list() + unmappableEffects = "none" ), susieInf = list( individualImpl = "susieR::susie", sumstatImpl = "susieR::susie_rss", multivariate = FALSE, gwasAllowed = TRUE, - unmappableEffects = "inf", - args = list() + unmappableEffects = "inf" ), susieAsh = list( individualImpl = "susieR::susie", sumstatImpl = "susieR::susie_rss", multivariate = FALSE, gwasAllowed = TRUE, - unmappableEffects = "ash", - args = list() + unmappableEffects = "ash" ), # Single-effect regression (SER) on summary statistics via # susieR::susie_ser. @@ -438,24 +463,21 @@ setGeneric("fineMappingPipeline", function(data, ...) { sumstatImpl = "susieR::susie_ser", multivariate = FALSE, gwasAllowed = TRUE, - unmappableEffects = NA_character_, - args = list() + unmappableEffects = NA_character_ ), mvsusie = list( individualImpl = "mvsusieR::mvsusie", sumstatImpl = "mvsusieR::mvsusie_rss", multivariate = TRUE, gwasAllowed = FALSE, - unmappableEffects = NA_character_, - args = list() + unmappableEffects = NA_character_ ), fsusie = list( individualImpl = "fsusieR::susiF", sumstatImpl = NULL, multivariate = TRUE, gwasAllowed = FALSE, - unmappableEffects = NA_character_, - args = list() + unmappableEffects = NA_character_ ) ) @@ -464,10 +486,6 @@ setGeneric("fineMappingPipeline", function(data, ...) { # them with a clear pointer rather than an "unknown token" error. .fmTwasOnlyTokens <- c("mrmash") -# Normalize a user-supplied `methods` argument into a character vector of -# canonical tokens. Mirrors `.twasNormalizeMethods` but the fine-mapping -# pipeline takes only a character vector (no preset strings, no list form). -# @noRd # Normalize a user-supplied `methods` argument into `(tokens, methodArgs)`. # # Accepts: * character vector c("susie", "susieInf") -> empty kwargs per token @@ -483,8 +501,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { # A plain named list is routable HERE even though the constructor refuses one # under `methods`: this call knows its input class, so the overrides go into # that path's slot and are checked against the engine that will actually -# receive them. A retired FineMappingMethodsParam() record is still accepted -# too. +# receive them. # @noRd .fmNormalizeMethods <- function( methods, @@ -512,11 +529,6 @@ setGeneric("fineMappingPipeline", function(data, ...) { ), inputKind ) - } else if (.isMethodOptions(methods)) { - list( - tokens = names(methods), - methodArgs = map(as.list(methods), as.list) - ) } else { cls <- class(methods)[[1L]] msg <- glue( @@ -597,13 +609,10 @@ setGeneric("fineMappingPipeline", function(data, ...) { # have one entry point for individual-level data and another for summary # statistics, and any single run uses exactly one of them -- so once the input # class is known the argument names can be checked against that one engine -# rather than against the union of both. +# rather than against the union of both. NULL when it has none for the class. # @noRd .fmMethodCalleeFor <- function(token, inputKind) { info <- .fineMappingMethodCapabilities[[token]] - if (is.null(info)) { - return(NULL) - } if (identical(inputKind, "QtlDataset")) { return(info$individualImpl) } @@ -698,16 +707,13 @@ setGeneric("fineMappingPipeline", function(data, ...) { )) } info <- caps[[tk]] + # A MultiStudyQtlDataset routes each method to the components it runs on, + # and every method runs on one of them, so none is refused there. reason <- switch( inputKind, QtlDataset = if (is.null(info$individualImpl)) { "is sumstat-only (use a QtlSumStats input)" }, - MultiStudyQtlDataset = if ( - is.null(info$individualImpl) && is.null(info$sumstatImpl) - ) { - "has no individual or sumstat implementation" - }, QtlSumStats = if (is.null(info$sumstatImpl)) { "is individual-only (use a QtlDataset input)" }, @@ -739,17 +745,16 @@ setGeneric("fineMappingPipeline", function(data, ...) { # Keep only the tokens in `methods` whose capability has a non-NULL `capField` # (individualImpl / sumstatImpl), so a sumstat-only method (e.g. ser) is dropped # from the individual-level recursion and an individual-only method from the -# sumstat recursion. `methods` is a character vector of tokens or a named list -# of per-token args; unknown tokens pass through (handled elsewhere). +# sumstat recursion. `methods` is the named list of per-token args a joint +# phase leaves, or the run's FineMappingMethodsParam, which passes through +# whole: each component reads its own path's slot. Unknown tokens pass through +# (handled elsewhere). .fmFilterMethodsForKind <- function(methods, capField) { - caps <- .fineMappingMethodCapabilities - if (is.character(methods)) { - methods[map_lgl(methods, .fmMethodOk, capField, caps)] - } else if (is.list(methods)) { - methods[map_lgl(names(methods), .fmMethodOk, capField, caps)] - } else { - methods + if (!is.list(methods)) { + return(methods) } + caps <- .fineMappingMethodCapabilities + methods[map_lgl(names(methods), .fmMethodOk, capField, caps)] } # Reject SumStats inputs that have not been QC'd via summaryStatsQc. @@ -821,6 +826,37 @@ setGeneric("fineMappingPipeline", function(data, ...) { .fmrRowParts(fineMappingResult, idx[[1L]]) } +# The rows of a resume cache this run may reuse. A cross-validation-only row +# (no full-data fit) cannot stand in for a run that needs the fit, and a row +# without cross-validation cannot stand in for a run that cross-validates; +# either would come back short of what was asked for, so those tuples are +# refit instead. `cvCfg` is the run's resolved CrossValidationParam. +# @noRd +.fmCacheForRun <- function(fineMappingResult, cvCfg) { + if (!is(fineMappingResult, "FineMappingResultBase")) { + return(fineMappingResult) + } + rows <- seq_len(nrow(fineMappingResult)) + hasFit <- map_lgl( + rows, + .fmrRowHasFit, + fineMappingResult = fineMappingResult + ) + hasCv <- map_lgl(rows, .fmrRowHasCv, fineMappingResult = fineMappingResult) + usable <- (hasFit | !isTRUE(cvCfg$fitFullData)) & + (hasCv | !.cvEnabled(cvCfg)) + if (all(usable)) { + return(fineMappingResult) + } + fineMappingResult[which(usable)] +} + +# Whether row `i` of a fine-mapping result carries a full-data fit. +# @noRd +.fmrRowHasFit <- function(i, fineMappingResult) { + length(.fmrPartsVariantIds(.fmrRowParts(fineMappingResult, i))) > 0L +} + # GwasFineMappingResult cache lookup using the (study, method, range) identity. # Multi-block FMRs carry one entry per block, so the key has to include the # block -- but the block is now the element's own RANGE rather than a stored @@ -903,7 +939,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { jointTraits = NULL, traitPos = NULL, region = NULL, - ldSketch = NULL, + ldReference = NULL, allowEmpty = FALSE ) { if (length(entries) == 0L && !allowEmpty) { @@ -924,42 +960,37 @@ setGeneric("fineMappingPipeline", function(data, ...) { jointTraits = jointTraits, traitPos = traitPos, region = region, - ldSketch = ldSketch + ldReference = ldReference ) } -# The per-row ANALYSIS WINDOW for a set of (context, trait) rows: the explicit -# `region` when the caller named one, else each trait's own cis window -# (traitPos +/- cisWindow) -- which is the interval the cis path actually -# slices X over, so a per-gene fit records its window just as a region-mode -# fit does. NULL when nothing resolves, so the builder omits the column and -# genomicRegion() falls back to the derived span. # The window ONE block was analysed over: the explicit range when the caller # named one, else the cis window of the trait(s) the block covers -- the same # interval .fmResidGenoBlock() slices X over when `rg` is NULL. Collapsed to a # single range so a multi-trait block (a PC pseudo-trait over a context's -# traits) records the span it covered. +# traits) records the span it covered. The traits are the dataset's own, so +# every one has a position to anchor on. # @noRd .fmBlockWindow <- function(rg, ctx, traits, cfg) { if (!is.null(rg)) { return(rg) } - per <- try_fetch( - .anchorVector( - cfg$data, - rep(ctx, length(traits)), - traits, - "region", - cfg$cisWindow - ), - error = function(cnd) NULL + per <- .anchorVector( + cfg$data, + rep(ctx, length(traits)), + traits, + "region", + cfg$cisWindow ) - if (is.null(per) || length(per) == 0L) { - return(NULL) - } range(per)[1L] } +# The per-row ANALYSIS WINDOW for a set of (context, trait) rows: the explicit +# `region` when the caller named one, else each trait's own cis window +# (traitPos +/- cisWindow) -- which is the interval the cis path actually +# slices X over, so a per-gene fit records its window just as a region-mode +# fit does. NULL when nothing resolves, so the builder omits the column and +# genomicRegion() falls back to the derived span. # @noRd .fmRowWindows <- function(data, contexts, traits, region, cisWindow, n) { explicit <- .analysisWindowForRows(region, n) @@ -982,7 +1013,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { entries, blockIds = NULL, region = NULL, - ldSketch = NULL, + ldReference = NULL, allowEmpty = FALSE ) { if (length(entries) == 0L && !allowEmpty) { @@ -998,7 +1029,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { blockId = blockIds, entry = entries, region = region, - ldSketch = ldSketch + ldReference = ldReference ) } @@ -1038,11 +1069,6 @@ setGeneric("fineMappingPipeline", function(data, ...) { set_names(as.numeric(mc$AF), as.character(mc$SNP))[variantIds] } -# Block label derived from a GwasSumStats entry's GRanges. Built through the -# same helper the collection uses for its range key, so a label minted here and -# the identity of the row it ends up on agree by construction rather than by -# two formatters happening to match. -# @noRd # The block key for GWAS entry `i`: the one the caller SUPPLIED when the # GwasSumStats carries it, else derived from the entry's variant span. # @@ -1052,6 +1078,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { # deriving from that element silently discarded a supplied key and replaced a # true block boundary (chr22_49355984_50799822) with the narrower span of the # variants that survived QC (chr22_49363017_50598205). +# # A supplied key is one that carries COORDINATES. GwasSumStats() always # materializes a blockId, but with no `ldBlocks` manifest and no explicit # `blockId` it falls back to the bare seqname ("chr22") -- which is the @@ -1073,9 +1100,12 @@ setGeneric("fineMappingPipeline", function(data, ...) { .fmGwasRangeKey(gr) } -# The entry's own range key. This is what the resume cache matches on -- it -# compares a cached row's DERIVED range key, so it must stay derived even when -# a block manifest supplies a wider boundary for the stored provenance. +# The entry's own range key, built through the same helper the collection uses +# for its range key, so a label minted here and the identity of the row it ends +# up on agree by construction rather than by two formatters happening to match. +# This is what the resume cache matches on -- it compares a cached row's +# DERIVED range key, so it must stay derived even when a block manifest +# supplies a wider boundary for the stored provenance. # @noRd .fmGwasRangeKey <- function(gr) { .rtlOneRangeKey(range(gr)) @@ -1115,22 +1145,16 @@ setGeneric("fineMappingPipeline", function(data, ...) { try_fetch(.asGRegion(as.character(blockId)), error = function(cnd) NULL) } -# Per-row windows for a GWAS collection, from each row's blockId. NULL when no -# row's blockId carries coordinates, so the column is omitted and -# genomicRegion() falls back to the derived span. +# Per-row windows for a GWAS collection, from each row's blockId -- which +# always spells coordinates (.fmGwasBlockId()): the block boundary when one +# was supplied, else the entry's own span. NULL when there are no rows, so the +# column is omitted. # @noRd .fmGwasRowWindows <- function(rows) { if (length(rows) == 0L) { return(NULL) } - gs <- map(map_chr(rows, "blockId"), .fmBlockIdRange) - if (all(map_lgl(gs, is.null))) { - return(NULL) - } - # A row whose blockId holds no coordinates still needs a range; the - # chrUn sentinel marks it, matching .anchorVector()'s convention. - sentinel <- GenomicRanges::GRanges("chrUn", IRanges::IRanges(1L, 1L)) - exec(c, !!!map(gs, function(g) if (is.null(g)) sentinel else g)) + exec(c, !!!map(map_chr(rows, "blockId"), .fmBlockIdRange)) } # @noRd @@ -1189,7 +1213,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { zn <- .fmExtractZn( gr, glue("fineMappingPipeline(GwasSumStats): study='{st}'"), - ldSketch = cfg$ldSketch, + ldReference = cfg$ldReference, cutoffs = .panelCutoffs(cfg$panelFilterParam) ) # Two different things that used to be one: the key the resume cache @@ -1234,7 +1258,10 @@ setGeneric("fineMappingPipeline", function(data, ...) { list( data = data, credibleSetParam = credibleSetParam, - fineMappingResult = fineMappingResult, + fineMappingResult = .fmCacheForRun( + fineMappingResult, + .cvResolve(CrossValidationParam()) + ), fitRetention = fitRetention, verbose = verbose, panelFilterParam = panelFilterParam @@ -1249,7 +1276,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { # @noRd .fmRssRunCfg <- function( common, - ldSketch, + ldReference, initializeWithSusieInf, methodArgs, susieRssParam @@ -1257,7 +1284,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { c( common, list( - ldSketch = ldSketch, + ldReference = ldReference, initializeWithSusieInf = initializeWithSusieInf, methodArgs = methodArgs, susieRssParam = susieRssParam @@ -1269,14 +1296,14 @@ setGeneric("fineMappingPipeline", function(data, ...) { # the block-specific arguments. The RSS analog of .fmFitXBlockP. # @noRd .fmFitRssBlockP <- function(z, zn, toRun, label, af, cfg, region = NULL) { - ldMat <- .ldFromSketch( - cfg$ldSketch, - zn$variantIds, - label = "fineMappingPipeline" - ) .fmFitRssBlock( z, - ldMat, + .fmRssLd( + cfg$ldReference, + zn$variantIds, + toRun, + cfg$initializeWithSusieInf + ), zn$n, toRun, cfg$initializeWithSusieInf, @@ -1292,6 +1319,24 @@ setGeneric("fineMappingPipeline", function(data, ...) { ) } +# The LD one block's RSS fits read, as list(R, X), in the cheapest form each +# fit accepts. A genotype reference gives its factor X (.ldFactorFromRef()): +# the plain susie model and every credible set's purity read it directly, +# never forming the p x p matrix. The matrix R is formed only when a fit has +# no factor route -- susieInf, and susieAsh, whose susie_rss low-rank paths +# fail (dev/ld-factor-audit.md) -- and is all an LdMatrix has. +# @noRd +.fmRssLd <- function(ldReference, variantIds, toRun, initializeWithSusieInf) { + label <- "fineMappingPipeline" + if (!.ldIsGenotypeRef(ldReference)) { + return(list(R = .ldFromRef(ldReference, variantIds, label = label))) + } + X <- .ldFactorFromRef(ldReference, variantIds, label = label) + chain <- .fmResolveSusieChain(toRun, initializeWithSusieInf) + needsR <- chain$runInf || is_in("susieAsh", toRun) + list(R = if (needsR) crossprod(X) / (nrow(X) - 1), X = X) +} + # Fit the still-to-run RSS tokens for one QtlSumStats entry and return one # row-record per fitted token. # @noRd @@ -1303,7 +1348,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { "fineMappingPipeline(QtlSumStats): entry {i} (study='{st}', ", "context='{ctx}', trait='{tr}')" ), - ldSketch = cfg$ldSketch, + ldReference = cfg$ldReference, cutoffs = .panelCutoffs(cfg$panelFilterParam) ) ents <- .fmFitRssBlockP( @@ -1368,20 +1413,20 @@ setGeneric("fineMappingPipeline", function(data, ...) { list(rows = c(cachedRows, computed), skipped = FALSE) } -# Concatenate two same-class FineMappingResult collections row-wise, carrying -# forward every column (delegates to the generic `.rbindCollections`). +# Concatenate two same-class fine-mapping result collections row-wise, +# carrying forward every column (delegates to the generic `.rbindCollections`). # @noRd #' @importFrom checkmate assertClass -.rbindFineMappingResult <- function(a, b, ldSketch = NULL) { +.rbindFineMappingResult <- function(a, b, ldReference = NULL) { assertClass(a, "FineMappingResultBase") assertClass(b, "FineMappingResultBase") # Carry forward every column (blockId / joint* / ...) and reconcile the # collection-level slots via the shared combine; the concrete class # (QTL vs GWAS) is preserved and checked there. - .combineTupleCollections(list(a, b), ldSketch, ".rbindFineMappingResult") + .combineTupleCollections(list(a, b), ldReference, ".rbindFineMappingResult") } -#' Combine FineMappingResult collections +#' Combine fine-mapping result collections #' #' Row-bind two or more fine-mapping result collections of the SAME concrete #' class (all \code{\link{QtlFineMappingResult}} or all @@ -1391,7 +1436,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { #' #' @param ... Two or more \code{FineMappingResultBase} objects, or a single #' \code{list} of them. -#' @param ldSketch Optional genotype panel (see +#' @param ldReference Optional genotype panel (see #' \code{\link{readGenotypes}}) to attach to the #' combined collection. Default \code{NULL}. Applied when combining two or #' more inputs; a single input is returned unchanged. @@ -1401,13 +1446,13 @@ setGeneric("fineMappingPipeline", function(data, ...) { #' data(qtlFineMappingExample) #' combineFineMappingResults(qtlFineMappingExample) #' @export -combineFineMappingResults <- function(..., ldSketch = NULL) { +combineFineMappingResults <- function(..., ldReference = NULL) { parts <- .asCombineList( list(...), "FineMappingResultBase", "combineFineMappingResults" ) - .combineTupleCollections(parts, ldSketch, "combineFineMappingResults") + .combineTupleCollections(parts, ldReference, "combineFineMappingResults") } @@ -1417,7 +1462,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # would also drop a legitimately zero-length `contexts` / `samples`. .fmResidPheno <- function( x, - residualizationArgs, + residualizationParam, contexts = NULL, traitId = NULL, naAction = NULL @@ -1431,7 +1476,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { !!!c( list( x = x, - residualizationArgs = residualizationArgs %||% + residualizationParam = residualizationParam %||% ResidualizationParam() ), sel @@ -1441,7 +1486,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { .fmResidGeno <- function( x, - residualizationArgs, + residualizationParam, contexts = NULL, traitId = NULL, region = NULL, @@ -1470,7 +1515,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { !!!c( list( x = x, - residualizationArgs = residualizationArgs %||% + residualizationParam = residualizationParam %||% ResidualizationParam() ), sel @@ -1620,6 +1665,37 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { } } +# `region` and `cisWindow` are alternative ways to name the variant window: +# `cisWindow` expands each trait's own coordinates, `region` is taken +# literally. A call supplying both signals a misunderstanding, so it is +# rejected. The one check behind the QtlDataset and MultiStudyQtlDataset +# methods of both fineMappingPipeline() and twasWeightsPipeline(); `label` +# names the caller in the message. +# @noRd +.rejectRegionWithCisWindow <- function(region, cisWindow, label) { + if (!is.null(region) && !is.null(cisWindow)) { + abort(glue( + "{label}: specify either `region` or `cisWindow`, not both. ", + "`cisWindow` expands each trait's own coordinates, whereas ", + "`region` is the literal variant window." + )) + } + invisible(NULL) +} + +# The MultiStudyQtlDataset inputs both pipelines resolve the same way: the +# region + cisWindow guard, the naAction choice and the joint-region spec. The +# per-call filter overrides are left to the components, which apply them to +# their own data. +# @noRd +.msResolveInputs <- function(naAction, region, cisWindow, jointRegions, label) { + .rejectRegionWithCisWindow(region, cisWindow, label) + list( + naAction = arg_match(naAction, c("drop", "impute")), + xRegions = .makeXRegions(region, jointRegions) + ) +} + # Rows of a TwasWeights whose method is mr.mash and whose identity matches # every axis the caller FIXED. A NULL axis means "do not filter on it". # @noRd @@ -1874,10 +1950,12 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { allNames <- unique(list_c(map(tls, names))) csCols <- allNames[str_detect(allNames, "^cs_[0-9]+$")] topLoci <- bind_rows(.fmRenumberCs(tls, csCols)) - susieFit <- set_names( - map(entries, .fmEntrySusieFit), - str_c("region", seq_along(entries)) - ) + fits <- map(entries, .fmEntrySusieFit) + susieFit <- if (all(map_lgl(fits, is.null))) { + NULL + } else { + set_names(fits, str_c("region", seq_along(entries))) + } # Per-region CV partitions/predictions kept under region* names so a # multi-region entry retains each block's CV (NULL when no region had CV). cvList <- set_names( @@ -1893,11 +1971,6 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) } -# Renumber per-region credible-set columns so region-local cs indices do not -# collide once concatenated: each region's indices are shifted by the running -# max of the regions before it (a sequential offset fold, per cs_ -# column). -# @noRd # The highest credible-set index table `tl` uses in column `cc`, or 0 when it # has no such column. # @noRd @@ -1945,6 +2018,11 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) } +# Renumber per-region credible-set columns so region-local cs indices do not +# collide once concatenated: each region's indices are shifted by the running +# max of the regions before it (a sequential offset fold, per cs_ +# column). +# @noRd .fmRenumberCs <- function(tls, csCols) { # A table's offset in a column is how many credible sets the tables # before it contributed there -- a cumulative count, so it is known up @@ -1959,17 +2037,11 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) } -# Merge per-method user kwargs onto a base arg list. `userArgs` is the -# per-token kwargs supplied by the caller (e.g. `list(L = 1, refine = -# FALSE)`); the capability table's `args` default fills in any keys the -# user did not set. User-supplied values always win over base, capability -# defaults, and chain-derived args. Returns the merged list. -# @noRd # Split a merged argument list into the target's own formals plus a -# `methodArgs` remainder. Callers build one flat list (base args, capability -# defaults, user overrides); this routes each name to the right place, so a -# tool option reaches the tool and an unknown name errors at the call instead -# of vanishing. A target with no `methodArgs` formal gets the list unchanged. +# `methodArgs` remainder. Callers build one flat list (base args, user +# overrides); this routes each name to the right place, so a tool option +# reaches the tool and an unknown name errors at the call instead of +# vanishing. A target with no `methodArgs` formal gets the list unchanged. # @noRd .splitMethodArgs <- function(fn, args) { target <- match.fun(fn) @@ -1987,38 +2059,24 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # Wrap the remainder in the record the target's `methodArgs` expects, so a # target that demands a constructor gets one rather than the bare list it # would refuse. The constructor is read off the target's own default -- -# `methodArgs = MvsusieOptions()` names it -- so this needs no registry and -# cannot drift from the signature. A target still defaulting to `list()` -# gets the plain list. +# `methodArgs = MvsusieOptions()` names it, as every target's default does -- +# so this needs no registry and cannot drift from the signature. # @noRd .methodConfigLike <- function(target, extra) { d <- formals(target)$methodArgs - if (!is.call(d) || !is.name(d[[1L]])) { - return(extra) - } exec(match.fun(as.character(d[[1L]])), !!!extra) } -.fmMergeUserArgs <- function(baseArgs, token, userArgs = NULL) { - if (is.null(userArgs)) { - userArgs <- list() - } - info <- .fineMappingMethodCapabilities[[token]] - capDefaults <- if (!is.null(info) && !is.null(info$args)) { - info$args - } else { - list() - } - # Order matters: base < capability defaults < user overrides. - withCaps <- if (length(capDefaults) > 0L) { - list_modify(baseArgs, !!!compact(capDefaults)) - } else { - baseArgs - } +# Merge per-method user kwargs onto a base arg list. `userArgs` is the +# per-token kwargs supplied by the caller (e.g. `list(L = 1, refine = +# FALSE)`); user-supplied values always win over base and chain-derived +# args. Returns the merged list. +# @noRd +.fmMergeUserArgs <- function(baseArgs, userArgs = NULL) { if (length(userArgs) == 0L) { - return(withCaps) + return(baseArgs) } - list_modify(withCaps, !!!compact(userArgs)) + list_modify(baseArgs, !!!compact(userArgs)) } # .fmFitSusieIndiv / .fmFitSusieRss / .fmFitSusieSer (single SuSiE fits) now @@ -2028,13 +2086,13 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # GwasSumStats entry GRanges. Errors when Z or N is missing. Wraps the # shared `.entryToSumstatDf` helper (R/sumstatsQc.R). # @noRd -.fmExtractZn <- function(gr, label, ldSketch = NULL, cutoffs = NULL) { +.fmExtractZn <- function(gr, label, ldReference = NULL, cutoffs = NULL) { allDf <- .entryToSumstatDf(gr, require = c("SNP", "Z", "N"), label = label) # Filtered HERE rather than at the LD build: z, the LD matrix and the # allele frequencies are all keyed off `variantIds`, so narrowing the id # set at its source keeps them aligned by construction instead of by three # subsetting steps staying in step with one another. - keep <- .panelKeepMask(allDf$variant_id, ldSketch, cutoffs, label) + keep <- .panelKeepMask(allDf$variant_id, ldReference, cutoffs, label) df <- allDf[keep, , drop = FALSE] list( variantIds = df$variant_id, @@ -2101,13 +2159,9 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { str_remove(adapter$methodKey, "_weights$") } -# Coerce a weight vector to a single-column matrix (rows named by the vector's -# names); pass matrices through unchanged. +# A weight vector as a single-column matrix, rows named by the vector's names. # @noRd .fmAsMat <- function(w) { - if (is.matrix(w)) { - return(w) - } matrix(w, ncol = 1L, dimnames = list(names(w), NULL)) } @@ -2188,7 +2242,6 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # susie and mvsusie fold paths; L is left to susiF's default there too. fsArgs <- .fmMergeUserArgs( list(X = Xtr, Y = Ytr, pos = pos, covLev = coverage), - "fsusie", userArgs ) fit <- exec(fitFsusie, !!!.splitMethodArgs(fitFsusie, fsArgs)) @@ -2352,20 +2405,15 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # held-out samples into training and inflate the CV metrics. # @noRd .fmCvResult <- function(res) { - foldFits <- if (is.null(res$foldFits)) { - NULL - } else { - `attr<-`( - res$foldFits, - "partitionKey", - .cvPartitionKey(res$samplePartition) - ) - } list( samplePartition = res$samplePartition, prediction = res$prediction, performance = res$performance, - foldFits = foldFits + foldFits = `attr<-`( + res$foldFits, + "partitionKey", + .cvPartitionKey(res$samplePartition) + ) ) } @@ -2417,6 +2465,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) } + # ============================================================================= # Residualized genotype for one X window: the trait-derived cis block when # `rg` is NULL, else the explicit region. Shared by the univariate and PCA @@ -2429,7 +2478,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { samples, data, cisWindow, - residualizationArgs + residualizationParam ) { if (is.null(rg)) { .fmResidGeno( @@ -2438,7 +2487,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { traitId = traitId, cisWindow = cisWindow, samples = samples, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ) } else { .fmResidGeno( @@ -2446,7 +2495,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { contexts = ctx, region = rg, samples = samples, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ) } } @@ -2491,14 +2540,15 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { cfg$verbose, ctx, label, - cvFolds = cfg$crossValidationArgs$folds, - cvThreads = cfg$crossValidationArgs$numThreads, - samplePartition = cfg$crossValidationArgs$samplePartition, + cvFolds = cfg$crossValidationParam$folds, + cvThreads = cfg$crossValidationParam$numThreads, + samplePartition = cfg$crossValidationParam$samplePartition, af = afVec, credibleSetParam = cfg$credibleSetParam, fitRetention = cfg$fitRetention, seed = cfg$seed, - region = region + region = region, + fitFullData = cfg$crossValidationParam$fitFullData ) } @@ -2514,22 +2564,11 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { rownames(Y), data = cfg$data, cisWindow = cfg$cisWindow, - residualizationArgs = cfg$residualizationArgs + residualizationParam = cfg$residualizationParam ) - common <- intersect(rownames(allX), rownames(Y)) - if (length(common) < 2L) { - abort(glue( - "fineMappingPipeline: too few shared samples between ", - "residualized X and Y for (context='{ctx}', trait='{tid}')." - )) - } - X <- allX[common, , drop = FALSE] - yBlock <- Y[common, , drop = FALSE] - y <- if (ncol(yBlock) > 1L) { - yBlock[, 1L, drop = TRUE] - } else { - drop(yBlock) - } + xy <- .fmAlignXY(allX, Y, ctx, tid) + X <- xy$X + y <- xy$y if (!.fmSerScreen(X, y, cfg$screen)) { if (cfg$verbose >= 1) { inform(glue( @@ -2559,6 +2598,23 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) } +# Align the residualized genotype block to Y's samples; `y` is Y's one column, +# the trait's. Errors when fewer than two samples are shared. +# @noRd +.fmAlignXY <- function(allX, Y, ctx, tid) { + common <- intersect(rownames(allX), rownames(Y)) + if (length(common) < 2L) { + abort(glue( + "fineMappingPipeline: too few shared samples between ", + "residualized X and Y for (context='{ctx}', trait='{tid}')." + )) + } + list( + X = allX[common, , drop = FALSE], + y = drop(Y[common, , drop = FALSE]) + ) +} + # All univariate row-records for one (context, trait): cache hits, then (when # tokens remain) per-window fits merged per token. # @noRd @@ -2587,7 +2643,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { contexts = ctx, traitId = tid, naAction = cfg$naAction, - residualizationArgs = cfg$residualizationArgs + residualizationParam = cfg$residualizationParam ) blockEntries <- map( cfg$xRegions, @@ -2614,7 +2670,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { samples, data = cfg$data, cisWindow = cfg$cisWindow, - residualizationArgs = cfg$residualizationArgs + residualizationParam = cfg$residualizationParam ) common <- intersect(rownames(X), names(pcY)) if (length(common) < 2L) { @@ -2689,7 +2745,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { contexts = ctx, traitId = traits, naAction = cfg$naAction, - residualizationArgs = cfg$residualizationArgs + residualizationParam = cfg$residualizationParam ) scores <- .fmTopPcScores(Yctx, cfg$nPCs) if (is.null(scores)) { @@ -2716,54 +2772,50 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # QtlDataset method # ============================================================================= -# The settings every QtlDataset joint-phase function forwards to the shared -# joint dispatcher: the common fine-mapping record plus the scope and -# TWAS-weight fields only the joint engine uses. +# The record a QtlDataset run hands both its joint dispatch and its per-tuple +# dispatch, and that a MultiStudyQtlDataset run hands each individual-level +# component's joint dispatch. One builder, so a setting added for one path +# reaches the others: the per-study joint dispatch used to assemble its own +# record and lost six settings that way. `data` is the dataset after its +# per-call filter overrides; `screen` is the resolved signal screen. # @noRd -.fmQdsJointCfg <- function( - common, +.fmIndividualJointCfg <- function( + data, contexts, traitId, + cisWindow, + xRegions, + credibleSetParam, + crossValidationParam, + residualizationParam, + screen, + fineMappingResult, + fitRetention, + verbose, + seed, mrmashPrior, dataDrivenPriorWeightsCutoff ) { - c( - common, - list( - contexts = contexts, - traitId = traitId, - mrmashPrior = mrmashPrior, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff - ) + cvCfg <- .cvResolve(crossValidationParam) + list( + data = data, + contexts = contexts, + traitId = traitId, + cisWindow = cisWindow, + xRegions = xRegions, + credibleSetParam = credibleSetParam, + crossValidationParam = cvCfg, + residualizationParam = residualizationParam, + screen = screen, + fineMappingResult = .fmCacheForRun(fineMappingResult, cvCfg), + fitRetention = fitRetention, + verbose = verbose, + seed = seed, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff ) } -# Run the joint engine for a QtlDataset with the given spec + token set. Shared -# by the explicit-jointSpecification path and the auto-detected multivariate -# path; only the spec and token arguments differ between them. -# @noRd -.fmQdsJointDispatch <- function(jointSpec, tokens, methodArgs, cfg) { - .fmDispatchJointSpecsQtlDataset( - jointSpec, - cfg$data, - tokens, - cfg$contexts, - cfg$traitId, - cfg$cisWindow, - cfg$verbose, - methodArgs = methodArgs, - xRegions = cfg$xRegions, - mrmashPrior = cfg$mrmashPrior, - dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff, - crossValidationArgs = cfg$crossValidationArgs, - residualizationArgs = cfg$residualizationArgs, - pipCutoffToSkip = cfg$screen, - fineMappingResult = cfg$fineMappingResult, - credibleSetParam = cfg$credibleSetParam, - fitRetention = cfg$fitRetention, - seed = cfg$seed - ) -} # Resolve the signal screen, apply per-call filter overrides to a validated # copy of the dataset, and derive the X windows. Rejects the region + cisWindow @@ -2771,23 +2823,19 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # @noRd .fmQdsResolveInputs <- function( data, - signalScreenArgs, + signalScreenParam, genotypeFilterParam, region, cisWindow, jointRegions ) { - .assertMethodParam(signalScreenArgs, "SignalScreenParam", "signalScreen") - screen <- .screenResolve(signalScreenArgs) + screen <- .fmResolveScreen(signalScreenParam) data <- .qtlApplyFilterOverrides(data, genotypeFilterParam) - if (!is.null(region) && !is.null(cisWindow)) { - msg <- glue( - "fineMappingPipeline(QtlDataset): specify either `region` or ", - "`cisWindow`, not both. `cisWindow` expands each trait's own ", - "coordinates, whereas `region` is the literal variant window." - ) - abort(msg) - } + .rejectRegionWithCisWindow( + region, + cisWindow, + "fineMappingPipeline(QtlDataset)" + ) list( data = data, screen = screen, @@ -2795,8 +2843,13 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) } -# Normalize methods, capability-check them, then hand off to the joint phase. +# The signal screen a run applies, from its SignalScreenParam. # @noRd +.fmResolveScreen <- function(signalScreenParam) { + .assertMethodParam(signalScreenParam, "SignalScreenParam") + .screenResolve(signalScreenParam) +} + # The joint-specification phase for the QtlDataset path: dispatch whatever the # spec covers, narrow the tokens the joint fits consumed, and report whether # anything is left for the per-tuple loop. `done = TRUE` means the joint fits @@ -2816,7 +2869,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { methodArgs = norm$methodArgs )) } - jointResult <- .fmQdsJointDispatch( + jointResult <- .fmDispatchJointSpecsQtlDataset( parsedJointSpec, intersect(norm$tokens, c("mvsusie", "fsusie")), norm$methodArgs, @@ -2824,7 +2877,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) # The joint dispatch consumed the multivariate tokens; the univariate # phase runs on whatever is left. - narrowed <- .fmNarrowAfterJoint(TRUE, norm$tokens, norm$methodArgs) + narrowed <- .fmNarrowAfterJoint(norm$tokens, norm$methodArgs) if (length(narrowed$tokens) == 0L) { if (is.null(jointResult)) { abort(glue( @@ -2843,6 +2896,8 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) } +# Normalize methods, capability-check them, then hand off to the joint phase. +# @noRd .fmQdsResolveTokens <- function( jointSpecification, methods, @@ -2863,24 +2918,26 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { } # The tokens (and their args) still owed a univariate fit after a joint -# dispatch ran. A run with no joint specification keeps everything. +# dispatch ran: the joint fits consumed the multivariate ones. # @noRd -.fmNarrowAfterJoint <- function(hadJointSpec, tokens, methodArgs) { - if (!hadJointSpec) { - return(list(tokens = tokens, methodArgs = methodArgs)) - } +.fmNarrowAfterJoint <- function(tokens, methodArgs) { remaining <- setdiff(tokens, c("mvsusie", "fsusie")) list(tokens = remaining, methodArgs = methodArgs[remaining]) } -# Trait ids available in one context, intersected with the requested traitId or -# overlapping the requested region (mirrors twasWeightsPipeline). +# Trait ids available in one context: the ones `traitId` selects there, else +# those overlapping the requested region (mirrors twasWeightsPipeline). A +# `traitId` that leaves this context out keeps all of its traits -- region +# picks traits only when no traitId is given at all. # @noRd .fmQdsTraitsForContext <- function(ctx, data, traitId, region) { se <- molecularTraits(data, contexts = ctx) allIds <- rownames(se) ids <- if (!is.null(traitId)) { - intersect(allIds, traitId) + intersect( + allIds, + .selectedTraits(traitId, studyName(data), ctx) %||% allIds + ) } else if (!is.null(region)) { allIds[IRanges::overlapsAny( SummarizedExperiment::rowRanges(se), @@ -2892,26 +2949,13 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ids } -# Resolve the study, the contexts to use (validating any requested ones), and -# the per-context trait lists. Returns `p` extended with study / useCtx / -# perCtxTraits / nCtx / nTraits. +# Resolve the study, the contexts to use, and the per-context trait lists. +# `contexts` / `traitId` arrive parsed (parseContexts() / parseTraitIds()), +# which is where requested contexts were checked. Returns `p` extended with +# study / useCtx / perCtxTraits / nCtx / nTraits. # @noRd .fmQdsResolveContexts <- function(data, contexts, traitId, region) { - allCtx <- contexts(data) - useCtx <- if (is.null(contexts)) { - allCtx - } else { - bad <- setdiff(contexts, allCtx) - if (length(bad) > 0L) { - badStr <- str_flatten(bad, ", ") - msg <- glue( - "fineMappingPipeline(QtlDataset): unknown context(s): ", - "{badStr}" - ) - abort(msg) - } - contexts - } + useCtx <- .selectedContexts(contexts, studyName(data)) %||% contexts(data) perCtxTraits <- set_names( map( useCtx, @@ -2965,9 +3009,6 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) } -# Univariate + usePCA dispatch: each (context, trait) -> merged-per-token -# row-records; each multi-trait context's top PCs -> pseudo-trait rows. -# @noRd # The per-run settings the univariate / PCA row builders all need: the common # fine-mapping record plus the grid and method fields only the per-tuple # dispatch uses. The chain threads a single record instead of two dozen @@ -3002,6 +3043,9 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) } +# Univariate + usePCA dispatch: each (context, trait) -> merged-per-token +# row-records; each multi-trait context's top PCs -> pseudo-trait rows. +# @noRd .fmQdsDispatchRows <- function(cfg) { univRows <- if (length(cfg$univTokens) > 0L) { list_flatten(map(cfg$useCtx, .fmUnivContextRows, cfg = cfg)) @@ -3017,8 +3061,10 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { } # Multivariate dispatch via the joint engine (auto-detected shape) for -# mvsusie / fsusie WITHOUT an explicit jointSpecification, merged with any -# explicit-spec result already in `p$jointResult`. +# mvsusie / fsusie WITHOUT an explicit jointSpecification. An explicit spec +# consumes those tokens, so they reach here only when there was none: the +# explicit result, `jointResult`, is returned as it stands when no +# multivariate token is left, and is NULL otherwise. # @noRd .fmQdsAutoJoint <- function( cfg, @@ -3032,19 +3078,12 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { if (length(mvTokens) == 0L && length(fsTokens) == 0L) { return(jointResult) } - autoJoint <- .fmQdsJointDispatch( + .fmDispatchJointSpecsQtlDataset( .fmSynthesizeJointSpec(nCtx, nTraits), c(mvTokens, fsTokens), methodArgs, cfg ) - if (is.null(jointResult)) { - autoJoint - } else if (is.null(autoJoint)) { - jointResult - } else { - .rbindFineMappingResult(jointResult, autoJoint, ldSketch = NULL) - } } # Assemble the QtlDataset result from the per-tuple row-records (region = @@ -3079,7 +3118,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { cisWindow, length(rows) ), - ldSketch = NULL + ldReference = NULL ) } else { NULL @@ -3097,7 +3136,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { if (is.null(perTupleResult)) { return(jointResult) } - .rbindFineMappingResult(perTupleResult, jointResult, ldSketch = NULL) + .rbindFineMappingResult(perTupleResult, jointResult, ldReference = NULL) } # Resolve the context/trait tuples, split the tokens across the univariate, @@ -3107,9 +3146,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # to be read together. # @noRd .fmQdsRunAndAssemble <- function( - data, - commonCfg, - jointCfg, + cfg, contexts, traitId, region, @@ -3122,14 +3159,14 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { usePCA ) { ctxInfo <- .fmQdsResolveContexts( - data = data, + data = cfg$data, contexts = contexts, traitId = traitId, region = region ) split <- .fmQdsSplitTokens(tokens, ctxInfo$nCtx, ctxInfo$nTraits) rows <- .fmQdsDispatchRows(.fmQdsRunCfg( - commonCfg, + cfg, initializeWithSusieInf = initializeWithSusieInf, methodArgs = methodArgs, nPCs = nPCs, @@ -3141,12 +3178,12 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { usePCA = usePCA )) .fmQdsAssemble( - data, + cfg$data, rows, region = region, - cisWindow = commonCfg$cisWindow, + cisWindow = cfg$cisWindow, .fmQdsAutoJoint( - jointCfg, + cfg, mvTokens = split$mvTokens, fsTokens = split$fsTokens, jointResult = jointResult, @@ -3162,6 +3199,13 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # on a captured environment. The susieInf chaining is applied downstream # inside .fmFitXBlock / .fmFitRssBlock (which recompute # .fmResolveSusieChain), so no chain config is threaded here. +# +# `genotypeFilterParam` is a per-call override; NULL uses the QtlDataset's +# construct-time slot value (applied lazily at extraction). The +# CrossValidationParam bundle is the user-facing form; below it the cfg +# plumbing (and the joint engine that reads it) keeps plain scalars. +# `cfg` (.fmIndividualJointCfg()) holds the settings the joint phase and the +# per-tuple dispatch share, built once so the two cannot disagree. # @noRd .fmPipelineQtlDataset <- function( data, @@ -3170,17 +3214,15 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { traitId = NULL, region = NULL, cisWindow = NULL, - # Per-call genotype-filter overrides; NULL = use the QtlDataset's - # construct-time slot value (applied lazily at extraction). genotypeFilterParam = GenotypeFilterParam(), jointRegions = FALSE, jointSpecification = NULL, initializeWithSusieInf = TRUE, credibleSetParam = CredibleSetParam(), fineMappingResult = NULL, - crossValidationArgs = CrossValidationParam(), - residualizationArgs = ResidualizationParam(), - signalScreenArgs = SignalScreenParam(), + crossValidationParam = CrossValidationParam(), + residualizationParam = ResidualizationParam(), + signalScreenParam = SignalScreenParam(), usePCA = FALSE, nPCs = 10L, seed = NULL, @@ -3193,44 +3235,33 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) { fitRetention <- arg_match(fitRetention) naAction <- arg_match(naAction, c("drop", "impute")) + contexts <- parseContexts(contexts, data) + traitId <- parseTraitIds(traitId, data) if (!is.null(seed)) { withr::local_seed(as.integer(seed)) } - # Each stage returns only the values it derives; nothing is grafted onto a - # captured environment. resolved <- .fmQdsResolveInputs( data = data, - signalScreenArgs = signalScreenArgs, + signalScreenParam = signalScreenParam, genotypeFilterParam = genotypeFilterParam, region = region, cisWindow = cisWindow, jointRegions = jointRegions ) - data <- resolved$data - screen <- resolved$screen - xRegions <- resolved$xRegions - # The bundle is the user-facing form; below this line the existing cfg - # plumbing (and the joint engine that reads it) keeps plain scalars. - cvCfg <- .cvResolve(crossValidationArgs) - # The settings the joint phase and the per-tuple dispatch share, named - # once so the two records built from it cannot disagree. - commonCfg <- list( - data = data, + cfg <- .fmIndividualJointCfg( + data = resolved$data, + contexts = contexts, + traitId = traitId, cisWindow = cisWindow, + xRegions = resolved$xRegions, credibleSetParam = credibleSetParam, - screen = screen, - xRegions = xRegions, - crossValidationArgs = cvCfg, - residualizationArgs = residualizationArgs, + crossValidationParam = crossValidationParam, + residualizationParam = residualizationParam, + screen = resolved$screen, fineMappingResult = fineMappingResult, fitRetention = fitRetention, verbose = verbose, - seed = seed - ) - jointCfg <- .fmQdsJointCfg( - commonCfg, - contexts = contexts, - traitId = traitId, + seed = seed, mrmashPrior = mrmashPrior, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff ) @@ -3239,36 +3270,30 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { methods, credibleSetParam$maxNumSingleEffects %||% 10L, credibleSetParam$maxNumSingleEffectsGreedy, - jointCfg + cfg ) - if (rt$done) { - return(.fmRecordProvenance( - rt$result, - dataType, - "individual", - .qtlScaleResiduals(data, residualizationArgs) - )) + out <- if (rt$done) { + rt$result + } else { + .fmQdsRunAndAssemble( + cfg, + contexts = contexts, + traitId = traitId, + region = region, + tokens = rt$tokens, + methodArgs = rt$methodArgs, + jointResult = rt$result, + initializeWithSusieInf = initializeWithSusieInf, + nPCs = nPCs, + naAction = naAction, + usePCA = usePCA + ) } - out <- .fmQdsRunAndAssemble( - data, - commonCfg, - jointCfg, - contexts = contexts, - traitId = traitId, - region = region, - tokens = rt$tokens, - methodArgs = rt$methodArgs, - jointResult = rt$result, - initializeWithSusieInf = initializeWithSusieInf, - nPCs = nPCs, - naAction = naAction, - usePCA = usePCA - ) .fmRecordProvenance( out, dataType, "individual", - .qtlScaleResiduals(data, residualizationArgs) + .qtlScaleResiduals(cfg$data, residualizationParam) ) } @@ -3289,32 +3314,24 @@ setMethod( # Whether a MultiStudyQtlDataset's JOINT rows are on the standardized scale. # The per-call override settles it when given; otherwise the embedded studies' # own slots do, and a collection whose studies disagree gets NA rather than a -# guess. A sumstats-only collection is in standardized units regardless. +# guess. # @noRd -.fmMsScaleResiduals <- function(data, residualizationArgs) { - if (!is.null(residualizationArgs$scaleResiduals)) { - return(residualizationArgs$scaleResiduals) - } - if (identical(.fmMsDataSource(data), "sumstat")) { - return(TRUE) +.fmMsScaleResiduals <- function(data, residualizationParam) { + if (!is.null(residualizationParam$scaleResiduals)) { + return(residualizationParam$scaleResiduals) } perStudy <- unique(map_lgl(qtlDatasets(data), scaleResiduals)) if (length(perStudy) == 1L) perStudy else NA } -# The `data_source` a MultiStudyQtlDataset run can state for its JOINT rows. A -# joint fit spans the studies the specification selected, so when the -# collection holds both individual-level and summary-statistics studies there -# is no single answer and the column is left NA (and so dropped on export) -# rather than guessed. +# The `data_source` a MultiStudyQtlDataset run can state for its JOINT rows. +# A collection always holds individual-level studies (its validity requires +# one), and a joint fit spans the studies the specification selected, so when +# summary statistics sit alongside them there is no single answer and the +# column is left NA (and so dropped on export) rather than guessed. # @noRd .fmMsDataSource <- function(data) { - hasIndividual <- length(qtlDatasets(data)) > 0L - hasSumstats <- length(sumStats(data)) > 0L - if (hasIndividual && hasSumstats) { - return(NA_character_) - } - if (hasSumstats) "sumstat" else "individual" + if (length(sumStats(data)) > 0L) NA_character_ else "individual" } # Per-embedded-study fine-mapping worker for .multiStudyPipelineDriver: recurse @@ -3326,6 +3343,13 @@ setMethod( if (length(m) == 0L) { return(NULL) } + # `cfg` carries the parsed selection for every study; this study gets its + # own share, and a study with none of its contexts selected sits out. + s <- studyName(qd) + contexts <- .selectedContexts(cfg$contexts, s) + if (!is.null(contexts) && length(contexts) == 0L) { + return(NULL) + } # Every setting is named. `cfg` also carries panelFilterParam and # susieRssParam, # which belong to the summary-statistics path: a study's own genotypes @@ -3337,8 +3361,8 @@ setMethod( data = qd, methods = m, jointSpecification = NULL, - contexts = cfg$contexts, - traitId = cfg$traitId, + contexts = contexts, + traitId = .studyTraitIdArg(cfg$traitId, s), region = cfg$region, cisWindow = cfg$cisWindow, jointRegions = cfg$jointRegions, @@ -3346,11 +3370,11 @@ setMethod( credibleSetParam = cfg$credibleSetParam, fineMappingResult = cfg$fineMappingResult, verbose = cfg$verbose, - crossValidationArgs = cfg$crossValidationArgs, - residualizationArgs = cfg$residualizationArgs, + crossValidationParam = cfg$crossValidationParam, + residualizationParam = cfg$residualizationParam, seed = cfg$seed, naAction = cfg$naAction, - signalScreenArgs = cfg$signalScreenArgs, + signalScreenParam = cfg$signalScreenParam, genotypeFilterParam = cfg$genotypeFilterParam, usePCA = cfg$usePCA, nPCs = cfg$nPCs, @@ -3369,17 +3393,24 @@ setMethod( if (length(m) == 0L) { return(NULL) } + # The parsed selection is applied here, to the rows, so the recursion runs + # on what it keeps with nothing left to filter -- and rows it leaves out + # are not an error when another component holds the selected tuples. + keepRows <- .sumStatsRowsSelected(ss, cfg$contexts, cfg$traitId) + if (!any(keepRows)) { + return(NULL) + } # Summary statistics carry no genotypes and no per-study region # selection: the region is already baked into the input, and there is # nothing to residualize, screen, cross-validate or PCA. `cfg` carries # those settings for the individual-level sibling and they are not # forwarded here. fineMappingPipeline( - data = ss, + data = if (all(keepRows)) ss else ss[which(keepRows)], methods = m, jointSpecification = NULL, - contexts = cfg$contexts, - traitId = cfg$traitId, + contexts = NULL, + traitId = NULL, initializeWithSusieInf = cfg$initializeWithSusieInf, credibleSetParam = cfg$credibleSetParam, fineMappingResult = cfg$fineMappingResult, @@ -3393,42 +3424,6 @@ setMethod( ) } -# Validate the naAction choice and the region + cisWindow combination, then -# derive the X windows. Mirrors .fmQdsResolveInputs, minus the filter -# overrides the components apply themselves. -# @noRd -.fmMsResolveInputs <- function(naAction, region, cisWindow, jointRegions) { - if (!is.null(region) && !is.null(cisWindow)) { - msg <- glue( - "fineMappingPipeline(MultiStudyQtlDataset): specify either ", - "`region` or `cisWindow`, not both." - ) - abort(msg) - } - list( - naAction = arg_match(naAction, c("drop", "impute")), - xRegions = .makeXRegions(region, jointRegions) - ) -} - -# Run the joint engine for a MultiStudyQtlDataset with the given spec + token -# set. -# @noRd -.fmMsJointDispatch <- function(jointSpec, tokens, methodArgs, cfg) { - .fmDispatchJointSpecsMultiStudy( - jointSpec, - cfg$data, - tokens, - cfg$contexts, - cfg$traitId, - cfg$cisWindow, - cfg$verbose, - methodArgs = methodArgs, - xRegions = cfg$xRegions, - mrmashPrior = cfg$mrmashPrior, - dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff - ) -} # The joint-specification phase for the MultiStudyQtlDataset path: dispatch # whatever the spec covers, narrow the tokens the joint fits consumed, and @@ -3447,7 +3442,7 @@ setMethod( methodArgs = norm$methodArgs )) } - jointResult <- .fmMsJointDispatch( + jointResult <- .fmDispatchJointSpecsMultiStudy( parsedJointSpec, intersect(norm$tokens, c("mvsusie", "fsusie")), norm$methodArgs, @@ -3455,7 +3450,7 @@ setMethod( ) # The joint dispatch consumed the multivariate tokens; the univariate # phase runs on whatever is left. - narrowed <- .fmNarrowAfterJoint(TRUE, norm$tokens, norm$methodArgs) + narrowed <- .fmNarrowAfterJoint(norm$tokens, norm$methodArgs) if (length(narrowed$tokens) == 0L) { if (is.null(jointResult)) { abort(glue( @@ -3511,18 +3506,16 @@ setMethod( return(phase) } # The per-component recursion re-enters fineMappingPipeline through - # `methods=`, so a run with no joint spec forwards the caller's own - # spelling untouched rather than the normalized tokens. + # `methods=`: a run with no joint spec forwards the methods record whole, + # one with a spec the per-token args of the tokens its joint fits left. list( done = FALSE, result = phase$result, tokens = phase$tokens, methods = if (length(parsedJointSpec) == 0L) { methods - } else if (length(phase$methodArgs) > 0L) { - phase$methodArgs } else { - phase$tokens + phase$methodArgs } ) } @@ -3530,6 +3523,12 @@ setMethod( # MultiStudyQtlDataset fine-mapping worker. After resolving the explicit # joint spec it routes each remaining method to the components it supports, # via the shared multi-study driver. +# +# The joint rows' provenance is recorded here; each per-study recursion +# records its own, so both sides of the driver's rbind carry the same columns. +# The residualization hatch decides the joint rows' scale. `jointCfg` is one +# record of the settings the joint phase and the shared dispatcher both need, +# so each names them once. # @noRd .fmPipelineMultiStudy <- function( data, @@ -3547,9 +3546,9 @@ setMethod( fineMappingResult = NULL, mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, - crossValidationArgs = CrossValidationParam(), - residualizationArgs = ResidualizationParam(), - signalScreenArgs = SignalScreenParam(), + crossValidationParam = CrossValidationParam(), + residualizationParam = ResidualizationParam(), + signalScreenParam = SignalScreenParam(), susieRssParam = SusieRssParam(), usePCA = FALSE, nPCs = 10L, @@ -3560,23 +3559,44 @@ setMethod( dataType = NULL ) { fitRetention <- arg_match(fitRetention) - # The joint rows are recorded here; each per-study recursion records its - # own, so both sides of the driver's rbind carry the same columns. - inputs <- .fmMsResolveInputs(naAction, region, cisWindow, jointRegions) + inputs <- .msResolveInputs( + naAction, + region, + cisWindow, + jointRegions, + "fineMappingPipeline(MultiStudyQtlDataset)" + ) naAction <- inputs$naAction - # One record of the settings the joint phase and the shared dispatcher - # both need, so each names them once. - jointCfg <- list( - data = data, - contexts = contexts, - traitId = traitId, + if (!is.null(seed)) { + withr::local_seed(as.integer(seed)) + } + cfg <- list( + methods = methods, + contexts = parseContexts(contexts, data), + traitId = parseTraitIds(traitId, data), + region = region, cisWindow = cisWindow, + jointRegions = jointRegions, + initializeWithSusieInf = initializeWithSusieInf, credibleSetParam = credibleSetParam, + fineMappingResult = fineMappingResult, verbose = verbose, - xRegions = inputs$xRegions, + crossValidationParam = crossValidationParam, + residualizationParam = residualizationParam, + seed = seed, + naAction = naAction, + signalScreenParam = signalScreenParam, + genotypeFilterParam = genotypeFilterParam, + panelFilterParam = panelFilterParam, + susieRssParam = susieRssParam, + usePCA = usePCA, + nPCs = nPCs, + fitRetention = fitRetention, mrmashPrior = mrmashPrior, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + dataType = dataType ) + jointCfg <- .fmMsJointCfg(cfg, data, inputs$xRegions) rt <- .fmMsResolveTokens( jointSpecification, methods, @@ -3588,51 +3608,54 @@ setMethod( rt$result, dataType, .fmMsDataSource(data), - # A sumstats-only collection is in standardized units whatever the - # hatch says; otherwise the hatch decides. - .fmMsScaleResiduals(data, residualizationArgs) + .fmMsScaleResiduals(data, residualizationParam) ) if (rt$done) { return(jointResult) } - methods <- rt$methods .multiStudyPipelineDriver( data, jointResult, .fmPerStudy, .fmSumStats, - list( - methods = methods, - contexts = contexts, - traitId = traitId, - region = region, - cisWindow = cisWindow, - jointRegions = jointRegions, - initializeWithSusieInf = initializeWithSusieInf, - credibleSetParam = credibleSetParam, - fineMappingResult = fineMappingResult, - verbose = verbose, - crossValidationArgs = crossValidationArgs, - residualizationArgs = residualizationArgs, - seed = seed, - naAction = naAction, - signalScreenArgs = signalScreenArgs, - genotypeFilterParam = genotypeFilterParam, - panelFilterParam = panelFilterParam, - susieRssParam = susieRssParam, - usePCA = usePCA, - nPCs = nPCs, - fitRetention = fitRetention, - mrmashPrior = mrmashPrior, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, - dataType = dataType - ), + list_assign(cfg, methods = rt$methods), .rbindFineMappingResult, QtlFineMappingResult, "fineMappingPipeline" ) } +# The MultiStudyQtlDataset joint record, derived from the record the +# per-component recursion receives (`cfg`): the individual-level joint record +# its components' own QtlDataset runs build, plus the two filters the +# components apply. Deriving it, rather than re-listing the settings, is what +# keeps the per-study joint fits on exactly the settings of the per-study +# fits. +# @noRd +.fmMsJointCfg <- function(cfg, data, xRegions) { + list_assign( + .fmIndividualJointCfg( + data = data, + contexts = cfg$contexts, + traitId = cfg$traitId, + cisWindow = cfg$cisWindow, + xRegions = xRegions, + credibleSetParam = cfg$credibleSetParam, + crossValidationParam = cfg$crossValidationParam, + residualizationParam = cfg$residualizationParam, + screen = .fmResolveScreen(cfg$signalScreenParam), + fineMappingResult = cfg$fineMappingResult, + fitRetention = cfg$fitRetention, + verbose = cfg$verbose, + seed = cfg$seed, + mrmashPrior = cfg$mrmashPrior, + dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff + ), + genotypeFilterParam = cfg$genotypeFilterParam, + panelFilterParam = cfg$panelFilterParam + ) +} + #' @rdname fineMappingPipeline #' @export setMethod( @@ -3667,27 +3690,6 @@ setMethod( ) } -# Run the joint engine for a QtlSumStats with the given spec + token set. -# Shared by the explicit-jointSpecification path and the auto-detected -# cross-context path; only the spec and token arguments differ between them. -# @noRd -.fmQssJointDispatch <- function(jointSpec, tokens, methodArgs, cfg) { - .fmDispatchJointSpecsQtlSumStats( - jointSpec, - cfg$data, - tokens, - cfg$contexts, - cfg$traitId, - cfg$verbose, - methodArgs = methodArgs, - mrmashPrior = cfg$mrmashPrior, - dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff, - fineMappingResult = cfg$fineMappingResult, - credibleSetParam = cfg$credibleSetParam, - fitRetention = cfg$fitRetention, - panelFilterParam = cfg$panelFilterParam %||% PanelFilterParam() - ) -} # The joint-specification phase for the QtlSumStats path: dispatch whatever # the spec covers, narrow the tokens the joint fits consumed, and report @@ -3706,7 +3708,7 @@ setMethod( methodArgs = norm$methodArgs )) } - jointResult <- .fmQssJointDispatch( + jointResult <- .fmDispatchJointSpecsQtlSumStats( parsedJointSpec, intersect(norm$tokens, "mvsusie"), norm$methodArgs, @@ -3714,7 +3716,7 @@ setMethod( ) # The joint dispatch consumed the multivariate tokens; the univariate # phase runs on whatever is left. - narrowed <- .fmNarrowAfterJoint(TRUE, norm$tokens, norm$methodArgs) + narrowed <- .fmNarrowAfterJoint(norm$tokens, norm$methodArgs) if (length(narrowed$tokens) == 0L) { if (is.null(jointResult)) { abort(glue( @@ -3739,23 +3741,6 @@ setMethod( # input is individual-level or summary statistics, so each constructor checks # against BOTH, taken live from the capability table rather than transcribed. -# The engine(s) a fine-mapping token forwards to, from the capability table. -# @noRd -.fmMethodCallees <- function(token) { - info <- .fineMappingMethodCapabilities[[token]] - unique(compact(list(info$individualImpl, info$sumstatImpl))) -} - -# Shared body for the per-engine constructors: pecotmr keeps no defaults of -# its own here (they are seeded per run from `L` / `Lgreedy`), so everything -# the caller gives is checked against that ONE engine and carried through. -# -# One constructor per engine, not per token. A method whose two input paths -# run different engines gets one for each: checking the union instead would -# accept a susie_rss-only name on an individual-level run and then drop it, -# and mvsusie could not be checked at all, since mvsusie_rss takes `...` and -# a union containing it accepts anything. -# @noRd # Engine arguments pecotmr supplies itself, per engine, with where the caller # sets each one instead. Keyed on the engine rather than the token because one # engine serves several tokens, and derived from what the wrappers actually @@ -3764,6 +3749,20 @@ setMethod( # caller's `SusieOptions(L = 3)` is a valid susie formal that pecotmr then # overwrites (or, on the mvsusie path, that silently overwrites pecotmr's own # X / Y). +# +# Per-engine notes: +# - mvsusie: `residual_variance` is deliberately NOT owned, though the +# pipeline does pass it: the prior's V can be NULL, compact() then drops it +# from the base, and a user value is the only source left. Refusing it would +# close the only path -- the QggOptions(nit=) mistake. +# - mvsusie_rss: `L` does not reach it, but `coverage` does: the pipeline +# threads csCoverage() into fitMvsusieRss()'s own `coverage` formal, so this +# engine takes that one entry of csHome and not the rest. +# - fsusie: only what the pipeline ACTUALLY supplies. `prior`, `max_scale` and +# `max_SNP_EM` used to be listed because this row described the retired +# fsusieWrapper(), which passed them; the pipeline calls fitFsusie() and +# never did, so refusing them closed the only path to setting them at all -- +# the same trap as `residual_variance` above. # @noRd .fmOwnedEngineArgs <- function(callee) { fromData <- "supplied from the data by the pipeline" @@ -3789,10 +3788,6 @@ setMethod( set_names(rep(fromData, 2L), c("z", "n")), csHome["coverage"] ), - # `residual_variance` is deliberately NOT owned, though the pipeline - # does pass it: the prior's V can be NULL, compact() then drops it - # from the base, and a user value is the only source left. Refusing - # it would close the only path -- the QggOptions(nit=) mistake. "mvsusieR::mvsusie" = c( set_names( rep(fromData, 3L), @@ -3800,9 +3795,6 @@ setMethod( ), csHome ), - # `L` does not reach mvsusie_rss, but `coverage` does: the pipeline - # threads csCoverage() into fitMvsusieRss()'s own `coverage` formal, - # so this engine takes that one entry of csHome and not the rest. "mvsusieR::mvsusie_rss" = c( set_names( rep(fromData, 4L), @@ -3810,12 +3802,6 @@ setMethod( ), csHome["coverage"] ), - # Only what the pipeline ACTUALLY supplies. `prior`, `max_scale` and - # `max_SNP_EM` used to be listed here because this row described the - # retired fsusieWrapper(), which passed them; the pipeline calls - # fitFsusie() and never did, so refusing them closed the only path to - # setting them at all -- the same trap the `residual_variance` note - # above records. "fsusieR::susiF" = c( set_names(rep(fromData, 3L), c("X", "Y", "pos")), c( @@ -3828,6 +3814,16 @@ setMethod( ) } +# Shared body for the per-engine constructors: pecotmr keeps no defaults of +# its own here (they are seeded per run from `L` / `Lgreedy`), so everything +# the caller gives is checked against that ONE engine and carried through. +# +# One constructor per engine, not per token. A method whose two input paths +# run different engines gets one for each: checking the union instead would +# accept a susie_rss-only name on an individual-level run and then drop it, +# and mvsusie could not be checked at all, since mvsusie_rss takes `...` and +# a union containing it accepts anything. +# @noRd .fmMethodOptions <- function(callee, label, engine, extra) { .configRefuseOwned(extra, .fmOwnedEngineArgs(callee), label) .newMethodOptions( @@ -3839,11 +3835,6 @@ setMethod( ) } -# The union constructor behind a token, for splicing a PLAIN LIST in the -# aggregator. A plain list declares no engine and the run's input class is -# not known yet, so it must stay acceptable for either path; the per-input -# check in .fmCheckMethodArgsForInput narrows it once the class is known. -# @noRd #' @rdname FineMappingMethodsParam #' @aliases FineMappingMethodsParam-class #' @exportClass FineMappingMethodsParam @@ -3927,46 +3918,6 @@ FineMappingMethodsParam <- function( !identical(inputKind, "GwasSumStats") || isTRUE(info$gwasAllowed) } -# One method's Options constructor for ONE input path, validating against -# just that path's callee. -# -# Deliberately not the union of both callees: validating against the union -# would accept a name valid on only one of them -- `susie` takes 41 -# arguments on individual data and 49 on summary statistics, sharing 37, so -# the union admits 16 names that are wrong for whichever path actually runs. -# Once the caller knows its input class there is no reason to be that -# lenient. -# @noRd -.fmTokenPathConfig <- function(token, inputKind) { - force(token) - force(inputKind) - callee <- .fmMethodCalleeFor(token, inputKind) - if (is.null(callee)) { - return(NULL) - } - function(...) { - .newMethodOptions( - callee, - defaults = list(), - extra = list(...), - label = glue("method '{token}' on {inputKind}"), - engine = token - ) - } -} - -# Every method's constructor for one input path, omitting the methods that -# do not run on it -- `fsusie` has no summary-statistics implementation, -# `ser` no individual one. -# @noRd -.fmMethodCtorsFor <- function(inputKind) { - toks <- names(.fineMappingMethodCapabilities) - compact(set_names( - map(toks, .fmTokenPathConfig, inputKind = inputKind), - toks - )) -} - #' @title Arguments For A Fine-Mapping Engine #' @description Options forwarded to one fine-mapping engine, checked #' against that engine's live formals. @@ -4051,16 +4002,7 @@ NULL studyCol <- as.character(data$study) contextCol <- as.character(data$context) traitCol <- as.character(data$trait) - byContext <- if (is.null(contexts)) { - seq_len(nrow(data)) - } else { - which(is_in(contextCol, contexts)) - } - selRows <- if (is.null(traitId)) { - byContext - } else { - byContext[is_in(traitCol[byContext], traitId)] - } + selRows <- which(.sumStatsRowsSelected(data, contexts, traitId)) if (length(selRows) == 0L) { msg <- glue( "fineMappingPipeline(QtlSumStats): no entries matched the ", @@ -4106,26 +4048,21 @@ NULL } # Multivariate dispatch via the joint engine (auto-detected cross-context RSS -# joint) for mvsusie WITHOUT an explicit jointSpecification, merged with any -# explicit-spec result the joint phase already produced. +# joint) for mvsusie WITHOUT an explicit jointSpecification. An explicit spec +# consumes mvsusie, so it reaches here only when there was none: the explicit +# result, `jointResult`, is returned as it stands when no mvsusie is left, +# and is NULL otherwise. # @noRd -.fmQssAutoJoint <- function(cfg, mvTokens, methodArgs, jointResult, ldSketch) { +.fmQssAutoJoint <- function(cfg, mvTokens, methodArgs, jointResult) { if (length(mvTokens) == 0L) { return(jointResult) } - autoJoint <- .fmQssJointDispatch( + .fmDispatchJointSpecsQtlSumStats( list(list(axes = "context", scope = NULL)), mvTokens, methodArgs, cfg ) - if (is.null(jointResult)) { - autoJoint - } else if (is.null(autoJoint)) { - jointResult - } else { - .rbindFineMappingResult(jointResult, autoJoint, ldSketch = ldSketch) - } } # Assemble the QtlSumStats result: build the per-tuple QtlFineMappingResult @@ -4135,37 +4072,12 @@ NULL # @noRd .fmQssAssemble <- function( data, - ldSketch, + ldReference, rows, nSkipped, jointResult ) { - rowContext <- map_chr(rows, "context") - rowTrait <- map_chr(rows, "trait") - perTupleResult <- if (length(rows) > 0L) { - .fmBuildQtlResult( - map_chr(rows, "study"), - rowContext, - rowTrait, - map_chr(rows, "method"), - map(rows, "entry"), - traitPos = try_fetch( - .anchorVector(data, rowContext, rowTrait, "traitPos"), - error = function(cnd) NULL - ), - region = .fmRowWindows( - data, - rowContext, - rowTrait, - NULL, - NULL, - length(rows) - ), - ldSketch = ldSketch - ) - } else { - NULL - } + perTupleResult <- .fmQssPerTupleResult(data, rows, ldReference) if (is.null(jointResult)) { if (!is.null(perTupleResult)) { return(perTupleResult) @@ -4177,7 +4089,7 @@ NULL character(0), character(0), list(), - ldSketch = ldSketch, + ldReference = ldReference, allowEmpty = TRUE )) } @@ -4188,7 +4100,43 @@ NULL if (is.null(perTupleResult)) { return(jointResult) } - .rbindFineMappingResult(perTupleResult, jointResult, ldSketch = ldSketch) + .rbindFineMappingResult( + perTupleResult, + jointResult, + ldReference = ldReference + ) +} + +# The per-tuple QtlFineMappingResult from the collected row-records, or NULL +# when there are none. Each row's region is its entry's variant span (no +# cis-window). +# @noRd +.fmQssPerTupleResult <- function(data, rows, ldReference) { + if (length(rows) == 0L) { + return(NULL) + } + rowContext <- map_chr(rows, "context") + rowTrait <- map_chr(rows, "trait") + .fmBuildQtlResult( + map_chr(rows, "study"), + rowContext, + rowTrait, + map_chr(rows, "method"), + map(rows, "entry"), + traitPos = try_fetch( + .anchorVector(data, rowContext, rowTrait, "traitPos"), + error = function(cnd) NULL + ), + region = .fmRowWindows( + data, + rowContext, + rowTrait, + NULL, + NULL, + length(rows) + ), + ldReference = ldReference + ) } # The settings the joint phase and the RSS row builders share, named once @@ -4248,6 +4196,8 @@ NULL dataType = NULL ) { .fmAssertQcd(data) + contexts <- parseContexts(contexts, data) + traitId <- parseTraitIds(traitId, data) cfgs <- .fmQssConfigs( data = data, credibleSetParam = credibleSetParam, @@ -4260,23 +4210,17 @@ NULL mrmashPrior = mrmashPrior, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff ) - commonCfg <- cfgs$common - jointCfg <- cfgs$joint rt <- .fmQssResolveTokens( jointSpecification, methods, credibleSetParam$maxNumSingleEffects %||% 10L, credibleSetParam$maxNumSingleEffectsGreedy, - jointCfg + cfgs$joint ) - if (rt$done) { - return(.fmRecordProvenance(rt$result, dataType, "sumstat", TRUE)) - } out <- .fmQssAfterJoint( data, rt = rt, - commonCfg = commonCfg, - jointCfg = jointCfg, + cfgs = cfgs, contexts = contexts, traitId = traitId, initializeWithSusieInf = initializeWithSusieInf, @@ -4288,34 +4232,38 @@ NULL # Everything after the joint phase has had its say: select the rows the # univariate tokens run on, resolve the LD-finiteness setting against the # sketch, and fit. `rt` is .fmQssResolveTokens()'s record -- it carries the -# remaining tokens, their options, and whatever the joint phase produced. +# remaining tokens, their options, and whatever the joint phase produced; when +# the joint phase consumed every method (`rt$done`) its result is returned +# as is. `cfgs` is .fmQssConfigs()'s (common, joint) pair. # @noRd .fmQssAfterJoint <- function( data, rt, - commonCfg, - jointCfg, + cfgs, contexts, traitId, initializeWithSusieInf, susieRssParam ) { + if (rt$done) { + return(rt$result) + } sel <- .fmQssSelectRows(data = data, contexts = contexts, traitId = traitId) - ldSketch <- ldSketch(data) + ldReference <- ldReference(data) cfg <- .fmRssRunCfg( - commonCfg, - ldSketch = ldSketch, + cfgs$common, + ldReference = ldReference, initializeWithSusieInf = initializeWithSusieInf, methodArgs = rt$methodArgs, - susieRssParam = .fmRssArgsResolved(susieRssParam, ldSketch) + susieRssParam = .fmRssArgsResolved(susieRssParam, ldReference) ) .fmQssRunRows( data, sel = sel, split = .fmQssSplitTokens(rt$tokens, sel), cfg = cfg, - jointCfg = jointCfg, - ldSketch = ldSketch, + jointCfg = cfgs$joint, + ldReference = ldReference, methodArgs = rt$methodArgs, jointResult = rt$result ) @@ -4332,7 +4280,7 @@ NULL split, cfg, jointCfg, - ldSketch, + ldReference, methodArgs, jointResult ) { @@ -4351,15 +4299,14 @@ NULL } .fmQssAssemble( data = data, - ldSketch = ldSketch, + ldReference = ldReference, rows = list_flatten(map(univOut, "rows")), nSkipped = sum(map_lgl(univOut, "skipped")), jointResult = .fmQssAutoJoint( cfg = jointCfg, mvTokens = split$mvTokens, methodArgs = methodArgs, - jointResult = jointResult, - ldSketch = ldSketch + jointResult = jointResult ) ) } @@ -4384,13 +4331,13 @@ setMethod( fitRetention = c("slim", "full"), susieRssParam = SusieRssParam(), panelFilterParam = PanelFilterParam(), - crossValidationArgs = CrossValidationParam(), - residualizationArgs = ResidualizationParam(), + crossValidationParam = CrossValidationParam(), + residualizationParam = ResidualizationParam(), dataType = NULL ) { fitRetention <- arg_match(fitRetention) .cvRefuseOnSumstats( - crossValidationArgs, + crossValidationParam, "fineMappingPipeline", "QtlSumStats" ) @@ -4418,22 +4365,17 @@ setMethod( # GwasSumStats method # ============================================================================= -# Default the finite-sample LD reference size when an EB / SER-fallback LD- -# mismatch mode is active (serFallback on, or rMismatch other than "none") and -# rFinite is unset: use the LD-panel sample size (the notebook's `B`). Shared by -# the QtlSumStats and GwasSumStats workers. -# @noRd # The resolved record, still a SusieRssParam. Previously the resolved value was # carried alongside the record as a second cfg field and spliced in with # list_assign(as.list(...)) at the point of use, which handed everything # downstream a bare list exactly where the value became concrete. # @noRd -.fmRssArgsResolved <- function(susieRssParam, ldSketch) { +.fmRssArgsResolved <- function(susieRssParam, ldReference) { resolved <- .fmResolveRFinite( susieRssParam$rFinite, susieRssParam$serFallback, susieRssParam$rMismatch, - ldSketch + ldReference ) if (identical(resolved, susieRssParam$rFinite)) { return(susieRssParam) @@ -4441,15 +4383,29 @@ setMethod( .rssParamWithRFinite(susieRssParam, resolved) } -.fmResolveRFinite <- function(rFinite, serFallback, rMismatch, ldSketch) { +# Default the finite-sample LD reference size when an EB / SER-fallback LD- +# mismatch mode is active (serFallback on, or rMismatch other than "none") and +# rFinite is unset: use the LD-panel sample size (the notebook's `B`), or the +# size an LdMatrix records. Shared by the QtlSumStats and GwasSumStats workers. +# @noRd +.fmResolveRFinite <- function(rFinite, serFallback, rMismatch, ldReference) { if ( - is.null(rFinite) && - (isTRUE(serFallback) || !identical(rMismatch, "none")) + !is.null(rFinite) || + (!isTRUE(serFallback) && identical(rMismatch, "none")) ) { - .ldSketchNSamples(ldSketch) - } else { - rFinite + return(rFinite) + } + n <- .ldRefNSamples(ldReference) + if (is.na(n)) { + abort(c( + str_c( + "The finite-reference LD mismatch model needs the LD ", + "reference's size." + ), + i = "Set `rFinite`, or record it with LdMatrix(nSamples = )." + )) } + n } # GwasSumStats fine-mapping worker. The resolved tokens, LD sketch and @@ -4479,11 +4435,11 @@ setMethod( ) .fmCheckMethodCapabilities(norm$tokens, "GwasSumStats") .fmCheckMethodArgsForInput(norm$methodArgs, "GwasSumStats") - ldSketch <- ldSketch(data) + ldReference <- ldReference(data) # Derived values are ordinary locals now, not fields grafted onto a bundle. tokens <- norm$tokens methodArgs <- norm$methodArgs - susieRssParam <- .fmRssArgsResolved(susieRssParam, ldSketch) + susieRssParam <- .fmRssArgsResolved(susieRssParam, ldReference) studyCol <- as.character(data$study) commonCfg <- .fmSsCommonCfg( data = data, @@ -4498,7 +4454,7 @@ setMethod( studyCol = studyCol, tokens = tokens, commonCfg = commonCfg, - ldSketch = ldSketch, + ldReference = ldReference, initializeWithSusieInf = initializeWithSusieInf, methodArgs = methodArgs, susieRssParam = susieRssParam @@ -4513,7 +4469,7 @@ setMethod( studyCol, tokens, commonCfg, - ldSketch, + ldReference, initializeWithSusieInf, methodArgs, susieRssParam @@ -4525,7 +4481,7 @@ setMethod( tokens = tokens, cfg = .fmRssRunCfg( commonCfg, - ldSketch = ldSketch, + ldReference = ldReference, initializeWithSusieInf = initializeWithSusieInf, methodArgs = methodArgs, susieRssParam = susieRssParam @@ -4544,7 +4500,7 @@ setMethod( # the same window .fmRssFitWindow() gives the per-row grange columns, # so the two cannot disagree. region = .fmGwasRowWindows(rows), - ldSketch = ldSketch, + ldReference = ldReference, allowEmpty = (nSkipped > 0L || nrow(data) == 0L) ) } @@ -4564,13 +4520,13 @@ setMethod( fitRetention = c("slim", "full"), susieRssParam = SusieRssParam(), panelFilterParam = PanelFilterParam(), - crossValidationArgs = CrossValidationParam(), - residualizationArgs = ResidualizationParam(), + crossValidationParam = CrossValidationParam(), + residualizationParam = ResidualizationParam(), dataType = NULL ) { fitRetention <- arg_match(fitRetention) .cvRefuseOnSumstats( - crossValidationArgs, + crossValidationParam, "fineMappingPipeline", "GwasSumStats" ) @@ -4754,93 +4710,6 @@ setMethod( # see colocPipeline(), crossValidation() and fineMappingPipeline(). # ============================================================================= -# --- CredibleSetParam accessors -------------------------------------------- -# Setters revalidate: slot assignment checks the declared type on its own but -# does not re-run a validity method, and this package does write those (see -# SignalScreenParam). - -#' @rdname CredibleSetParam -setMethod("csCoverage", "CredibleSetParam", function(x) x@coverage) - -#' @rdname CredibleSetParam -setReplaceMethod("csCoverage", "CredibleSetParam", function(x, value) { - x@coverage <- value - validObject(x) - x -}) - -#' @rdname CredibleSetParam -setMethod("secondaryCoverage", "CredibleSetParam", function(x) { - x@secondaryCoverage -}) - -#' @rdname CredibleSetParam -setReplaceMethod("secondaryCoverage", "CredibleSetParam", function(x, value) { - x@secondaryCoverage <- value - validObject(x) - x -}) - -#' @rdname CredibleSetParam -setMethod("signalCutoff", "CredibleSetParam", function(x) x@signalCutoff) - -#' @rdname CredibleSetParam -setReplaceMethod("signalCutoff", "CredibleSetParam", function(x, value) { - x@signalCutoff <- value - validObject(x) - x -}) - -#' @rdname CredibleSetParam -setMethod("minAbsCorr", "CredibleSetParam", function(x) x@minAbsCorr) - -#' @rdname CredibleSetParam -setReplaceMethod("minAbsCorr", "CredibleSetParam", function(x, value) { - x@minAbsCorr <- value - validObject(x) - x -}) - -#' @rdname CredibleSetParam -setMethod("medianAbsCorr", "CredibleSetParam", function(x) x@medianAbsCorr) - -#' @rdname CredibleSetParam -setReplaceMethod("medianAbsCorr", "CredibleSetParam", function(x, value) { - x@medianAbsCorr <- value - validObject(x) - x -}) - -#' @rdname CredibleSetParam -setMethod("includeAllCs", "CredibleSetParam", function(x) x@includeAllCs) - -#' @rdname CredibleSetParam -setReplaceMethod("includeAllCs", "CredibleSetParam", function(x, value) { - x@includeAllCs <- value - validObject(x) - x -}) - -#' @rdname CredibleSetParam -setMethod("perCsColumns", "CredibleSetParam", function(x) x@perCsColumns) - -#' @rdname CredibleSetParam -setReplaceMethod("perCsColumns", "CredibleSetParam", function(x, value) { - x@perCsColumns <- value - validObject(x) - x -}) - -#' @rdname CredibleSetParam -setMethod("maxNumSingleEffects", "CredibleSetParam", function(x) { - x@maxNumSingleEffects -}) - -#' @rdname CredibleSetParam -setMethod("maxNumSingleEffectsGreedy", "CredibleSetParam", function(x) { - x@maxNumSingleEffectsGreedy -}) - #' @rdname SignalScreenParam #' @aliases SignalScreenParam-class #' @exportClass SignalScreenParam @@ -5131,6 +5000,93 @@ CredibleSetParam <- function( ) } +# --- CredibleSetParam accessors -------------------------------------------- +# Setters revalidate: slot assignment checks the declared type on its own but +# does not re-run a validity method, and this package does write those (see +# SignalScreenParam). + +#' @rdname CredibleSetParam +setMethod("csCoverage", "CredibleSetParam", function(x) x@coverage) + +#' @rdname CredibleSetParam +setReplaceMethod("csCoverage", "CredibleSetParam", function(x, value) { + x@coverage <- value + validObject(x) + x +}) + +#' @rdname CredibleSetParam +setMethod("secondaryCoverage", "CredibleSetParam", function(x) { + x@secondaryCoverage +}) + +#' @rdname CredibleSetParam +setReplaceMethod("secondaryCoverage", "CredibleSetParam", function(x, value) { + x@secondaryCoverage <- value + validObject(x) + x +}) + +#' @rdname CredibleSetParam +setMethod("signalCutoff", "CredibleSetParam", function(x) x@signalCutoff) + +#' @rdname CredibleSetParam +setReplaceMethod("signalCutoff", "CredibleSetParam", function(x, value) { + x@signalCutoff <- value + validObject(x) + x +}) + +#' @rdname CredibleSetParam +setMethod("minAbsCorr", "CredibleSetParam", function(x) x@minAbsCorr) + +#' @rdname CredibleSetParam +setReplaceMethod("minAbsCorr", "CredibleSetParam", function(x, value) { + x@minAbsCorr <- value + validObject(x) + x +}) + +#' @rdname CredibleSetParam +setMethod("medianAbsCorr", "CredibleSetParam", function(x) x@medianAbsCorr) + +#' @rdname CredibleSetParam +setReplaceMethod("medianAbsCorr", "CredibleSetParam", function(x, value) { + x@medianAbsCorr <- value + validObject(x) + x +}) + +#' @rdname CredibleSetParam +setMethod("includeAllCs", "CredibleSetParam", function(x) x@includeAllCs) + +#' @rdname CredibleSetParam +setReplaceMethod("includeAllCs", "CredibleSetParam", function(x, value) { + x@includeAllCs <- value + validObject(x) + x +}) + +#' @rdname CredibleSetParam +setMethod("perCsColumns", "CredibleSetParam", function(x) x@perCsColumns) + +#' @rdname CredibleSetParam +setReplaceMethod("perCsColumns", "CredibleSetParam", function(x, value) { + x@perCsColumns <- value + validObject(x) + x +}) + +#' @rdname CredibleSetParam +setMethod("maxNumSingleEffects", "CredibleSetParam", function(x) { + x@maxNumSingleEffects +}) + +#' @rdname CredibleSetParam +setMethod("maxNumSingleEffectsGreedy", "CredibleSetParam", function(x) { + x@maxNumSingleEffectsGreedy +}) + #' @rdname SusieRssParam #' @aliases SusieRssParam-class #' @exportClass SusieRssParam diff --git a/R/fineMappingRow.R b/R/fineMappingRow.R index e70c541b6..793f7681f 100644 --- a/R/fineMappingRow.R +++ b/R/fineMappingRow.R @@ -2,10 +2,10 @@ # FineMappingRow S4 class # ----------------------------------------------------------------------------- # One row's fine-mapping payload: the variants (with topLoci as their metadata -# columns) plus the stored fit. This is what a FineMappingResult collection is +# columns) plus the stored fit. This is what a fine-mapping result collection is # built FROM and what its per-row views are computed OVER. # -# It replaces the retired FineMappingRow, but is a different object in the +# It replaces the retired FineMappingEntry, but is a different object in the # two ways that made that class expensive: # # * It is NOT a dispatch target. The per-row views (.fmrRowTopLoci, .fmrRowCs, @@ -123,6 +123,20 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { obj } +# The row a cross-validation-only fit leaves (CrossValidationParam(fitFullData = +# FALSE)): no variants, no fit, no top loci -- only the cross-validation result +# attached afterwards. The writers refuse such rows (.fmbIncompleteRows()), and +# a resume cache only reuses them for another cross-validation-only run. +# @noRd +.fmCvOnlyRow <- function(cvResult = NULL) { + fineMappingRow( + variantIds = character(0), + susieFit = NULL, + topLoci = tibble(), + cvResult = cvResult + ) +} + # Attach topLoci's payload columns to the variant GRanges, keeping the # identity columns `.variantIdsToGRanges()` already put in mcols. Replacing # mcols wholesale would drop those, and the variant ids could no longer be @@ -162,40 +176,6 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { } -# ---- FineMappingRow validity helpers ------------------------------------- - -# Full validity check: collect all contract violations (empty vector = valid). -# @noRd - -# cvResult must be NULL or a list. -# @noRd - -# topLoci contract checks (only meaningful when topLoci has rows). -# @noRd - -# Minimal column contract: variant_id + pip. Canonical projector columns -# (marginal_*, posterior_*, ...) are pipeline-populated; skeletal entries may -# omit them (accessor projections then return NA-filled cols). -# @noRd - -# topLoci row count must match variantIds length. -# @noRd - -# topLoci$variant_id must equal variantIds in order. -# -# Still earns its place after the migration. The collection stores topLoci AS -# the element's inner mcols, where alignment is definitional -- but the entry -# VIEW keeps `variantIds` and `topLoci` in separate slots, and -# .fmeEntryToGRanges() builds the range from the former while taking mcols -# positionally from the latter. Without this check a misaligned entry would -# convert into silently mis-assigned mcols. It becomes deletable only if the -# entry stops carrying the two separately. -# @noRd - -# Drift check: a susieFit$pip vector must match the topLoci pip column. Catches -# adjustPips() (or any mutator) updating one and forgetting the other. -# @noRd - # ---- fSuSiE credible-band / affected-region helpers -------------------- .isFsusieFit <- function(fit) { @@ -359,14 +339,6 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { bind_rows(parts) } -# Map each fit-effect index (1..L, as affected_reg's `CS`) to pecotmr's -# canonical CS label + purity. The raw fSuSiE fit stores no purity (fsusieR -# computes it from the genotype matrix, which the fit does not retain), so the -# canonical value is `cs_95_purity` in the entry's topLoci. Matching is by the -# CS's variant -# MEMBERSHIP (not by index), which is robust to pecotmr's CS -# filtering/renumbering. -# @noRd # One fit effect's variant ids, resolving positional membership through the # fit's own variant order. # @noRd @@ -397,6 +369,13 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { as.numeric(topLoci$cs_95_purity[topLoci$cs_95 == lab][1]) } +# Map each fit-effect index (1..L, as affected_reg's `CS`) to pecotmr's +# canonical CS label + purity. The raw fSuSiE fit stores no purity (fsusieR +# computes it from the genotype matrix, which the fit does not retain), so the +# canonical value is `cs_95_purity` in the entry's topLoci. Matching is by the +# CS's variant MEMBERSHIP (not by index), which is robust to pecotmr's CS +# filtering/renumbering. +# @noRd .fsusieCsMapFromTopLoci <- function(fit, topLoci) { L <- length(fit$cs) defaultLabel <- set_names(str_c("fsusie_", seq_len(L)), seq_len(L)) @@ -645,7 +624,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { m <- filter(tl, !is.na(.data[[csCol]]) & .data[[csCol]] == lab) list( ids = as.character(m$variant_id), - eff = suppressWarnings(as.integer(str_remove(lab, "^.*_"))), + eff = .csLabelIndex(lab), lab = lab ) } @@ -1453,6 +1432,12 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # the two views silently joinable into a mix of the two quantities. posterior_effect = .tlCol(tl, "posterior_mean", "numeric"), posterior_se = .tlCol(tl, "posterior_sd", "numeric"), + # The infinitesimal part of `posterior_effect`, on the same scale. + # susieInf / susieAsh split their posterior into a sparse and an + # infinitesimal term and coef.susie() sums them, so the published + # effect is correct for those methods either way -- `theta` is what + # makes the split visible. Zero where the method has no such term. + theta = .tlCol(tl, "posterior_theta", "numeric"), pip = .tlCol(tl, "pip", "numeric"), logBF = .tlCol(tl, "logBF", "numeric") ) @@ -1478,6 +1463,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { af = numeric(0), posterior_effect = numeric(0), posterior_se = numeric(0), + theta = numeric(0), pip = numeric(0), logBF = numeric(0) ) @@ -1576,22 +1562,6 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # @noRd .fmeIdentityCols <- c("variant_id", "chrom", "pos", "A1", "A2") -# Every `entry` must be a FineMappingRow. Checked before the payload is -# unpacked, so a wrong type names itself rather than failing as a missing -# method on whatever was passed instead. -# @noRd - -# One entry -> its element. -# @noRd - -# The entry view for a collection row (or rows). A tuple split across -# chromosomes owns several elements; they are stitched back into the single -# entry callers expect, the same contract sumStats() keeps. -# @noRd - -# One element (plus its outer-mcols payload) -> the entry view. -# @noRd - # Rebuild the canonical topLoci table from an element: the identity columns are # re-rendered from the range and alleles, the rest come straight from mcols. # @noRd diff --git a/R/fineMappingWrappers.R b/R/fineMappingWrappers.R index 9c01a6f9a..5898fa864 100644 --- a/R/fineMappingWrappers.R +++ b/R/fineMappingWrappers.R @@ -293,7 +293,7 @@ fitSusieInfThenSusie <- function( #' @param fitRetention How much of each fit is kept: \code{"slim"} (default) #' trims the retained fit to what downstream needs, \code{"full"} keeps the #' whole fit object. The \code{topLoci} table's per-credible-set columns -#' are governed by \code{credibleSet}'s \code{perCsColumns} instead. +#' are governed by \code{credibleSetParam}'s \code{perCsColumns} instead. #' @param otherQuantities Optional named list of extra per-method quantities to #' carry on the result untouched (returned as the \code{otherQuantities} #' element). Default \code{NULL}. @@ -771,6 +771,8 @@ extractVariantNames <- function(fit) { normalizeVariantId(variantNames) } +#' @importFrom susieR univariate_regression +#' @noRd extractSumstats <- function( dataX, dataY, @@ -973,7 +975,8 @@ computeCsTable <- function( # fSuSiE credible sets: purity is the min |correlation| WITHIN each CS # (fsusieR::cal_purity), recorded as sets$purity$min.abs.corr for the canonical -# .csPurityVec() reader; cs_corr keeps the BETWEEN-CS correlation matrix. +# .csPurityVec() reader. The correlation BETWEEN sets is not kept; +# computeCsCorrelation() derives it from an LD source on demand. .csTableFsusie <- function(fit, dataX, coverage) { sets <- try_fetch( fsusieGetCs(fit, dataX, requestedCoverage = coverage), @@ -1009,7 +1012,15 @@ computeCsTable <- function( # X vs Xcorr only changes how susie_get_cs computes purity; the between-CS # correlation is derived on demand later by computeCsCorrelation(), so it is # no longer stored on the fit. - ldArg <- if (csInput == "X") list(X = dataX) else list(Xcorr = dataX) + ldArg <- if (csInput == "Xcorr") { + list(Xcorr = dataX) + } else if (inherits(fit, "susieRss")) { + # An RSS fit's X is its LD reference's factor, standing in for the + # matrix, so its purity must be the matrix route's: never subsampled. + list(X = dataX, n_purity = Inf) + } else { + list(X = dataX) + } sets <- exec(susie_get_cs, !!!c(list(fit), csArgs, ldArg)) list(sets = sets, pip = fit$pip) } @@ -1020,9 +1031,43 @@ computeCsTable <- function( # fit. get_cs_correlation() needs only the CS membership + PIP + the LD, with # the LD columns/rows ALIGNED to the fit's variable order (variantIds). +# A fit's credible sets: a susie fit keeps them in sets$cs, an fSuSiE fit +# (class "susiF") in cs. Reading only the first made every fSuSiE fit look +# set-less, so its between-CS correlation was never computed. +# @noRd +.csSetsOf <- function(fit) { + if (inherits(fit, "susiF")) fit$cs else fit$sets$cs +} + # TRUE when the fit has fewer than two credible sets (no between-CS corr). .csCountBelowTwo <- function(fit) { - is.null(fit$sets) || is.null(fit$sets$cs) || length(fit$sets$cs) < 2L + length(.csSetsOf(fit)) < 2L +} + +# An fSuSiE fit's between-CS correlation as fsusieR::cal_cor_cs() defines it +# -- for each pair of sets, the largest correlation between a member of one +# and a member of the other, so 1 on the diagonal -- read from the LD among +# the sets' members alone. +# @noRd +.fsusieCsCorrelationLd <- function(cs, ldReference, ids, label) { + members <- sort(unique(as.integer(list_c(cs)))) + R <- .ldFromRef(ldReference, ids[members], label, onMissing = "error") + sets <- map(cs, match, table = members) + n <- length(cs) + values <- map2_dbl( + rep(seq_len(n), times = n), + rep(seq_len(n), each = n), + .csPairMaxCorrelation, + sets = sets, + R = R + ) + matrix(values, n, n) +} + +# The largest correlation between a member of set `l` and one of set `k`. +# @noRd +.csPairMaxCorrelation <- function(l, k, sets, R) { + max(R[sets[[l]], sets[[k]]]) } # GRanges spanning the fit's variants (parsed from chrom:pos in the ids). @@ -1058,6 +1103,7 @@ computeCsTable <- function( } #' @rdname computeCsCorrelation +#' @importFrom purrr map2_dbl setMethod( "computeCsCorrelation", signature(x = "FineMappingResultBase", ldSource = "SumStatsBase"), @@ -1073,22 +1119,29 @@ setMethod( if (.csCountBelowTwo(fit)) { return(NULL) } - ldSketch <- ldSketch(ldSource) - if (is.null(ldSketch)) { + ldReference <- ldReference(ldSource) + if (is.null(ldReference)) { abort(glue( "computeCsCorrelation(): the summary-statistics ldSource ", - "carries no LD sketch to derive the correlation from." + "carries no LD reference to derive the correlation from." )) } # onMissing = "error": every fit variant must be in the panel, else the # 1..p sets$cs indices would misalign with a shrunken LD matrix. - xcorr <- .ldFromSketch( - ldSketch, - .fmrPartsVariantIds(parts), - label = "computeCsCorrelation", - onMissing = "error" - ) - get_cs_correlation(list(sets = fit$sets, pip = fit$pip), Xcorr = xcorr) + ids <- .fmrPartsVariantIds(parts) + label <- "computeCsCorrelation" + if (inherits(fit, "susiF")) { + return(.fsusieCsCorrelationLd(fit$cs, ldReference, ids, label)) + } + csFit <- list(sets = fit$sets, pip = fit$pip) + if (!.ldIsGenotypeRef(ldReference)) { + xcorr <- .ldFromRef(ldReference, ids, label, onMissing = "error") + return(get_cs_correlation(csFit, Xcorr = xcorr)) + } + # A genotype reference's factor: get_cs_correlation() correlates only + # the credible sets' lead columns of it, never forming the p x p LD. + factor <- .ldFactorFromRef(ldReference, ids, label, onMissing = "error") + get_cs_correlation(csFit, X = factor) } } @@ -1780,12 +1833,19 @@ buildTopLoci <- function( mu <- .fmSliceCond(fit$mu, conditionIdx) mu2 <- .fmSliceCond(fit$mu2, conditionIdx) scaleFactors <- .btlScaleFactors(fit, nV) + infinitesimal <- .btlInfinitesimal(fit, nV) meanStd <- if (!is.null(mu) && all(dim(alpha) == dim(mu))) { - colSums(alpha * mu) + .btlInfinitesimal(fit, nV) + colSums(alpha * mu) + infinitesimal } else { rep(NA_real_, nV) } postMean <- meanStd / scaleFactors + # Reported on the SAME scale as postMean, because that is the question it + # answers: how much of the published weight is the infinitesimal term + # rather than the sparse one. The sum is already inside postMean -- this + # only lets a reader see the split, which is otherwise unrecoverable. + # Zero for every method that has no infinitesimal component. + postTheta <- infinitesimal / scaleFactors postSd <- if (!is.null(mu2) && all(dim(alpha) == dim(mu2))) { # From the STANDARDIZED mean, then rescaled: an SD rescales the same # way its mean does, but the mu2 identity only holds in the units mu2 @@ -1810,6 +1870,7 @@ buildTopLoci <- function( mu2 = mu2, postMean = postMean, postSd = postSd, + postTheta = postTheta, logBF = logBF ) } @@ -2014,9 +2075,6 @@ buildTopLoci <- function( list_c(pieces) } -# One credible set's conditional-lfsr values, or NULL when its effect is out -# of range or it covers no in-range variant. -# @noRd # The conditional lfsr of a univariate susie fit, which reports none. # # It has everything needed to compute one: the single-effect posterior for @@ -2049,6 +2107,9 @@ buildTopLoci <- function( array(lfsr, dim = c(dim(mu), 1L)) } +# One credible set's conditional-lfsr values, or NULL when its effect is out +# of range or it covers no in-range variant. +# @noRd .btlCondLfsrForSet <- function( csPos, setsPrim, @@ -2190,6 +2251,7 @@ buildTopLoci <- function( pip = as.numeric(fit$pip), posterior_mean = unname(post$postMean), posterior_sd = unname(post$postSd), + posterior_theta = unname(post$postTheta), logBF = unname(post$logBF) ) meta <- tibble( @@ -2229,6 +2291,7 @@ buildTopLoci <- function( pip = numeric(), posterior_mean = numeric(), posterior_sd = numeric(), + posterior_theta = numeric(), logBF = numeric(), cs_95 = character(), cs_70 = character(), @@ -2438,7 +2501,7 @@ trimFinemappingFit <- function(fit, effectIdx, method, csTables) { #' Promotes the primary method's per-method post-processing payload to the root #' level and attaches the unified \code{top_loci} table. The primary method's #' bare \code{FineMappingRow} appears at \code{$finemappingEntry}; wrap it -#' into a \code{FineMappingResult} collection at the pipeline level once (study, +#' into a fine-mapping result collection at the pipeline level once (study, #' context, trait, method) identity tags are known. #' #' @param post Output from \code{\link{postprocessFinemappingFits}}. @@ -2503,28 +2566,6 @@ csInfo <- function(susieOutputSetsCs, topVariantsIdx) { ) bind_rows(rows) } -#' @title Calculate Purity Measures for Credible Sets -#' -#' @description As an extension of the internal cal_purity function. This -#' function computes purity metrics (minimum, mean, and median absolute -#' correlations) for each credible set in a list of credible set indices, -#' based on the provided X matrix. The output Purity depends on the method -#' specified: for the 'min' method, it returns a single value for -#' single-element sets or the minimum absolute correlation for others. For -#' other methods, it returns a vector of three values (min, mean, median) for -#' each set. -#' -#' @param lCs A list of credible set indices, where each element is a vector of -#' indices corresponding to variables in a credible set. -#' @param X The data matrix used to compute correlations between variables in -#' each credible set. -#' @param method A character string specifying the method to use for calculating -#' purity. Defaults to 'min'. Other methods return a vector of min, mean, and -#' median absolute correlations for each credible set. -#' @return A list where each element corresponds to a credible set and contains -#' either a single purity value (for 'min' method and single-element sets) or -#' a vector of purity metrics (for other methods and multi-element sets). -#' @noRd # Absolute off-diagonal correlations among one credible set's variants. The # diagonal is blanked so a set is never judged pure by its self-correlation. @@ -2556,6 +2597,28 @@ csInfo <- function(susieOutputSetsCs, topVariantsIdx) { ) } +#' @title Calculate Purity Measures for Credible Sets +#' +#' @description As an extension of the internal cal_purity function. This +#' function computes purity metrics (minimum, mean, and median absolute +#' correlations) for each credible set in a list of credible set indices, +#' based on the provided X matrix. The output Purity depends on the method +#' specified: for the 'min' method, it returns a single value for +#' single-element sets or the minimum absolute correlation for others. For +#' other methods, it returns a vector of three values (min, mean, median) for +#' each set. +#' +#' @param lCs A list of credible set indices, where each element is a vector of +#' indices corresponding to variables in a credible set. +#' @param X The data matrix used to compute correlations between variables in +#' each credible set. +#' @param method A character string specifying the method to use for calculating +#' purity. Defaults to 'min'. Other methods return a vector of min, mean, and +#' median absolute correlations for each credible set. +#' @return A list where each element corresponds to a credible set and contains +#' either a single purity value (for 'min' method and single-element sets) or +#' a vector of purity metrics (for other methods and multi-element sets). +#' @noRd calPurity <- function(lCs, X, method = "min") { # Each `lCs[[k]]` is documented (and always supplied) as a plain index # vector; the unlist() that used to sit here was a no-op that quietly @@ -2597,12 +2660,12 @@ fsusieGetCs <- function(fsusieObj, X, requestedCoverage = 0.95) { str_c("L", seq_along(fsusieObj$cs)) ) - # Create 'purity' data frame - purity <- `colnames<-`( - bind_rows( - map(calPurity(fsusieObj$cs, X = X, method = "susie"), .asDataFrameT) - ), - c("minAbsCorr", "meanAbsCorr", "medianAbsCorr") + # Create 'purity' data frame: each set's (min, mean, median) |r|. + setPurity <- calPurity(fsusieObj$cs, X = X, method = "susie") + purity <- tibble( + minAbsCorr = map_dbl(setPurity, 1L), + meanAbsCorr = map_dbl(setPurity, 2L), + medianAbsCorr = map_dbl(setPurity, 3L) ) # Credible-set label as a `cs` column (was rownames; tibbles carry none). purityDf <- bind_cols(tibble(cs = names(csNamed)), purity) @@ -2957,10 +3020,6 @@ fitFsusie <- function( # extractors live with the rest of the fine-mapping/SuSiE wrappers). # ============================================================================= -# Shared helper for susie/susieAsh/susieInf weight extraction. -# @param fit A susie fit object (or NULL to fit from X, y). -# @param X Genotype matrix (optional). -# @param y Phenotype vector (optional). # Drop-intercept TWAS coefficient weights from a fitted SuSiE(-RSS) model # (zero the intercept, then coef.susie without the intercept row). # @noRd @@ -2968,13 +3027,18 @@ fitFsusie <- function( coef.susie(list_assign(fit, intercept = 0))[-1] } -# @param requiredFields Fields that must be present in the fit to extract -# weights. -# @param token SuSiE-family token ("susie" / "susieInf" / "susieAsh") selecting -# the unmappable_effects mode. The fit is delegated to .fmFitSusieIndiv so the -# package keeps a single susie-invocation point. -# @param userArgs Extra arguments forwarded to susieR::susie via -# .fmFitSusieIndiv. +# Shared helper for susie/susieAsh/susieInf weight extraction: the +# drop-intercept coefficients of an EXISTING fit. These never fine-map, so a +# NULL `fit` is an error naming the run that would produce one. +# @param fit A susie fit object. +# @param X Genotype matrix, or NULL; when given, its column count is checked +# against the fit's variants. +# @param requiredFields Fields the fit must carry for weights to be extracted; +# the weights are all zero when any is missing. +# @param token SuSiE-family token ("susie" / "susieInf" / "susieAsh") the +# error names. +# @param fitRetention "none" returns the weights alone; otherwise the fit rides +# along as their "fit" attribute. #' @importFrom susieR coef.susie susie #' @noRd .susieExtractWeights <- function( @@ -3191,7 +3255,7 @@ susieInfWeights <- function( #' @noRd .susieRssExtractWeights <- function( fit, - R, + nVariants, requiredFields, token = "susie", fitRetention = c("none", "slim", "full") @@ -3206,12 +3270,11 @@ susieInfWeights <- function( ) abort(msg) } - if (length(fit$pip) != nrow(R)) { + if (!is.na(nVariants) && length(fit$pip) != nVariants) { nPip <- length(fit$pip) - nR <- nrow(R) msg <- glue( - "Dimension mismatch: susieRss fit has {nPip} variants but R ", - "has {nR} rows." + "Dimension mismatch: susieRss fit has {nPip} variants but the ", + "statistics describe {nVariants}." ) abort(msg) } @@ -3232,8 +3295,11 @@ susieInfWeights <- function( #' \code{susieR::susie_rss()} from summary statistics and LD. #' #' @param stat List with components \code{z} (z-scores), \code{n} (sample -#' sizes). -#' @param LD LD correlation matrix. +#' sizes) and, to check against an \code{ldReference}, \code{variantNames}. +#' @param ldReference Optional LD reference: a genotype panel, a +#' \code{\link{GenotypeMixture}} or an \code{\link{LdMatrix}}. The fit is +#' checked against the statistics' variants and, with a reference, those +#' variants must also be in it. No LD is read. #' @param susieRssFit A fitted SuSiE-RSS object. Required: these wrappers #' extract weights and never run fine-mapping themselves. #' @param fitRetention How much of the fit is kept on the returned weights: @@ -3255,12 +3321,12 @@ susieInfWeights <- function( #' n = rep(nrow(X), ncol(X))) #' LD <- cor(X) #' fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) -#' susieRssWeights(stat, LD, susieRssFit = fit) +#' susieRssWeights(stat, susieRssFit = fit) #' @importFrom checkmate assertList assertFlag #' @export susieRssWeights <- function( stat, - LD, + ldReference = NULL, susieRssFit = NULL, fitRetention = c("slim", "none", "full") ) { @@ -3268,7 +3334,7 @@ susieRssWeights <- function( fitRetention <- arg_match(fitRetention) .susieRssExtractWeights( fit = susieRssFit, - R = LD, + nVariants = .rssVariantCount(stat, ldReference, "susieRssWeights"), requiredFields = c("alpha", "mu", "X_column_scale_factors"), token = "susie", fitRetention = fitRetention @@ -3297,12 +3363,12 @@ susieRssWeights <- function( #' n = rep(nrow(X), ncol(X))) #' LD <- cor(X) #' fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) -#' susieInfRssWeights(stat, LD, susieInfRssFit = fit) +#' susieInfRssWeights(stat, susieInfRssFit = fit) #' @importFrom checkmate assertList assertFlag #' @export susieInfRssWeights <- function( stat, - LD, + ldReference = NULL, susieInfRssFit = NULL, fitRetention = c("slim", "none", "full") ) { @@ -3310,7 +3376,7 @@ susieInfRssWeights <- function( fitRetention <- arg_match(fitRetention) .susieRssExtractWeights( fit = susieInfRssFit, - R = LD, + nVariants = .rssVariantCount(stat, ldReference, "susieInfRssWeights"), requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), token = "susieInf", fitRetention = fitRetention @@ -3339,12 +3405,12 @@ susieInfRssWeights <- function( #' n = rep(nrow(X), ncol(X))) #' LD <- cor(X) #' fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) -#' susieAshRssWeights(stat, LD, susieAshRssFit = fit) +#' susieAshRssWeights(stat, susieAshRssFit = fit) #' @importFrom checkmate assertList assertFlag #' @export susieAshRssWeights <- function( stat, - LD, + ldReference = NULL, susieAshRssFit = NULL, fitRetention = c("slim", "none", "full") ) { @@ -3352,7 +3418,7 @@ susieAshRssWeights <- function( fitRetention <- arg_match(fitRetention) .susieRssExtractWeights( fit = susieAshRssFit, - R = LD, + nVariants = .rssVariantCount(stat, ldReference, "susieAshRssWeights"), requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), token = "susieAsh", fitRetention = fitRetention @@ -3656,15 +3722,18 @@ fsusieWeights <- function( #' extracts coefficients from an existing \code{mvsusieR::mvsusie_rss} fit. #' It never runs fine-mapping itself --- \code{mvsusieRssFit} is required. #' -#' Follows the \code{*_rss_weights(stat, LD, ...)} contract: \code{stat} and -#' \code{LD} describe the block the fit is being extracted against, and the -#' fit is checked against them rather than refitted. +#' Follows the RSS weights contract: \code{stat} (and \code{ldReference}, +#' when given) describe the block the fit is being extracted against, and +#' the fit is checked against them rather than refitted. #' -#' @param stat A list with \code{z} (matrix variants x conditions) and \code{n} -#' (numeric vector or scalar), describing the block the fit came from. -#' @param LD LD correlation matrix for that block. The fit must cover the -#' same number of variants; a mismatch is an error, since weights from one -#' block are not comparable against another's LD. +#' @param stat A list with \code{z} (matrix variants x conditions), \code{n} +#' (numeric vector or scalar) and, to check against an \code{ldReference}, +#' \code{variantNames}, describing the block the fit came from. The fit +#' must cover the same number of variants; a mismatch is an error, since +#' weights from one block are not comparable against another's. +#' @param ldReference Optional LD reference for that block: a genotype +#' panel, a \code{\link{GenotypeMixture}} or an \code{\link{LdMatrix}}. +#' With one, the statistics' variants must also be in it. No LD is read. #' @param mvsusieRssFit A fitted \code{mvsusieRss} object. Required: this #' extracts weights and never runs fine-mapping itself. #' @param fitRetention How much of the fit is kept on the returned weights: @@ -3689,11 +3758,11 @@ fsusieWeights <- function( #' LD <- cor(X) #' fit <- fitMvsusieRss(Z = stat$z, R = LD, N = nrow(X), #' prior_variance = 1) -#' mvsusieRssWeights(stat, LD, mvsusieRssFit = fit) +#' mvsusieRssWeights(stat, mvsusieRssFit = fit) #' @export mvsusieRssWeights <- function( stat, - LD, + ldReference = NULL, mvsusieRssFit = NULL, fitRetention = c("none", "slim", "full") ) { @@ -3712,11 +3781,14 @@ mvsusieRssWeights <- function( abort(msg) } weights <- mvsusieR::coef.mvsusie(mvsusieRssFit)[-1, , drop = FALSE] - # `stat` / `LD` describe the block the fit is being combined with. The - # susie *RssWeights wrappers check the fit against them; this one used - # to take both and read neither, so a fit from a different block was - # extracted without complaint. - .mvsusieRssAssertBlock(weights, LD) + # `stat` (and `ldReference`) describe the block the fit is being combined + # with. The susie *RssWeights wrappers check the fit against them; this + # one used to take both and read neither, so a fit from a different block + # was extracted without complaint. + .mvsusieRssAssertBlock( + weights, + .rssVariantCount(stat, ldReference, "mvsusieRssWeights") + ) if (identical(fitRetention, "none")) { return(weights) } @@ -3726,13 +3798,13 @@ mvsusieRssWeights <- function( # The supplied fit must describe the LD block it is being extracted against; # the pairing is what makes the weights comparable across a region. # @noRd -.mvsusieRssAssertBlock <- function(weights, LD) { - if (is.null(LD) || nrow(weights) == nrow(LD)) { +.mvsusieRssAssertBlock <- function(weights, nVariants) { + if (is.na(nVariants) || nrow(weights) == nVariants) { return(invisible(NULL)) } abort(glue( "Dimension mismatch: mvsusieRss fit has {nrow(weights)} variants ", - "but LD has {nrow(LD)} rows." + "but the statistics describe {nVariants}." )) } @@ -3741,8 +3813,6 @@ mvsusieRssWeights <- function( # Cross-condition credible-set merging # ============================================================================= -# Identify variant IDs that are associated with more than one credible set. -# @noRd # The sets a variant belongs to, but only when it belongs to more than one. # @noRd .ovlMultiSets <- function(entry) { @@ -3750,6 +3820,8 @@ mvsusieRssWeights <- function( if (length(sets) > 1) sets else NULL } +# Identify variant IDs that are associated with more than one credible set. +# @noRd .identifyOverlapSets <- function(variantsSetsAndPipsList) { compact(map(variantsSetsAndPipsList, .ovlMultiSets)) } @@ -3776,8 +3848,6 @@ mvsusieRssWeights <- function( `[[<-`(parent, rootB, value = rootA) } -# Merge overlapping credible sets using connected components (union-find). -# @noRd # @noRd .ufPair <- function(s, first) { list(a = first, b = s) @@ -3804,6 +3874,8 @@ mvsusieRssWeights <- function( set_names(as.list(rep(label, length(members))), members) } +# Merge overlapping credible sets using connected components (union-find). +# @noRd .mergeAndUpdateOverlapSets <- function(variantsSetsAndPipsList, overlapSets) { allSets <- unique(list_c(overlapSets)) if (length(allSets) == 0) { @@ -3899,7 +3971,7 @@ mvsusieRssWeights <- function( #' the \code{"strong"} input for \code{\link{mashPipeline}}. #' #' @param fineMappingResult A \code{\link{QtlFineMappingResult}} (or any -#' \code{FineMappingResult}) produced by per-condition SuSiE fine-mapping. +#' \code{FineMappingResultBase}) produced by per-condition SuSiE fine-mapping. #' Each entry's \code{topLoci} must carry a credible-set column #' (\code{cs_}, e.g. \code{cs_95}, with values such as #' \code{"susie_1"} where the trailing integer is the set index and \code{_0} @@ -3919,8 +3991,8 @@ mvsusieRssWeights <- function( mergeSusieCs <- function(fineMappingResult, coverage = 0.95) { if (!is(fineMappingResult, "FineMappingResultBase")) { msg <- glue( - "`fineMappingResult` must be a QtlFineMappingResult (or ", - "FineMappingResult)." + "`fineMappingResult` must be a QtlFineMappingResult or ", + "GwasFineMappingResult." ) abort(msg) } @@ -3957,28 +4029,30 @@ mergeSusieCs <- function(fineMappingResult, coverage = 0.95) { #' Extract the trimmed SuSiE fit from a finemapping pipeline result #' -#' Returns the trimmed model fit underlying \code{con_data$finemappingEntry} (a -#' \code{FineMappingRow} S4 object), or NULL if no fine-mapping entry is -#' attached. +#' Returns the trimmed model fit underlying \code{conData$finemappingEntry} (a +#' \code{FineMappingRow}, or a single-row fine-mapping result), or NULL if no +#' fine-mapping entry is attached. #' #' @param conData List. The method-layer entry from a finemapping pipeline #' result, expected to carry \code{$finemappingEntry} as a -#' \code{FineMappingRow} object. +#' \code{FineMappingRow} or a single-row fine-mapping result. #' @return The trimmed fit (a list with \code{pip}, \code{sets}, etc.) or NULL. #' @examples -#' data(qtlSumStatsExample) -#' susieResult(qtlSumStatsExample) +#' data(qtlFineMappingExample) +#' fit <- susieResult(list(finemappingEntry = qtlFineMappingExample[1])) +#' head(fit$pip) #' @importFrom checkmate assertList #' @export susieResult <- function(conData) { - # No type guard: this is duck-typed on `$` and `length()` and returns NULL - # for anything without a `finemappingEntry`. Its own @example passes a - # QtlSumStats, which assertList rejects. + # Duck-typed on `$` and `length()`: NULL for anything without a + # fine-mapping entry. The entry is one row's worth of fine-mapping -- a + # FineMappingRow, or the single-row result fineMappingResult() returns -- + # which .fmrPartsSusieFit() reads alike. if (length(conData) == 0) { return(NULL) } fm <- conData$finemappingEntry - if (is.null(fm) || !is(fm, "FineMappingResultBase")) { + if (!is(fm, "FineMappingRow") && !is(fm, "FineMappingResultBase")) { return(NULL) } trimmed <- .fmrPartsSusieFit(fm) @@ -4019,8 +4093,8 @@ susieResult <- function(conData) { #' CS (its row of the between-CS matrix, self-correlation on the diagonal), #' computed on demand from \code{ldSource}. Absent when there are fewer than #' two credible sets.} -#' \item{cs_corr_max}{Maximum absolute between-CS correlation (excluding the -#' self == 1); \code{NA} for a single CS.} +#' \item{cs_corr_max}{Maximum absolute correlation with the other credible +#' sets; \code{NA} for a single CS.} #' \item{cs_corr_min}{Minimum absolute between-CS correlation; \code{NA} for a #' single CS.} #' @@ -4135,43 +4209,40 @@ extractTopPipInfo <- function(fmRow, sumstats) { ) } -# Reduce one credible set's correlation vector (a row of the between-CS matrix, -# the self-correlation == 1 on the diagonal) to its |corr| max/min, excluding -# every self / perfect correlation (== 1). An empty result yields NA. +# Credible set `i`'s largest and smallest |correlation| with the other sets +# in the between-CS matrix `csCorr`. Only its own entry is dropped, by +# position: two sets in perfect LD still report |r| = 1, and a diagonal a few +# ulps short of 1 (as a factor's correlation gives) is still the set with +# itself. `csCorr` exists only for two or more sets, so others always remain. # @noRd -.extractCorrelations <- function(x) { - filtered <- abs(x[x != 1]) - if (length(filtered) == 0L) { - return(list(max_corr = NA_real_, min_corr = NA_real_)) - } +.extractCorrelations <- function(i, csCorr) { + others <- abs(csCorr[i, -i]) list( - max_corr = max(filtered, na.rm = TRUE), - min_corr = min(filtered, na.rm = TRUE) + max_corr = max(others, na.rm = TRUE), + min_corr = min(others, na.rm = TRUE) ) } # Append the between-CS correlation columns to the per-CS summary `base` from # the m x m matrix `csCorr` (whose rows are aligned to `base`): the expanded # cs_corr_1..m (each CS's row, self-correlation on the diagonal) plus -# cs_corr_max / cs_corr_min (|corr| excluding the self == 1). A NULL matrix +# cs_corr_max / cs_corr_min (|corr| with the other sets). A NULL matrix # (fewer than two credible sets) yields NA max/min and no expanded columns. # @noRd .csAppendCorrelationCols <- function(base, csCorr) { if (is.null(csCorr)) { return(mutate(base, cs_corr_max = NA_real_, cs_corr_min = NA_real_)) } - perRow <- apply(csCorr, 1L, .extractCorrelations, simplify = FALSE) + perRow <- map(seq_len(nrow(csCorr)), .extractCorrelations, csCorr = csCorr) expanded <- `names<-`( as_tibble(csCorr, .name_repair = "minimal"), str_c("cs_corr_", seq_len(ncol(csCorr))) ) - # unname(): apply() names its result by the matrix rownames, which map_dbl - # then carries into the column (tibbles preserve element names). base |> bind_cols(expanded) |> mutate( - cs_corr_max = unname(map_dbl(perRow, "max_corr")), - cs_corr_min = unname(map_dbl(perRow, "min_corr")) + cs_corr_max = map_dbl(perRow, "max_corr"), + cs_corr_min = map_dbl(perRow, "min_corr") ) } @@ -4244,7 +4315,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { # into the arg prep (not merged afterwards) so L_greedy is clamped to # min(#inf effects, L) rather than passed through raw. chainedArgs <- prepareSusieFromInfArgs( - .fmMergeUserArgs(list(), token, userArgs), + .fmMergeUserArgs(list(), userArgs), chainFromInf, refineDefault = if (token == "susie") TRUE else NULL, unmappableEffects = if (token == "susieAsh") "ash" else "none" @@ -4258,7 +4329,6 @@ extractTopPipInfo <- function(fmRow, sumstats) { } else { .fmMergeUserArgs( list_assign(baseArgs, !!!.fmSusieTokenDefaults(token)), - token, userArgs ) } @@ -4267,7 +4337,9 @@ extractTopPipInfo <- function(fmRow, sumstats) { # Sumstat counterpart of .fmFitSusieIndiv. Calls susieR::susie_rss with -# the same unmappable_effects switch, chained init, and userArgs merge. +# the same unmappable_effects switch, chained init, and userArgs merge. The +# LD is either the matrix `R` or, in its place, a factor `X` of it (see +# .ldRefFactor()), which susie_rss correlates itself without forming R. # @noRd .fmFitSusieRss <- function( z, @@ -4279,14 +4351,16 @@ extractTopPipInfo <- function(fmRow, sumstats) { userArgs = NULL, rFinite = NULL, rMismatch = "none", - rssControl = NULL + rssControl = NULL, + X = NULL ) { info <- .fmRssValidateToken(token) + ldArgs <- if (is.null(X)) list(R = R) else list(X = X) baseArgs <- .fmRssAddControl( c( + list(z = z), + ldArgs, list( - z = z, - R = R, n = n, coverage = coverage, unmappable_effects = info$unmappableEffects @@ -4306,7 +4380,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { userArgs, chainFromInf, z, - R, + ldArgs, n, coverage ) @@ -4354,19 +4428,20 @@ extractTopPipInfo <- function(fmRow, sumstats) { } # SuSiE-RSS(-ash) initialised from a SuSiE-inf fit; userArgs folded into the arg -# prep so L_greedy is clamped rather than passed through raw. +# prep so L_greedy is clamped rather than passed through raw. `ldArgs` is +# list(R = ) or list(X = ), whichever form of the LD the fit reads. .fmRssChainedArgs <- function( baseArgs, token, userArgs, chainFromInf, z, - R, + ldArgs, n, coverage ) { chainedArgs <- prepareSusieFromInfArgs( - .fmMergeUserArgs(list(), token, userArgs), + .fmMergeUserArgs(list(), userArgs), chainFromInf, refineDefault = if (token == "susie") TRUE else NULL, unmappableEffects = if (token == "susieAsh") "ash" else "none" @@ -4374,7 +4449,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { list_assign( list_modify(baseArgs, !!!compact(chainedArgs)), z = z, - R = R, + !!!ldArgs, n = n, coverage = coverage ) @@ -4384,7 +4459,6 @@ extractTopPipInfo <- function(fmRow, sumstats) { .fmRssNonChainedArgs <- function(baseArgs, token, userArgs) { .fmMergeUserArgs( list_assign(baseArgs, !!!.fmSusieTokenDefaults(token)), - token, userArgs ) } @@ -4410,7 +4484,6 @@ extractTopPipInfo <- function(fmRow, sumstats) { .fmFitSusieSer <- function(z, n, coverage = 0.95, userArgs = NULL) { baseArgs <- .fmMergeUserArgs( list(z = z, n = n, coverage = coverage), - "ser", userArgs ) .setFinemappingFitClass(exec(susieR::susie_ser, !!!baseArgs), "susieRss") @@ -4481,8 +4554,12 @@ extractTopPipInfo <- function(fmRow, sumstats) { tid, af, fitRetention, - region = NULL + region = NULL, + fitFullData = TRUE ) { + if (isFALSE(fitFullData)) { + return(set_names(rep(list(.fmCvOnlyRow()), length(toRun)), toRun)) + } chainLocal <- .fmResolveSusieChain(toRun, initializeWithSusieInf) infFit <- .fmXInfFit( chainLocal, @@ -4531,7 +4608,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { af = NULL, fitRetention = "slim", seed = NULL, - region = NULL + region = NULL, + fitFullData = TRUE ) { out <- .fmXFitAll( toRun, @@ -4545,7 +4623,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { tid = tid, af = af, fitRetention = fitRetention, - region = region + region = region, + fitFullData = fitFullData ) .fmXCrossValidate( out, @@ -4708,13 +4787,15 @@ extractTopPipInfo <- function(fmRow, sumstats) { .fmAttachCv(out[[tk]], .fmSliceCv(cv, tk)) } -# Fit every requested RSS token on one (z, R, n) sumstat block, returning a +# Fit every requested RSS token on one (z, LD, n) sumstat block, returning a # named list (token -> FineMappingRow). The sumstat analog of .fmFitXBlock: # the QtlSumStats and GwasSumStats methods both call it and differ only in how -# they push the returned entries (tuple shape) and the progress `label`. +# they push the returned entries (tuple shape) and the progress `label`. `ld` +# is list(R, X) as .fmRssLd() builds it: the LD matrix, the LD reference's +# factor, or both. .fmFitRssBlock <- function( z, - R, + ld, n, toRun, initializeWithSusieInf, @@ -4732,7 +4813,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { infFit <- .fmRssInfFit( chainLocal, z = z, - R = R, + R = ld$R, n = n, coverage = credibleSetParam$coverage, methodArgs = methodArgs, @@ -4747,7 +4828,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { chainLocal = chainLocal, infFit = infFit, z = z, - R = R, + ld = ld, n = n, credibleSetParam = credibleSetParam, methodArgs = methodArgs, @@ -4771,7 +4852,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { chainLocal, infFit, z, - R, + ld, n, credibleSetParam, methodArgs, @@ -4788,7 +4869,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { chainLocal, infFit, z = z, - R = R, + ld = ld, n = n, coverage = credibleSetParam$coverage, methodArgs = methodArgs, @@ -4801,7 +4882,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { } entry <- .fmRssPostprocess( f$fit, - R = R, + ld = ld, z = z, credibleSetParam = credibleSetParam, af = af, @@ -4849,12 +4930,14 @@ extractTopPipInfo <- function(fmRow, sumstats) { # Standard multi-effect SuSiE-RSS fit (susie / susieAsh): the only branch that # carries susieR's finite-sample R diagnostics and honours the SER fallback. +# The plain susie model reads the LD reference's factor when there is one; +# susieAsh needs the matrix (see .fmRssLd()). .fmRssFitStd <- function( tk, chainLocal, infFit, z, - R, + ld, n, coverage, methodArgs, @@ -4874,9 +4957,10 @@ extractTopPipInfo <- function(fmRow, sumstats) { msg <- glue("Fitting {tk} (RSS) for {label} ...") inform(msg) } + useFactor <- tk == "susie" && !is.null(ld$X) fit <- .fmFitSusieRss( z, - R, + if (useFactor) NULL else ld$R, n, tk, chainFromInf = chainFrom, @@ -4884,7 +4968,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { userArgs = methodArgs[[tk]], rFinite = susieRssParam$rFinite, rMismatch = susieRssParam$rMismatch, - rssControl = .rssControlList(susieRssParam$control) + rssControl = .rssControlList(susieRssParam$control), + X = if (useFactor) ld$X ) .fmRssSerFallback(fit, susieRssParam) } @@ -4921,7 +5006,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { chainLocal, infFit, z, - R, + ld, n, coverage, methodArgs, @@ -4953,7 +5038,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { chainLocal, infFit, z = z, - R = R, + ld = ld, n = n, coverage = coverage, methodArgs = methodArgs, @@ -4964,10 +5049,12 @@ extractTopPipInfo <- function(fmRow, sumstats) { list(fit = std$fit, flag = std$flag, isStd = TRUE, multiFit = std$multiFit) } -# Post-process one RSS fit into a finemapping entry. +# Post-process one RSS fit into a finemapping entry. The credible sets' +# purity reads the LD reference's factor when there is one (only the sets' +# own columns are correlated), else the LD matrix. .fmRssPostprocess <- function( fit, - R, + ld, z, credibleSetParam, af, @@ -4978,7 +5065,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { .fmPostprocessOne( fit = fit, method = "susieRss", - dataX = R, + dataX = ld$X %||% ld$R, dataY = list(z = z), af = af, # Per-variant effective N (reporting-only, top_loci$N). NULL on any @@ -4986,7 +5073,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { # never 1. This is NOT `n` (the scalar median the RSS fit consumes). n = nVar, region = region, - csInput = "Xcorr", + csInput = if (is.null(ld$X)) "Xcorr" else "X", credibleSetParam = credibleSetParam, fitRetention = fitRetention ) @@ -5130,13 +5217,13 @@ extractTopPipInfo <- function(fmRow, sumstats) { str_c(methodTag, "_", ix) } -# Trailing integer of a "_" cs string (0 when empty / NA). +# Trailing integer of "_" credible-set labels, the inverse of +# .btlCsLabel ("susie_3" -> 3L). Vectorized. 0 marks "in no credible set", +# which is also what an empty or NA label means. # @noRd -.cs95ToIndex <- function(s) { - if (is.na(s) || str_length(s) == 0L) { - return(0L) - } - suppressWarnings(as.integer(str_remove(s, "^.*_"))) +.csLabelIndex <- function(labels) { + idx <- suppressWarnings(as.integer(str_remove(labels, "^.*_"))) + replace(idx, is.na(labels) | str_length(labels) == 0L, 0L) } # @noRd @@ -5166,11 +5253,6 @@ extractTopPipInfo <- function(fmRow, sumstats) { ) } -# @noRd -.asDataFrameT <- function(x) { - as.data.frame(t(x)) -} - # @noRd .amRow <- function(l, am) { as.numeric(am[l, ]) @@ -5438,7 +5520,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { baseArgs, !!!compact(list(residual_variance = mvPrior$residualVariance)) ) - mvArgs <- .fmMergeUserArgs(withPrior, "mvsusie", userArgs) + mvArgs <- .fmMergeUserArgs(withPrior, userArgs) fit <- exec(fitMvsusie, !!!.splitMethodArgs(fitMvsusie, mvArgs)) raw <- as.matrix(mvsusieWeights(mvsusieFit = fit)) W <- `rownames<-`(raw, rownames(raw) %||% colnames(Xtr)) diff --git a/R/genotypeIo.R b/R/genotypeIo.R index cc5d515c2..0fdb4feab 100644 --- a/R/genotypeIo.R +++ b/R/genotypeIo.R @@ -1,7 +1,8 @@ -#' @title Genotype I/O via GenotypeHandle -#' @description Read genotype data from various formats (VCF, plink1, plink2, -#' GDS) and provide block-level genotype extraction without requiring format -#' conversion. +#' @title Genotype I/O +#' @description Read genotype data in its own format (VCF, plink1, plink2, +#' GDS, BGEN) as a lazily read genotype panel, without converting it: +#' PLINK2 and BGEN files through a GenotypeHandle, VCF, GDS and PLINK1 +#' files through a GenotypeDosageSeed. #' @name pecotmr-genotype-io #' @keywords internal #' @importFrom SummarizedExperiment SummarizedExperiment rowRanges @@ -34,9 +35,7 @@ setMethod( "readGenotypes", signature(path = "character"), function(path, format = NULL, vcfArgs = list()) { - .genotypeExperiment( - .readGenotypeHandle(path, format = format, vcfArgs = vcfArgs) - ) + .readGenotypePanel(path, format = format, vcfArgs = vcfArgs) } ) @@ -63,10 +62,9 @@ setMethod( vcfArgs = list() ) { # The keyword sources are declared here rather than absorbed by `...` - # and forwarded: GenotypeHandle() is internal, so this signature is - # the only place a caller can name them, and a misspelled source - # should be an error at the call rather than a silently unset one. - .genotypeExperiment(GenotypeHandle( + # and forwarded, so a misspelled source is an error at the call + # rather than a silently unset one. + .genotypePanelFromSources( plink1Prefix = plink1Prefix, plink2Prefix = plink2Prefix, bed = bed, @@ -81,24 +79,100 @@ setMethod( chroms = chroms, format = format, vcfArgs = vcfArgs - )) + ) } ) -# The handle behind a panel. Internal: the handle is the seed layer, and the +# The panel a keyword source names: exactly one source, checked as +# GenotypeHandle() checks it. A PLINK2 triplet is read through a handle, a +# PLINK1 one as a panel; a file an LD-meta row or a per-chromosome meta +# names, through whatever reads its format. +# @noRd +.genotypePanelFromSources <- function( + plink1Prefix = NULL, + plink2Prefix = NULL, + bed = NULL, + bim = NULL, + fam = NULL, + pgen = NULL, + pvar = NULL, + psam = NULL, + ldMeta = NULL, + region = NULL, + genoMeta = NULL, + chroms = NULL, + format = NULL, + vcfArgs = list() +) { + flags <- .ghValidateArgs( + bed = bed, + bim = bim, + fam = fam, + pgen = pgen, + pvar = pvar, + psam = psam, + ldMeta = ldMeta, + region = region + ) + sources <- .ghResolveSources( + path = NULL, + plink1Prefix = plink1Prefix, + plink2Prefix = plink2Prefix, + ldMeta = ldMeta, + genoMeta = genoMeta, + chroms = chroms, + flags = flags + ) + switch( + names(sources)[which(sources)], + plink1Prefix = .readGenotypePanel(plink1Prefix, format = "plink1"), + plink2Prefix = .genotypeExperiment(.makePlink2Handle(plink2Prefix)), + plink1Triplet = .readGenotypePanel( + .plink1TripletStem(bed, bim, fam), + format = "plink1" + ), + plink2Triplet = .genotypeExperiment( + .genotypeHandleFromPlink2Triplet(pgen, pvar, psam) + ), + ldMeta = .ghLdPathToPanel(.ghResolveLdPath(ldMeta, region), vcfArgs), + genoMeta = .chromMetaPanel(genoMeta, chroms, format) + ) +} + +# The formats read as a panel directly, through a GenotypeDosageSeed; every +# other format is read through a GenotypeHandle. +# @noRd +.DOSAGE_PANEL_FORMATS <- c("vcf", "gds", "plink1") + +# The panel of one genotype file or PLINK prefix. A VCF, GDS or PLINK1 file +# is read as a panel directly; a PLINK2 or BGEN file through a +# GenotypeHandle. +# @noRd +.readGenotypePanel <- function(path, format = NULL, vcfArgs = list()) { + format <- format %||% .requireGenotypeFormat(path, "readGenotypes") + if (!is_in(format, .DOSAGE_PANEL_FORMATS)) { + return(.genotypeExperiment(.readGenotypeHandle(path, format = format))) + } + .withSourceProjection(.readDosagePanel(path, format, vcfArgs)) +} + +# The handle behind a panel of a format a GenotypeHandle reads: PLINK2 or +# BGEN. Internal: the handle is the seed layer, and the # handle-construction machinery below calls this rather than readGenotypes() # so it does not wrap and immediately unwrap a panel on every hop. # @noRd -.readGenotypeHandle <- function(path, format = NULL, vcfArgs = list()) { - if (is.null(format)) { - format <- .h2DetectFormat(path) - } +.readGenotypeHandle <- function(path, format = NULL) { + format <- format %||% .requireGenotypeFormat(path, "readGenotypes") switch( format, - "gds" = .makeGdsHandle(path), - "vcf" = .makeVcfHandle(path, vcfArgs = vcfArgs), - "plink1" = .makePlink1Handle(path), "plink2" = .makePlink2Handle(path), + "bgen" = .makeBgenHandle(path), + "vcf" = , + "gds" = , + "plink1" = abort(c( + glue("A {format} file is read as a genotype panel, not a handle."), + i = "Read it with readGenotypes()." + )), .abortUnsupportedFormat(format) ) } @@ -111,21 +185,13 @@ setMethod( # lets @snpInfo be row-subset (e.g. to the range of a study's summary stats) # while genotype reads that index BY FILE POSITION still resolve correctly: # PLINK2's ReadList(variant_subset=) and the per-chromosome PLINK2 view inside -# sharded routing read fileIdx[snpIdx]; the by-id backends (plink1/gds/vcf) look -# up snpInfo$SNP[snpIdx] / $BP[snpIdx] and ignore fileIdx entirely. For a full -# (unsubset) handle fileIdx == seq_len(nrow), so reads are unchanged. +# sharded routing read fileIdx[snpIdx]. For a full (unsubset) handle fileIdx +# == seq_len(nrow), so reads are unchanged. # @noRd .withFileIdx <- function(snpInfo) { mutate(snpInfo, fileIdx = seq_len(nrow(snpInfo))) } -# Restrict a GenotypeHandle's @snpInfo to `keep` (a logical mask or integer row -# indices into @snpInfo). Genotype reads stay correct because fileIdx carries -# each kept variant's original file position; everything else (path/format/ -# pgenPtr/chromPaths/samples) is preserved. NULL-safe; a no-op when nothing is -# dropped. Handles built before the fileIdx column existed are NOT subset (the -# read path would be positional) -- return them unchanged. -# @noRd # A handle trimmed to zero variants, every other property preserved. # # Separate from .subsetGenotypeHandle() because that declines to subset a @@ -142,7 +208,7 @@ setMethod( # 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. + # via .emptyLdRef (the empty / PIP-skip path), never on a surviving region. methods::initialize( handle, snpInfo = slice(snpInfo(handle), integer(0)), @@ -151,6 +217,13 @@ setMethod( ) } +# Restrict a GenotypeHandle's @snpInfo to `keep` (a logical mask or integer row +# indices into @snpInfo). Genotype reads stay correct because fileIdx carries +# each kept variant's original file position; everything else (path/format/ +# pgenPtr/chromPaths/samples) is preserved. NULL-safe; a no-op when nothing is +# dropped. Handles built before the fileIdx column existed are NOT subset (the +# read path would be positional) -- return them unchanged. +# @noRd .subsetGenotypeHandle <- function(handle, keep) { if (is.null(handle)) { return(NULL) @@ -166,149 +239,13 @@ setMethod( methods::initialize(handle, snpInfo = slice(si, keepIdx)) } -#' @importFrom checkmate assertFileExists -#' @keywords internal -.makeGdsHandle <- function(path) { - if (!requireNamespace("SNPRelate", quietly = TRUE)) { - abort("Package 'SNPRelate' is required for reading GDS files.") - } - if (!requireNamespace("gdsfmt", quietly = TRUE)) { - abort("Package 'gdsfmt' is required for reading GDS files.") - } - assertFileExists(path, access = "r", .var.name = "GDS file") - - snpInfo <- .gdsSnpInfo(path) - - sampleIds <- .withGds(path, .gdsReadSampleIds) - nSamples <- length(sampleIds) - - new( - "GenotypeHandle", - path = path, - format = "gds", - snpInfo = .withFileIdx(snpInfo), - nSamples = as.integer(nSamples), - sampleIds = sampleIds, - pgenPtr = NULL - ) -} - -#' @importFrom checkmate assertFileExists -#' @keywords internal -.makeVcfHandle <- function(path, vcfArgs = list()) { - if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { - abort("Package 'VariantAnnotation' is required for reading VCF files.") - } - assertFileExists(path, access = "r", .var.name = "VCF file") - - hdr <- VariantAnnotation::scanVcfHeader(path) - sampleIds <- as.character(VariantAnnotation::samples(hdr)) - nSamples <- length(sampleIds) - - param <- VariantAnnotation::ScanVcfParam( - fixed = c("ALT"), - info = NA, - geno = NA - ) - vcf <- exec( - VariantAnnotation::readVcf, - path, - param = param, - !!!vcfArgs - ) - rd <- rowRanges(vcf) - - # pecotmr convention: A1 = ALT (effect), A2 = REF - snpInfo <- tibble( - SNP = names(rd), - CHR = as.character(seqnames(rd)), - BP = as.integer(start(rd)), - A1 = map_chr(rd$ALT, .gtFirstAllele), - A2 = as.character(rd$REF) - ) - - new( - "GenotypeHandle", - path = normalizePath(path), - format = "vcf", - snpInfo = .withFileIdx(snpInfo), - nSamples = as.integer(nSamples), - sampleIds = sampleIds, - pgenPtr = NULL - ) -} - -#' @keywords internal -.makePlink1Handle <- function(path) { - if (!requireNamespace("snpStats", quietly = TRUE)) { - abort("Package 'snpStats' is required for reading plink1 files.") - } - stem <- .plink1RequireFiles(path) - meta <- .plink1ReadMeta(stem) - new( - "GenotypeHandle", - path = stem, - format = "plink1", - snpInfo = .withFileIdx(meta$snpInfo), - nSamples = as.integer(meta$nSamples), - sampleIds = meta$sampleIds, - pgenPtr = NULL - ) -} - -# Resolve the plink1 stem and assert its .bed/.bim/.fam all exist. -# @noRd -#' @importFrom checkmate assertFileExists -.plink1RequireFiles <- function(path) { - stem <- .plinkStem(path) - assertFileExists( - str_c(stem, c(".bed", ".bim", ".fam")), - access = "r", - .var.name = "Plink file" - ) - stem -} - -# Read the .bim / .fam sidecars into snpInfo + sample metadata. Returns -# list(snpInfo, sampleIds, nSamples). -# @noRd -.plink1ReadMeta <- function(stem) { - # col_types all-character so readr never coerces a column: a bim whose - # allele column is uniformly "T"/"F" (all-A/T SNPs) would otherwise become - # logical, silently corrupting A1/A2 (BP is cast to integer below). - bim <- read_table( - str_c(stem, ".bim"), - col_names = c("CHR", "SNP", "CM", "BP", "A1", "A2"), - col_types = cols(.default = col_character()) - ) - fam <- read_table( - str_c(stem, ".fam"), - col_names = FALSE, - col_types = cols(.default = col_character()) - ) - # plink1 bim: col5 = A1 (minor/effect), col6 = A2 (major/ref); matches the - # pecotmr convention directly. - snpInfo <- tibble( - SNP = bim$SNP, - CHR = as.character(bim$CHR), - BP = as.integer(bim$BP), - A1 = bim$A1, - A2 = bim$A2 - ) - list( - snpInfo = snpInfo, - sampleIds = as.character(fam[[2]]), - nSamples = nrow(fam) - ) -} - #' @keywords internal .makePlink2Handle <- function(path) { if (!requireNamespace("pgenlibr", quietly = TRUE)) { abort("Package 'pgenlibr' is required for reading plink2 files.") } - stem <- .plinkStem(path) + stem <- .genotypeStem(path) # Use pecotmr's resolvePlink2Paths for robust path detection (.pvar.zst) paths <- resolvePlink2Paths(stem) @@ -376,11 +313,8 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { if (length(.genotypeChromPaths(handle)) > 0L) { return(.extractBlockSharded(handle, snpIdx, meanImpute = meanImpute)) } - # An empty request is answered without reaching a reader. This is not - # defensive tidiness: snpStats::read.plink(select.snps = character(0)) - # SEGFAULTS, taking the R session with it rather than raising a condition - # tryCatch could see. The sharded branch above already returns early for - # the same reason; this is the single-file path catching up. + # An empty request is answered without reaching a reader, which need not + # accept one, as the sharded branch above already answers it. if (length(snpIdx) == 0L) { return(.emptyBlockSe(sampleIds(handle))) } @@ -388,9 +322,6 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # .restoreRequestedOrder() for why this is not merely tidiness. ord <- order(.genotypeFilePos(handle, snpIdx)) raw <- .extractBlockByFormat(handle, snpIdx[ord]) - if (is.null(raw)) { - return(NULL) - } ordered <- .restoreRequestedOrder(raw, ord) geno <- if (meanImpute) .meanImputeGeno(ordered) else ordered .blockGenotypesToSe(geno, handle, snpIdx) @@ -408,17 +339,14 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # Put a block's variant columns back into the order the caller asked for. # -# snpStats (`select.snps=`) and SNPRelate (`snp.id=`) return variants in FILE -# order however they were asked for, while .blockGenotypesToSe() labels the -# block from snpInfo[snpIdx], i.e. the REQUESTED order. An unsorted request -# therefore produced a block whose names and dosages described different -# variants -- silently, since both are the right length. pgenlibr reads -# positionally and was unaffected. -# -# Reading ascending and permuting back is correct for every backend, including -# the ones that do honour the request: given a sorted request they return -# sorted output either way, so the inverse permutation restores the caller's -# order in both cases. +# .blockGenotypesToSe() labels the block from snpInfo[snpIdx], i.e. the +# REQUESTED order, so a backend returning variants in FILE order however they +# were asked for -- snpStats did, when it read PLINK1 -- would yield a block +# whose names and dosages describe different variants, silently, since both +# are the right length. Reading ascending and permuting back is correct for +# every backend, whether or not it honours the requested order: given a +# sorted request it returns sorted output either way, so the inverse +# permutation restores the caller's order. # @noRd .restoreRequestedOrder <- function(geno, ord) { if (ncol(geno) != length(ord)) { @@ -449,10 +377,18 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { as.matrix(genotypeCovariates) } cd <- .genotypeColData(gCov, colnames(dosage)) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = .genotypeSnpRanges(genotypes, rownames(dosage)), - colData = cd + # A stochastic sketch's dosages are projections, so its real sample count + # and allele frequencies are recorded from its sidecar here, once; and + # where the genotypes come from is recorded for what needs the file + # (.ldRefSource()). + .withLdProjection( + SummarizedExperiment::SummarizedExperiment( + assays = list(dosage = dosage), + rowRanges = .genotypeSnpRanges(genotypes, rownames(dosage)), + colData = cd, + metadata = list(genotypeSource = .genotypeSourceRecord(genotypes)) + ), + .sketchProjectionRecord(genotypes) ) } @@ -518,7 +454,28 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # describe variants the same way, and overlaps between the two actually hit. # @noRd .genotypeSnpRanges <- function(genotypes, variantIds) { - si <- snpInfo(genotypes) + .snpInfoRanges(snpInfo(genotypes), variantIds) +} + +# A panel's variants snpInfo-style, one row per rowRanges element: SNP (the +# file's own ids), CHR (canonical), BP, A1, A2. The inverse of +# .snpInfoRanges(), so genotypes from any backend answer alike. +# @noRd +.rangesSnpInfo <- function(gr) { + mc <- S4Vectors::mcols(gr) + tibble( + SNP = as.character(mc$SNP), + CHR = canonChrom(as.character(seqnames(gr))), + BP = as.integer(start(gr)), + A1 = as.character(mc$A1), + A2 = as.character(mc$A2) + ) +} + +# The rowRanges of variants described snpInfo-style (SNP, CHR, BP, A1, A2), +# named `variantIds`: a handle's, or a VCF, GDS or PLINK1 panel's rows. +# @noRd +.snpInfoRanges <- function(si, variantIds) { `names<-`( GenomicRanges::GRanges( seqnames = withChrPrefix(as.character(si$CHR)), @@ -537,10 +494,8 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { fmt <- genotypeFormat(handle) switch( fmt, - "gds" = .extractBlockGds(handle, snpIdx), - "vcf" = .extractBlockVcf(handle, snpIdx), - "plink1" = .extractBlockPlink1(handle, snpIdx), "plink2" = .extractBlockPlink2(handle, snpIdx), + "bgen" = .extractBlockBgen(handle, snpIdx), .abortUnsupportedFormat(fmt, "extractBlockGenotypes") ) } @@ -668,60 +623,6 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { ) } -#' @keywords internal -.extractBlockGds <- function(handle, snpIdx) { - .withGds( - .genotypeReadPath(handle), - .gdsBlockGeno, - fnArgs = list(handle = handle, snpIdx = snpIdx), - allow.fork = TRUE - ) -} - -#' @keywords internal -.extractBlockVcf <- function(handle, snpIdx) { - si <- slice(snpInfo(handle), snpIdx) - gr <- GRanges( - seqnames = si$CHR, - ranges = IRanges(start = si$BP, end = si$BP) - ) - param <- VariantAnnotation::ScanVcfParam( - which = gr, - fixed = NA, - info = NA, - geno = "GT" - ) - vcf <- VariantAnnotation::readVcf( - .genotypeReadPath(handle), - genome = "", - param = param - ) - gt <- VariantAnnotation::geno(vcf)$GT - - # Convert GT strings to ALT dosage (A1 dosage): one column per variant, - # laid side by side rather than filled into a preallocated matrix. - matrix( - map_dbl(as.vector(t(gt)), .gtStringToDosage), - nrow = ncol(gt), - ncol = nrow(gt) - ) -} - -#' @keywords internal -.extractBlockPlink1 <- function(handle, snpIdx) { - snpIds <- snpInfo(handle)$SNP[snpIdx] - pathStem <- .genotypeReadPath(handle) - plinkData <- snpStats::read.plink( - bed = str_c(pathStem, ".bed"), - bim = str_c(pathStem, ".bim"), - fam = str_c(pathStem, ".fam"), - select.snps = snpIds - ) - # snpStats as(x, "numeric") gives count of B allele (A2/bim col 6). - # Flip to count A1 (bim col 5 / effect allele). - `storage.mode<-`(2 - as(plinkData$genotypes, "numeric"), "double") -} - #' @keywords internal #' @importFrom rlang try_fetch .extractBlockPlink2 <- function(handle, snpIdx) { @@ -769,21 +670,17 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # @noRd .dosageMatrix <- function(handle, snpIdx, meanImpute = TRUE) { block <- extractBlockGenotypes(handle, snpIdx, meanImpute = meanImpute) - # NULL, not an error, when the reader declines the block: callers read - # that as "no genotypes here" (computeLd answers with an identity). - if (is.null(block)) { - return(NULL) - } t(SummarizedExperiment::assay(block, "dosage")) } -# Open a GDS read-only, guarantee it is closed on exit, and return fn(gds). -# The shared form of the snpgdsOpen(...) + on.exit(snpgdsClose(gds)) idiom -# used across the GDS readers. +# Resource bracket: open the SNPRelate GDS at `path` read-only, guarantee it +# is closed on exit, and run `fn(gds, ...)` -- the snpgdsOpen(...) + +# on.exit(snpgdsClose(gds)) idiom of the on-disk LD routine, which needs +# SNPRelate's own handle. `fn` is a top-level function (not an inline +# closure); its per-call inputs are threaded through `...`. A file a panel's +# GDSArray backend already holds open in this session is opened again rather +# than refused. # @noRd -# Resource bracket: open the GDS at `path`, guarantee it is closed on exit, and -# run `fn(gds, ...)`. `fn` is a top-level function (not an inline closure); its -# per-call inputs are threaded through `...`. .withGds <- function( path, fn, @@ -794,6 +691,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { gds <- SNPRelate::snpgdsOpen( path, readonly = readonly, + allow.duplicate = TRUE, allow.fork = allow.fork ) on.exit(SNPRelate::snpgdsClose(gds)) @@ -801,11 +699,11 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { } #' @keywords internal -.computeBlockLdGds <- function(handle, snpIdx) { +.computeBlockLdGds <- function(path, snpIds) { .withGds( - .genotypeReadPath(handle), + path, .gdsBlockLd, - fnArgs = list(handle = handle, snpIdx = snpIdx), + fnArgs = list(snpIds = snpIds), allow.fork = TRUE ) } @@ -861,88 +759,86 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { replace(geno, naMask, means[col(geno)[naMask]]) } -#' @keywords internal -.gdsSnpInfo <- function(gdsPath) { - .withGds(gdsPath, .gdsReadSnpInfo) -} +# ============================================================================= +# Genotype format detection +# ----------------------------------------------------------------------------- +# The one place a genotype path's format is told. A file is told by its +# extension, in any case; a PLINK prefix by the PLINK file beside it, a .pgen +# before a .bed (PLINK2 can hold dosages, so it wins when both are there). A +# VCF, GDS or BGEN file is always named by its own path. +# ============================================================================= -# Map a lowercase file extension to a genotype format, or NULL if unrecognized. +# The extensions naming each genotype format, as regular expressions. # @noRd -.h2FormatFromExt <- function(ext) { - switch( - ext, - "vcf" = "vcf", - "bcf" = "vcf", - "bed" = "plink1", - "bim" = "plink1", - "fam" = "plink1", - "pgen" = "plink2", - "pvar" = "plink2", - "psam" = "plink2", - "gds" = "gds", - "rds" = "rds", - "rdata" = "rds", - "annot" = "ldsc_annot", - "bw" = "bigwig", - "bigwig" = "bigwig", - NULL - ) -} - -.h2DetectFormat <- function(path) { - lpath <- str_to_lower(path) - if ( - str_detect(lpath, "\\.vcf\\.gz$") || - str_detect(lpath, "\\.vcf\\.bgz$") - ) { - return("vcf") - } - if (str_detect(lpath, "\\.annot\\.gz$")) { - return("ldsc_annot") - } +.GENOTYPE_EXTENSIONS <- c( + vcf = "vcf(\\.b?gz)?|bcf", + gds = "gds", + bgen = "bgen", + plink1 = "bed|bim|fam", + plink2 = "pgen|pvar(\\.zst)?|psam" +) + +# The genotype format a file's extension names, or NULL when it names none. +# @noRd +.genotypeFileFormat <- function(path) { + named <- str_detect( + str_to_lower(path), + str_c("\\.(", .GENOTYPE_EXTENSIONS, ")$") + ) + if (any(named)) names(.GENOTYPE_EXTENSIONS)[which(named)[[1L]]] else NULL +} - ext <- str_to_lower(file_ext(path)) - if (str_length(ext) > 0L) { - detected <- .h2FormatFromExt(ext) - if (!is.null(detected)) return(detected) +# The genotype format of a file or PLINK prefix: by the file's extension, or +# for a prefix by the PLINK file beside it; NULL when neither tells. +# @noRd +.genotypePathFormat <- function(path) { + byExtension <- .genotypeFileFormat(path) + if (!is.null(byExtension)) { + return(byExtension) } - # Check for file stems, including dotted prefixes such as sample.EUR.chr21. - if ( - file.exists(str_c(path, ".pgen")) || file.exists(str_c(path, ".pvar")) - ) { + if (file.exists(str_c(path, ".pgen"))) { return("plink2") } - if (file.exists(str_c(path, ".bed")) || file.exists(str_c(path, ".bim"))) { + if (file.exists(str_c(path, ".bed"))) { return("plink1") } - if (file.exists(str_c(path, ".gds"))) { - return("gds") - } - if (str_length(ext) > 0L) { - msg <- glue("Cannot detect format from extension: {ext}") - abort(msg) - } - msg <- glue("Cannot detect genotype format for path: {path}") - abort(msg) + NULL } -#' @title Detect Plink File Stem -#' @description Given any plink file path, return the stem. -#' @param path Character, path to any plink file. -#' @return Character, file stem without extension. -#' @keywords internal -.plinkStem <- function(path) { - # Only strip known plink extensions; leave other paths as-is (they may - # already be the stem, e.g. "prefix.genotype" -> "prefix.genotype.bed") - ext <- file_ext(path) - plinkExts <- c("bed", "bim", "fam", "pgen", "pvar", "psam") - if (is_in(str_to_lower(ext), plinkExts)) { - file_path_sans_ext(path) - } else { - path - } +# .genotypePathFormat(), or an error from `label` when the path names no +# genotype format. +# @noRd +.requireGenotypeFormat <- function(path, label) { + format <- .genotypePathFormat(path) + if (!is.null(format)) { + return(format) + } + abort(c( + glue( + "{label}: '{path}' is neither a genotype file nor a PLINK prefix." + ), + i = str_c( + "A genotype file is named by its extension (.vcf.gz, .vcf.bgz, ", + ".gds, .bgen, .bed, .pgen); a PLINK prefix by the .pgen or .bed ", + "beside it." + ) + )) } +# The stem of a genotype path: the path without the extension naming its +# format, which is what PLINK's readers and a file's sidecars (.afreq, +# .stochastic_meta.tsv, .sample) are named after. A PLINK prefix is its own +# stem. +# @noRd +.genotypeStem <- function(path) { + str_remove( + path, + regex( + str_c("\\.(", str_flatten(.GENOTYPE_EXTENSIONS, "|"), ")$"), + ignore_case = TRUE + ) + ) +} # ============================================================================= # Format-specific file readers @@ -956,34 +852,17 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # read PLINK files #' @importFrom vroom vroom -#' @importFrom tools file_path_sans_ext #' @importFrom Rsamtools TabixFile seqnamesTabix scanTabix headerTabix #' @importFrom GenomicRanges GRanges seqnames #' @importFrom SummarizedExperiment assay readBim <- function(bed) { - bimf <- str_c(file_path_sans_ext(bed), ".bim") + bimf <- str_c(.genotypeStem(bed), ".bim") `colnames<-`( vroom(bimf, col_names = FALSE), c("chrom", "id", "gpos", "pos", "a1", "a0") ) } -#' @importFrom vroom vroom -#' @importFrom tools file_path_sans_ext -readFam <- function(bed) { - famf <- str_c(file_path_sans_ext(bed), ".fam") - return(vroom(famf, col_names = FALSE)) -} - -# open bed/bim/fam: A PLINK 1 .bed is a valid .pgen -openBed <- function(bed) { - if (!requireNamespace("pgenlibr", quietly = TRUE)) { - abort("Package 'pgenlibr' is required for this function.") - } - rawSCt <- nrow(readFam(bed)) - return(pgenlibr::NewPgen(bed, raw_sample_ct = rawSCt)) -} - #' Read a PLINK2 allele frequency file (.afreq or .afreq.zst) #' #' @param prefix File prefix (without .afreq extension). @@ -1103,19 +982,16 @@ readStochasticMeta <- function(path, format = NULL) { #' Search for a stochastic genotype sidecar file alongside a genotype path. #' #' Looks for \code{.afreq}, \code{.afreq.zst}, and \code{.stochastic_meta.tsv} -#' files next to the given genotype path. For extension-based paths (VCF, GDS), -#' the extension is stripped first. For prefix-based paths (PLINK1/2), the -#' prefix is used directly. +#' files next to the given genotype path. For extension-based paths (VCF, GDS, +#' BGEN, or a PLINK file), the extension is stripped first. For prefix-based +#' paths (PLINK1/2), the prefix is used directly. #' #' @param genotypePath Path to the genotype data (prefix or file path). #' @return Path to the first sidecar file found, or \code{NULL}. #' @noRd findStochasticMeta <- function(genotypePath) { # Strip known genotype extensions to get the stem - stem <- str_remove( - genotypePath, - "\\.(vcf|vcf\\.gz|bcf|gds|bed|bim|fam|pgen|pvar|psam)$" - ) + stem <- .genotypeStem(genotypePath) candidates <- c( str_c(stem, ".afreq"), str_c(stem, ".afreq.zst"), @@ -1125,7 +1001,6 @@ findStochasticMeta <- function(genotypePath) { if (length(found) > 0) found[1] else NULL } - #' Invert min-max [0,2] scaling to recover the original U matrix #' #' Stochastic genotype data is stored after min-max scaling: U_scaled = 2 * (U - @@ -1207,64 +1082,13 @@ readPvar <- function(pvarPath) { ) } -# PLINK1 .bim files come in a 6-column form and a 9-column extended form; -# the column meanings are positional, so the width selects the header. -# @noRd -.plinkVariantColnames <- function(n, snpFilePath) { - if (n == 6) { - return(c("chrom", "id", "gpos", "pos", "A1", "A2")) - } - if (n == 9) { - return(c( - "chrom", - "id", - "gpos", - "pos", - "A1", - "A2", - "variance", - "allele_freq", - "n_nomiss" - )) - } - abort(glue( - "Unexpected number of columns ({n}) in variant file: ", - "{snpFilePath}" - )) -} - -#' Read variant metadata from either .bim or .pvar/.pvar.zst file. -#' -#' Auto-detects the format by extension and header, then returns a standardized -#' data.frame. For PLINK1 .bim files, assigns column names based on the number -#' of columns (6 or 9). For PLINK2 .pvar files, delegates to \code{readPvar()}. -#' -#' @param snpFilePath Path to .bim, .pvar, or .pvar.zst file. -#' @return data.frame with at minimum columns: chrom, id, pos, A2, A1. Extended -#' .bim files (9 columns) also include: variance, allele_freq, n_nomiss. -#' @importFrom readr read_table cols col_character -#' @noRd -readVariantMetadata <- function(snpFilePath) { - # Extension first, then the header line: a .pvar written without its - # extension still announces itself with a #CHROM header. - byExtension <- str_detect(snpFilePath, "\\.(pvar|pvar\\.zst)$") - isPvar <- byExtension || - str_detect(read_lines(snpFilePath, n_max = 1), "^#CHROM") - - if (isPvar) { - readPvar(snpFilePath) - } else { - df <- read_table(snpFilePath, col_names = FALSE, col_types = cols()) - `names<-`(df, .plinkVariantColnames(ncol(df), snpFilePath)) - } -} - #' Get variant information from any LD reference source #' -#' Auto-detects the source type (PLINK2, PLINK1, VCF, GDS, or pre-computed LD -#' metadata) and returns variant metadata. For PLINK2, opens only the .pvar -#' file. For PLINK1, reads only the .bim file. For VCF and GDS, loads the full -#' file and extracts variant info. +#' Auto-detects the source type (PLINK2, PLINK1, VCF, GDS or BGEN, given +#' directly or through LD metadata whose rows point at genotype files) and +#' returns variant metadata. For PLINK2, opens only the .pvar file. For PLINK1, +#' reads only the .bim file. For VCF, GDS and BGEN, loads the full file and +#' extracts variant info. #' #' @param source Genotype file path/prefix or LD metadata file path. #' @param region Region of interest: "chr:start-end" string or data.frame with @@ -1285,10 +1109,8 @@ refVariantInfo <- function(source, region = NULL) { info <- .refInfoPlink2(dataPath) } else if (resolved$type == "plink1") { info <- .refInfoPlink1(dataPath) - } else if (is_in(resolved$type, c("vcf", "gds"))) { - return(.refInfoVcfGds(dataPath, region)) } else { - return(.refInfoPrecomputedLd(resolved, region)) + return(.refInfoVcfGds(dataPath, region)) } # Region filter for plink2 / plink1 (the loader-based paths self-filter). .refRegionFilter(info, region) @@ -1298,7 +1120,10 @@ refVariantInfo <- function(source, region = NULL) { # else the resolved data path. # @noRd .refDataPath <- function(resolved, region) { - usesMeta <- is_in(resolved$type, c("plink2", "plink1", "vcf", "gds")) && + usesMeta <- is_in( + resolved$type, + c("plink2", "plink1", "vcf", "gds", "bgen") + ) && !is.null(resolved$metaPath) && !is.null(region) if (usesMeta) { @@ -1351,42 +1176,6 @@ refVariantInfo <- function(source, region = NULL) { ) } -# Pre-computed LD variant info: read the per-intersection bim/pvar metadata -# (already region-filtered by regionalLdMeta). -# @noRd -.refInfoPrecomputedLd <- function(resolved, region) { - bimPaths <- regionalLdMeta( - resolved$metaPath, - region - )$intersections$bimFilePaths - bind_rows(map(bimPaths, .refReadBimMeta)) |> - mutate(id = normalizeVariantId(.data$id)) -} - -# Read one bim/pvar metadata file into a canonical variant-info data.frame, -# carrying the optional variance / allele_freq / n_nomiss columns when present. -# @noRd -.refReadBimMeta <- function(path) { - df <- readVariantMetadata(path) - out <- tibble( - chrom = df$chrom, - id = df$id, - pos = df$pos, - A2 = df$A2, - A1 = df$A1 - ) - optional <- intersect(c("variance", "allele_freq", "n_nomiss"), names(df)) - mutate( - out, - !!!set_names(map(optional, .refMetaColumn, df = df), optional) - ) -} - -# @noRd -.refMetaColumn <- function(col, df) { - df[[col]] -} - # Filter plink2 / plink1 variant info to the requested region. # @noRd .refRegionFilter <- function(info, region) { @@ -1480,17 +1269,16 @@ matchVariantsToKeep <- function(variantInfo, keepVariantsPath) { } } - #' Load genotype data for a specific region #' #' Auto-detects PLINK2 (.pgen/.pvar[.zst]/.psam), PLINK1 (.bed/.bim/.fam), VCF -#' (.vcf/.vcf.gz/.bcf), or GDS (.gds) format and loads genotype data via -#' \code{\link{readGenotypes}} and \code{\link{extractBlockGenotypes}}. If a -#' stochastic genotype sidecar file (.afreq or .stochastic_meta.tsv) is found -#' alongside the genotype file, non-integer dosages are automatically rescaled -#' using the stored U_MIN/U_MAX values. +#' (.vcf.gz/.vcf.bgz, bgzipped with a tabix index), GDS (.gds) or BGEN (.bgen) +#' format, reads the file as a panel with \code{\link{readGenotypes}} and +#' loads the region's dosages. If a stochastic genotype sidecar file (.afreq +#' or .stochastic_meta.tsv) is found alongside the genotype file, non-integer +#' dosages are automatically rescaled using the stored U_MIN/U_MAX values. #' -#' @param genotype Path to the genotype data file (without extension). +#' @param genotype Path to the genotype data file, or a PLINK prefix. #' @param region The target region in the format "chr:start-end". #' @param keepIndel Whether to keep indel SNPs. #' @param keepVariantsPath Path to a file listing variants to keep. @@ -1521,15 +1309,22 @@ loadGenotypeRegion <- function( stochasticMetaPath = NULL, stochasticMetaFormat = NULL ) { - handle <- .loadGenoHandle(genotype) - handleSnpInfo <- snpInfo(handle) - snpIdx <- .loadGenoSnpIdx(handleSnpInfo, region) - # Samples x variants matrix (pecotmr convention); callers handle missing. + panel <- .readGenotypePanel( + genotype, + format = .requireGenotypeFormat(genotype, "loadGenotypeRegion") + ) + variants <- .rangesSnpInfo(SummarizedExperiment::rowRanges(panel)) + snpIdx <- .loadGenoSnpIdx(variants, region) + # Samples x variants matrix (pecotmr convention), its columns named by + # the file's own variant ids; callers handle missing. extracted <- list( - X = .dosageMatrix(handle, snpIdx, meanImpute = FALSE), + X = `colnames<-`( + .ldRefDosage(panel, snpIdx, meanImpute = FALSE), + variants$SNP[snpIdx] + ), variant_info = .loadGenoAttachAfreq( - handle, - .snpInfoToVariantInfo(slice(handleSnpInfo, snpIdx)) + panel, + .snpInfoToVariantInfo(slice(variants, snpIdx)) ) ) filtered <- .loadGenoPostFilter(extracted, keepIndel, keepVariantsPath) @@ -1542,37 +1337,13 @@ loadGenotypeRegion <- function( if (returnVariantInfo) result else result$X } -# Detect the genotype file format and open the matching GenotypeHandle. -# @noRd -.loadGenoHandle <- function(genotype) { - if (str_detect(genotype, "\\.(vcf|vcf\\.gz|bcf)$")) { - return(.readGenotypeHandle(genotype, format = "vcf")) - } - if (str_detect(genotype, "\\.gds$")) { - return(.readGenotypeHandle(genotype, format = "gds")) - } - if (hasPlink2Files(genotype)) { - return(.readGenotypeHandle(genotype, format = "plink2")) - } - if (hasPlink1Files(genotype)) { - return(.readGenotypeHandle(genotype, format = "plink1")) - } - msg <- glue( - "Genotype files not found at: {genotype}\n", - " Expected: .vcf/.vcf.gz/.bcf, .gds, or PLINK prefix ", - "(.pgen/.pvar[.zst]/.psam or .bed/.bim/.fam)", - .trim = FALSE - ) - abort(msg) -} - # Resolve the SNP indices for a region (all variants when region is NULL). # @noRd -.loadGenoSnpIdx <- function(handleSnpInfo, region) { +.loadGenoSnpIdx <- function(variants, region) { if (is.null(region)) { - return(seq_len(nrow(handleSnpInfo))) + return(seq_len(nrow(variants))) } - snpIdx <- .regionToSnpIdx(handleSnpInfo, region) + snpIdx <- .regionToSnpIdx(variants, region) if (length(snpIdx) == 0) { msg <- glue("No SNPs found in the specified region {region}") abort(msg, class = "NoSnpsError") @@ -1583,11 +1354,11 @@ loadGenotypeRegion <- function( # Attach allele frequency from the .afreq sidecar (plink2 only). #' @importFrom dplyr left_join #' @noRd -.loadGenoAttachAfreq <- function(handle, variantInfo) { - if (genotypeFormat(handle) != "plink2") { +.loadGenoAttachAfreq <- function(panel, variantInfo) { + if (!identical(.ldRefFormat(panel), "plink2")) { return(variantInfo) } - afreq <- readAfreq(.genotypeReadPath(handle)) + afreq <- readAfreq(.ldRefReadPath(panel)) if (is.null(afreq)) { return(variantInfo) } @@ -1631,8 +1402,10 @@ loadGenotypeRegion <- function( ) } -# Detect stochastic genotype scaling and restore the original scale from a -# metadata sidecar; warn (only) when non-integer dosages have no sidecar. +# Restore a stochastic sketch's original scale from its metadata sidecar. +# Without one the dosages are taken as they are: a dosage need not be a whole +# number (imputed BGEN, VCF FORMAT/DS, PLINK2 dosages), so whether the values +# are whole says nothing about whether the file is a sketch. # @noRd .loadGenoInvertStochastic <- function( result, @@ -1642,7 +1415,6 @@ loadGenotypeRegion <- function( ) { metaPath <- stochasticMetaPath %||% findStochasticMeta(genotype) if (is.null(metaPath)) { - .loadGenoWarnStochastic(result$X) return(result) } smeta <- readStochasticMeta(metaPath, format = stochasticMetaFormat) @@ -1681,45 +1453,14 @@ loadGenotypeRegion <- function( restored } -# Warn when non-integer dosages are present but no stochastic sidecar was found. -# @noRd -.loadGenoWarnStochastic <- function(X) { - if (all(X == round(X), na.rm = TRUE)) { - return(invisible(NULL)) - } - msg <- glue( - "Non-integer genotype values detected but no stochastic metadata ", - "sidecar found. Place a .afreq or .stochastic_meta.tsv file with ", - "u_min/u_max columns alongside the genotype files to restore the ", - "original scale." - ) - warn(msg) -} - # ---- map/apply helpers (lambda-free callbacks) --------------------------- -# The first ALT allele of a variant (as character). -# @noRd -.gtFirstAllele <- function(x) { - as.character(x)[1] -} - # The dosage assay matrix of one per-chromosome SummarizedExperiment. # @noRd .seDosage <- function(se) { SummarizedExperiment::assay(se, "dosage") } -# ALT (A1) dosage from a VCF GT string; NA for missing ("./." or NA). -# @noRd -.gtStringToDosage <- function(x) { - if (is.na(x) || x == "./.") { - return(NA_real_) - } - alleles <- str_split(x, "[/|]")[[1L]] - sum(alleles != "0") -} - # Variant `i`'s chromosome from an open pvar handle. # @noRd .pvarChrom <- function(i, pvar) { @@ -1744,7 +1485,7 @@ loadGenotypeRegion <- function( pgenlibr::GetAlleleCode(pvar, i, k) } -# ---- .withGds resource-body functions (run inside the open-GDS bracket) --- +# ---- GDS resource-body functions (run inside an open-GDS bracket) --------- # The sample ids stored in an open GDS. # @noRd @@ -1752,42 +1493,26 @@ loadGenotypeRegion <- function( as.character(gdsfmt::read.gdsn(gdsfmt::index.gdsn(gds, "sample.id"))) } -# The dosage matrix for `handle`'s `snpIdx` variants (NULL when none selected). -# snpgdsGetGeno counts the first allele (labelled A1 in .gdsSnpInfo), so no flip -# is needed; it also handles non-contiguous SNP selection. +# The sample-LD matrix of the SNPs `snpIds` (NA correlations -> 0). # @noRd -.gdsBlockGeno <- function(gds, handle, snpIdx) { - snpIds <- snpInfo(handle)$SNP[snpIdx] - geno <- SNPRelate::snpgdsGetGeno( - gds, - snp.id = snpIds, - with.id = FALSE, - verbose = FALSE - ) - if (is.null(geno) || length(geno) == 0) { - return(NULL) - } - `storage.mode<-`(geno, "double") -} - -# The sample-LD matrix for `handle`'s `snpIdx` variants (NA correlations -> 0). -# @noRd -.gdsBlockLd <- function(gds, handle, snpIdx) { +.gdsBlockLd <- function(gds, snpIds) { # snpgdsLDMat() returns variants in FILE order whatever order snp.id is - # given in, and labels nothing. Ask in ascending order and permute back, - # exactly as the block readers do, so the matrix agrees with its names. - ord <- order(.genotypeFilePos(handle, snpIdx)) - snpIds <- snpInfo(handle)$SNP[snpIdx[ord]] + # given in, and labels nothing. Ask in file order and permute back, so the + # matrix agrees with its names; the file's own ids are passed, since a + # GDS may store them as integers. + fileIds <- gdsfmt::read.gdsn(gdsfmt::index.gdsn(gds, "snp.id")) + pos <- match(as.character(snpIds), as.character(fileIds)) + ord <- order(pos) ldMat <- SNPRelate::snpgdsLDMat( gds, - snp.id = snpIds, + snp.id = fileIds[pos[ord]], method = "corr", slide = -1, verbose = FALSE ) raw <- replace(ldMat$LD, is.na(ldMat$LD), 0) inv <- order(ord) - ids <- snpInfo(handle)$SNP[snpIdx] + ids <- as.character(snpIds) `dimnames<-`(raw[inv, inv, drop = FALSE], list(ids, ids)) } @@ -1811,3 +1536,992 @@ loadGenotypeRegion <- function( A2 = a2 ) } + +# ============================================================================= +# BGEN genotype reading +# ----------------------------------------------------------------------------- +# A "bgen" GenotypeHandle reads a BGEN file lazily, without converting it: +# its variants come from the .bgi index (bgenix's SQLite database), its +# samples from the file's sample block or a .sample file beside it, and a +# block's dosages are read record by record at the offsets the index gives. +# +# Every revision is read: layout 1 (BGEN 1.1: diploid, biallelic, three +# 16-bit probabilities per sample, zlib or no compression) and layout 2 (BGEN +# 1.2 and 1.3: phased or unphased, any ploidy, any bit depth, zlib, zstd or +# no compression). A record with more than two alleles becomes one variant +# per non-first allele. The dosage is the expected count of A1, the variant's +# second (or later) allele, with the first as A2, as bgen's own tools count +# it: from 0 to the sample's ploidy. +# ============================================================================= + +# The handle of a BGEN file. Only its header, its index and its sample ids +# are read here. +# @noRd +#' @importFrom checkmate assertFileExists +.makeBgenHandle <- function(path) { + walk(c("DBI", "RSQLite"), .bgenRequirePackage) + assertFileExists(path, access = "r", .var.name = "BGEN file") + path <- normalizePath(path) + header <- .bgenReadHeader(path, withSamples = TRUE) + sampleIds <- header$sampleIds %||% .bgenSampleFileIds(path) + if (length(sampleIds) != header$nSamples) { + abort(glue( + "BGEN file {path} declares {header$nSamples} samples but ", + "{length(sampleIds)} sample ids were found." + )) + } + new( + "GenotypeHandle", + path = path, + format = "bgen", + snpInfo = .withFileIdx(.bgenSnpInfo(path)), + nSamples = as.integer(header$nSamples), + sampleIds = sampleIds, + pgenPtr = NULL + ) +} + +# @noRd +.bgenRequirePackage <- function(pkg) { + if (!requireNamespace(pkg, quietly = TRUE)) { + abort(glue( + "Package '{pkg}' is required for reading BGEN files, whose .bgi ", + "index is an SQLite database." + )) + } + invisible(NULL) +} + +# A little-endian unsigned integer from raw bytes, as a double (a uint32 can +# exceed R's integer range). +# @noRd +.bgenUint <- function(bytes) { + sum(as.numeric(bytes) * 256^(seq_along(bytes) - 1L)) +} + +# The header block: the sample count, the compression and layout flags and, +# when the file stores them and they are asked for, the sample ids. An +# unknown layout or compression is refused here, before any variant is +# read. +# @noRd +.bgenReadHeader <- function(path, withSamples = FALSE) { + con <- file(path, "rb") + on.exit(close(con)) + fixed <- readBin(con, "raw", 20L) + if (length(fixed) < 20L) { + abort(glue("{path} is too short to be a BGEN file.")) + } + headerLength <- .bgenUint(fixed[5:8]) + magic <- fixed[17:20] + if (!identical(magic, charToRaw("bgen")) && any(magic != as.raw(0L))) { + abort(glue("{path} is not a BGEN file (no 'bgen' magic number).")) + } + readBin(con, "raw", headerLength - 20) + flags <- as.integer(readBin(con, "raw", 4L)) + compression <- bitwAnd(flags[[1L]], 3L) + layout <- bitwAnd(bitwShiftR(flags[[1L]], 2L), 15L) + .bgenCheckFlags(path, compression, layout) + nSamples <- .bgenUint(fixed[13:16]) + hasIds <- bitwAnd(flags[[4L]], 128L) > 0L + list( + nSamples = nSamples, + compression = compression, + layout = layout, + sampleIds = if (withSamples && hasIds) { + .bgenReadSampleBlock(con, nSamples) + } + ) +} + +# @noRd +.bgenCheckFlags <- function(path, compression, layout) { + if (!is_in(layout, 1:2)) { + abort(glue( + "{path} has BGEN layout {layout}; the spec defines layouts 1 and 2." + )) + } + if (compression > 2L) { + abort(glue("{path} has an unknown BGEN compression ({compression}).")) + } + if (layout == 1L && compression == 2L) { + abort(glue( + "{path} is a layout-1 (BGEN 1.1) file compressed with zstd, which ", + "the spec does not allow." + )) + } + invisible(NULL) +} + +# The sample identifier block, which follows the header: its length, the +# sample count again, then each id as a 2-byte length and its bytes. +# @noRd +.bgenReadSampleBlock <- function(con, nSamples) { + blockLength <- .bgenUint(readBin(con, "raw", 4L)) + block <- readBin(con, "raw", blockLength - 4) + if (.bgenUint(block[1:4]) != nSamples) { + abort("The BGEN sample block's sample count disagrees with its header.") + } + bgenSampleIdsCpp(block[-(1:4)], as.integer(nSamples)) +} + +# The sample ids of a BGEN file that does not store them, from the .sample +# file beside it (`.sample`): the first column, after the header line +# and the line of column types. +# @noRd +#' @importFrom readr read_table cols col_character +.bgenSampleFileIds <- function(path) { + samplePath <- str_c(.genotypeStem(path), ".sample") + if (!file.exists(samplePath)) { + abort(c( + glue("{path} stores no sample ids, and {samplePath} is missing."), + i = "Put the Oxford-format .sample file beside the .bgen file." + )) + } + tbl <- read_table( + samplePath, + col_types = cols(.default = col_character()), + progress = FALSE + ) + as.character(tbl[[1L]][-1L]) +} + +# The variant table: one row per (record, non-first allele), in file order, +# with each record's offset and length from the .bgi index and the allele the +# row reads. Built column-wise for the biallelic records, which are nearly +# all of them; only a multi-allelic record is read to learn its alleles. +# @noRd +#' @importFrom dplyr arrange bind_rows +#' @importFrom purrr pmap +.bgenSnpInfo <- function(path) { + index <- .bgenReadIndex(str_c(path, ".bgi")) + multi <- index$number_of_alleles > 2L + rows <- .bgenBiallelicRows(index[!multi, ]) + if (!any(multi)) { + return(rows) + } + warn(glue( + "{sum(multi)} BGEN record(s) of {path} carry more than two alleles; ", + "each is read as one biallelic variant per non-first allele." + )) + split <- pmap( + list( + chrom = index$chromosome[multi], + pos = index$position[multi], + alleles = .bgenRecordAlleles( + path, + index$file_start_position[multi], + index$size_in_bytes[multi] + ), + offset = index$file_start_position[multi], + size = index$size_in_bytes[multi] + ), + .bgenSplitRecordRows + ) + arrange( + bind_rows(rows, list_rbind(split)), + .data$bgen_offset, + .data$bgen_allele + ) +} + +# The rows of the biallelic records: A2 the first allele, A1 the second. A +# record keeps its rsid as its id when it has one, else is named +# chr:pos:A2:A1. +# @noRd +.bgenBiallelicRows <- function(index) { + ids <- formatVariantId( + index$chromosome, + index$position, + index$allele1, + index$allele2 + ) + named <- !is.na(index$rsid) & nzchar(index$rsid) & index$rsid != "." + tibble( + SNP = if_else(named, index$rsid, ids), + CHR = canonChrom(index$chromosome), + BP = as.integer(index$position), + A1 = index$allele2, + A2 = index$allele1, + bgen_offset = as.numeric(index$file_start_position), + bgen_size = as.numeric(index$size_in_bytes), + bgen_allele = rep(2L, nrow(index)) + ) +} + +# A multi-allelic record's rows: A2 its first allele, A1 each other allele +# in turn, every row named chr:pos:A2:A1 so they stay distinct. +# @noRd +.bgenSplitRecordRows <- function(chrom, pos, alleles, offset, size) { + others <- alleles[-1L] + tibble( + SNP = formatVariantId(chrom, pos, alleles[[1L]], others), + CHR = canonChrom(chrom), + BP = as.integer(pos), + A1 = others, + A2 = alleles[[1L]], + bgen_offset = as.numeric(offset), + bgen_size = as.numeric(size), + bgen_allele = seq_along(others) + 1L + ) +} + +# The .bgi index's Variant table, in file order. +# @noRd +.bgenReadIndex <- function(bgiPath) { + if (!file.exists(bgiPath)) { + abort(c( + str_c( + "A BGEN file is read through its .bgi index: ", + bgiPath, + " is missing." + ), + i = "Build it with bgenix (`bgenix -g .bgen -index`)." + )) + } + con <- DBI::dbConnect( + RSQLite::SQLite(), + bgiPath, + flags = RSQLite::SQLITE_RO + ) + on.exit(DBI::dbDisconnect(con)) + as_tibble(DBI::dbGetQuery( + con, + str_c( + "SELECT chromosome, position, rsid, number_of_alleles, allele1, ", + "allele2, file_start_position, size_in_bytes FROM Variant ", + "ORDER BY file_start_position" + ) + )) +} + +# The alleles of the records at `offsets`, read from their identifying data: +# the .bgi index holds only the first two. +# @noRd +.bgenRecordAlleles <- function(path, offsets, sizes) { + con <- file(path, "rb") + on.exit(close(con)) + map2(offsets, sizes, .bgenReadRecordAlleles, con = con) +} + +# Only a layout-2 record can carry more than two alleles, so only one is +# parsed here. +# @noRd +.bgenReadRecordAlleles <- function(offset, size, con) { + record <- .bgenReadRecord(con, offset, size) + .bgenParseIdentifying(record, layout = 2L)$alleles +} + +# @noRd +.bgenReadRecord <- function(con, offset, size) { + seek(con, where = offset) + readBin(con, "raw", size) +} + +# A record's identifying data: its alleles, and where its genotype block +# starts (1-based). A layout-1 record opens with its sample count and has two +# alleles without saying so; a layout-2 one states its allele count. +# @noRd +.bgenParseIdentifying <- function(record, layout) { + at <- if (layout == 1L) 5L else 1L + for (field in 1:3) { + # variant id, rsid, chromosome: a 2-byte length and the bytes + at <- at + 2L + .bgenUint(record[at:(at + 1L)]) + } + at <- at + 4L + nAlleles <- 2L + if (layout == 2L) { + nAlleles <- .bgenUint(record[at:(at + 1L)]) + at <- at + 2L + } + alleles <- character(nAlleles) + for (k in seq_len(nAlleles)) { + len <- .bgenUint(record[at:(at + 3L)]) + alleles[[k]] <- rawToChar(record[(at + 4L):(at + 3L + len)]) + at <- at + 4L + len + } + list(alleles = alleles, genotypeStart = at) +} + +# The samples x variants dosages of the handle's variants at `snpIdx`: each +# record read once, its probabilities decompressed and decoded for the +# alleles its rows ask about. +# @noRd +.extractBlockBgen <- function(handle, snpIdx) { + si <- slice(snpInfo(handle), snpIdx) + path <- .genotypeReadPath(handle) + header <- .bgenReadHeader(path) + con <- file(path, "rb") + on.exit(close(con)) + offsets <- unique(si$bgen_offset) + blocks <- map( + offsets, + .bgenRecordDosage, + si = si, + con = con, + header = header, + nSamples = handle@nSamples + ) + out <- exec(cbind, !!!blocks) + # The blocks hold the rows grouped by record; put them back in `si`'s + # order. + rowOrder <- list_c(map(offsets, .bgenRowsOf, si = si)) + out[, order(rowOrder), drop = FALSE] +} + +# @noRd +.bgenRowsOf <- function(offset, si) { + which(si$bgen_offset == offset) +} + +# One record's dosage columns, for the rows of `si` that read it. +# @noRd +.bgenRecordDosage <- function(offset, si, con, header, nSamples) { + rows <- .bgenRowsOf(offset, si) + record <- .bgenReadRecord(con, offset, si$bgen_size[[rows[[1L]]]]) + if (header$layout == 1L) { + return(.bgenLayout1Dosage(record, header$compression, nSamples)) + } + probabilities <- .bgenProbabilityData(record, header$compression) + bgenDosageCpp( + probabilities, + as.integer(nSamples), + as.integer(si$bgen_allele[rows]) + ) +} + +# A layout-1 record's dosage column: per sample three 16-bit probabilities, +# of the genotypes AA, AB and BB, each out of 32768, zlib-compressed or +# stored as they are. The second allele's expected count is P(AB) + 2 P(BB); +# a sample whose three are all zero is missing. +# @noRd +.bgenLayout1Dosage <- function(record, compression, nSamples) { + at <- .bgenParseIdentifying(record, layout = 1L)$genotypeStart + nBytes <- 6 * nSamples + data <- if (compression == 0L) { + record[at:(at + nBytes - 1)] + } else { + stored <- .bgenUint(record[at:(at + 3L)]) + memDecompress(record[(at + 4L):(at + 3L + stored)], type = "gzip") + } + if (length(data) != nBytes) { + abort("A layout-1 BGEN record holds the wrong amount of data.") + } + p <- matrix( + readBin( + data, + "integer", + n = 3 * nSamples, + size = 2L, + signed = FALSE, + endian = "little" + ) / + 32768, + nrow = 3L + ) + dosage <- p[2L, ] + 2 * p[3L, ] + matrix(replace(dosage, colSums(p) == 0, NA_real_), ncol = 1L) +} + +# A layout-2 record's genotype probability data, uncompressed. +# @noRd +.bgenProbabilityData <- function(record, compression) { + at <- .bgenParseIdentifying(record, layout = 2L)$genotypeStart + stored <- .bgenUint(record[at:(at + 3L)]) + if (compression == 0L) { + return(record[(at + 4L):(at + 3L + stored)]) + } + uncompressed <- .bgenUint(record[(at + 4L):(at + 7L)]) + payload <- record[(at + 8L):(at + 3L + stored)] + .bgenUncompress(payload, compression, uncompressed) +} + +# zlib through base R; zstd through archive, since R need not be built with +# it. +# @noRd +#' @importFrom archive archive_read +.bgenUncompress <- function(payload, compression, uncompressed) { + if (compression == 1L) { + return(memDecompress(payload, type = "gzip")) + } + con <- archive_read(rawConnection(payload), format = "raw", filter = "zstd") + open(con, "rb") + on.exit(close(con)) + readBin(con, "raw", uncompressed) +} + +# ============================================================================= +# VCF, GDS and PLINK1 genotype panels +# ----------------------------------------------------------------------------- +# A VCF, GDS or PLINK1 file is read as a genotype panel directly rather than +# through a GenotypeHandle: its variants and samples are read here, its +# dosages through a GenotypeDosageSeed, a block at a time, when something +# touches them. The +# panel records where it came from (metadata(panel)$genotypeSource), which is +# what anything needing the file reads -- a stochastic sketch's .afreq +# sidecar, the per-chromosome files of a manifest. +# +# A record with several ALT alleles becomes one variant per ALT allele, with a +# warning, its dosage the count of that allele, as for BGEN; a record with no +# ALT allele holds no variant. The dosage is FORMAT/DS where the file declares +# one, else the count from the GT calls. A SNPRelate GDS stores genotype codes +# counting the first of a SNP's two alleles, which is therefore A1, as +# SNPRelate reads it. A PLINK1 .bed's codes are read through PlinkMatrix as +# the count of A1, the .bim's fifth column. +# ============================================================================= + +# @noRd +.requireReaderPackage <- function(pkg, format) { + if (!requireNamespace(pkg, quietly = TRUE)) { + abort(glue("Package '{pkg}' is required for reading {format} files.")) + } + invisible(NULL) +} + +# The panel of a VCF, GDS or PLINK1 file, without the record of a stochastic +# sketch's sidecar (.withSourceProjection() adds it, once the panel is whole). +# @noRd +.readDosagePanel <- function(path, format, vcfArgs = list()) { + switch( + format, + vcf = .vcfPanel(path, vcfArgs), + gds = .gdsPanel(path), + plink1 = .plinkBedPanel(path) + ) +} + +# A panel over a GenotypeDosageSeed: its rows' variants as rowRanges, shaped +# as .genotypeExperiment() shapes a handle's, and where it came from. +# @noRd +.dosageSeedPanel <- function(seed, rows, format, path) { + dosage <- DelayedArray::DelayedArray(seed) + SummarizedExperiment::SummarizedExperiment( + assays = list(dosage = dosage), + rowRanges = .snpInfoRanges(rows, rownames(dosage)), + colData = S4Vectors::DataFrame(row.names = colnames(dosage)), + metadata = list( + genotypeSource = list( + format = format, + path = path, + chromPaths = character(0) + ) + ) + ) +} + +# One row per (record, ALT allele), in file order: A2 the record's REF +# allele, A1 the ALT allele the row counts. A record keeps its own id when it +# has one and a single ALT allele; otherwise each of its rows is named +# chr:pos:A2:A1, so they stay distinct. +# @noRd +.recordVariantRows <- function(records, path, label) { + nAlt <- lengths(records$alt) + multi <- nAlt > 1L + if (any(multi)) { + warn(glue( + "{sum(multi)} {label} record(s) of {path} carry more than one ", + "ALT allele; each is read as one biallelic variant per ALT allele." + )) + } + record <- rep(seq_len(nrow(records)), nAlt) + a1 <- as.character(list_c(records$alt)) + a2 <- records$ref[record] + named <- !is.na(records$id) & !multi + tibble( + SNP = if_else( + named[record], + records$id[record], + formatVariantId(records$chrom[record], records$pos[record], a2, a1) + ), + CHR = canonChrom(records$chrom[record]), + BP = as.integer(records$pos[record]), + A1 = a1, + A2 = a2, + record = record, + allele = sequence(nAlt) + ) +} + +# ---- VCF ------------------------------------------------------------------- + +# A VCF's panel. Only its header and its records' fixed fields are read here. +# @noRd +.vcfPanel <- function(path, vcfArgs = list()) { + .requireReaderPackage("VariantAnnotation", "VCF") + file <- .vcfIndexedFile(path) + header <- VariantAnnotation::scanVcfHeader(file) + field <- .vcfDosageField(header, path(file)) + records <- .vcfRecords(file, vcfArgs) + rows <- .recordVariantRows(records, path(file), "VCF") + seed <- methods::new( + "GenotypeDosageSeed", + backend = file, + field = if (field == "DS") "vcfDs" else "vcfGt", + rowRecord = rows$record, + rowAllele = rows$allele, + records = GRanges( + seqnames = records$chrom, + ranges = IRanges(records$pos, records$end), + posRank = .positionRank(records$chrom, records$pos) + ), + dn = list( + normalizeVariantId(rows$SNP), + as.character(VariantAnnotation::samples(header)) + ) + ) + .dosageSeedPanel(seed, rows, "vcf", path(file)) +} + +# The VCF at `path` with its tabix index, through which its records are read +# a block at a time. A VCF without one cannot be read lazily; a BCF cannot be +# read at all, Rsamtools having its BCF support disabled. +# @noRd +#' @importFrom checkmate assertFileExists +.vcfIndexedFile <- function(path) { + assertFileExists(path, access = "r", .var.name = "VCF file") + path <- normalizePath(path) + if (str_ends(str_to_lower(path), "\\.bcf")) { + abort(c( + glue("{path} is a BCF file, which pecotmr cannot read."), + i = str_c( + "Rsamtools ships with its BCF support disabled; convert it ", + "to a bgzipped, tabix-indexed VCF." + ) + )) + } + index <- str_c(path, ".tbi") + if (!file.exists(index)) { + abort(c( + glue( + "A VCF is read a block at a time through its tabix index, ", + "and {index} is missing." + ), + i = str_c( + "Compress the VCF with bgzip and index it, e.g. with ", + "Rsamtools::bgzip() and Rsamtools::indexTabix(format = 'vcf')." + ) + )) + } + VariantAnnotation::VcfFile(path, index = index) +} + +# The FORMAT field the dosages are read from: DS when the header declares +# it, with one value per ALT allele (Number=A) or one per record (Number=1), +# else GT. +# @noRd +.vcfDosageField <- function(header, path) { + declared <- VariantAnnotation::geno(header) + fields <- rownames(declared) + if (is_in("DS", fields)) { + number <- declared$Number[match("DS", fields)] + if (!is_in(number, c("A", "1"))) { + abort(glue( + "{path} declares FORMAT/DS with Number={number}; a dosage ", + "has one value per ALT allele (Number=A) or one per record ", + "(Number=1)." + )) + } + return("DS") + } + if (is_in("GT", fields)) { + return("GT") + } + abort(glue( + "{path} declares neither FORMAT/DS nor FORMAT/GT, so it holds no ", + "genotypes to read." + )) +} + +# One row per record of the VCF, in file order: its position and the end of +# its REF allele, its own ID (NA where it has none), its REF allele and its +# ALT alleles. +# @noRd +.vcfRecords <- function(file, vcfArgs) { + vcf <- exec( + VariantAnnotation::readVcf, + file, + param = VariantAnnotation::ScanVcfParam( + fixed = "ALT", + info = NA, + geno = NA + ), + !!!vcfArgs + ) + rr <- SummarizedExperiment::rowRanges(vcf) + chrom <- as.character(seqnames(rr)) + pos <- as.integer(start(rr)) + ref <- as.character(rr$REF) + alt <- as.list(methods::as(rr$ALT, "CharacterList")) + tibble( + chrom = chrom, + pos = pos, + end = as.integer(end(rr)), + id = .vcfRecordIds(names(rr), chrom, pos, ref, alt), + ref = ref, + alt = map(alt, .vcfAltAlleles) + ) +} + +# Each record's own ID, or NA where it has none. VariantAnnotation names a +# record whose ID is "." from the line's own text, CHROM:POS_REF/ALT, and +# that name is no ID of the record's. +# @noRd +.vcfRecordIds <- function(ids, chrom, pos, ref, alt) { + if (is.null(ids)) { + return(rep(NA_character_, length(chrom))) + } + altText <- map_chr(alt, str_flatten, collapse = ",") + synthetic <- str_c( + chrom, + ":", + pos, + "_", + ref, + "/", + if_else(altText == "", ".", altText) + ) + if_else(ids == synthetic | ids == ".", NA_character_, ids) +} + +# A record's ALT alleles; a record whose ALT is "." has none. +# @noRd +.vcfAltAlleles <- function(alt) { + alt[!is_in(alt, c("", "."))] +} + +# Each record's rank among the records starting at its position, in file +# order: 1 for nearly all of them. +# @noRd +.positionRank <- function(chrom, pos) { + tibble(chrom = chrom, pos = pos) |> + mutate(rank = row_number(), .by = all_of(c("chrom", "pos"))) |> + pull("rank") +} + +# ---- GDS ------------------------------------------------------------------- + +# A GDS file's panel: a SNPRelate (SNP_ARRAY) or SeqArray (SEQ_ARRAY) file, +# told apart by the format its root node records. +# @noRd +#' @importFrom checkmate assertFileExists +.gdsPanel <- function(path) { + walk(c("gdsfmt", "GDSArray"), .requireReaderPackage, format = "GDS") + assertFileExists(path, access = "r", .var.name = "GDS file") + path <- normalizePath(path) + kind <- .withGdsFile(path, .gdsFileFormat) + switch( + kind, + SNP_ARRAY = .snpGdsPanel(path), + SEQ_ARRAY = .seqArrayPanel(path), + abort(glue( + "{path} is a GDS file of format '{kind}'; genotypes are read ", + "from SNPRelate (SNP_ARRAY) and SeqArray (SEQ_ARRAY) files." + )) + ) +} + +# Resource bracket: open the GDS at `path` read-only with gdsfmt, close it on +# exit, and run `fn(gds, ...)`. A file GDSArray already holds open in this +# session is opened again rather than refused. +# @noRd +.withGdsFile <- function(path, fn, fnArgs = list()) { + gds <- gdsfmt::openfn.gds(path, readonly = TRUE, allow.duplicate = TRUE) + on.exit(gdsfmt::closefn.gds(gds)) + exec(fn, gds, !!!fnArgs) +} + +# The kind of GDS file an open GDS is, as its root node records it. +# @noRd +.gdsFileFormat <- function(gds) { + as.character(gdsfmt::get.attr.gdsn(gds$root)$FileFormat %||% "unknown") +} + +# A node of an open GDS, read whole. +# @noRd +.gdsRead <- function(gds, name) { + gdsfmt::read.gdsn(gdsfmt::index.gdsn(gds, name)) +} + +# A SNPRelate GDS's panel. +# @noRd +.snpGdsPanel <- function(path) { + meta <- .withGdsFile(path, .snpGdsMeta) + rows <- mutate( + meta$snpInfo, + SNP = as.character(.data$SNP), + CHR = canonChrom(.data$CHR), + record = row_number(), + allele = 1L + ) + backend <- DelayedArray::seed(GDSArray::GDSArray(path, "genotype")) + stored <- c(nrow(rows), length(meta$sampleIds)) + expected <- if (meta$snpFirst) stored else rev(stored) + if (!identical(as.integer(dim(backend)), as.integer(expected))) { + abort(glue( + "The genotype matrix of {path} is ", + "{str_flatten(dim(backend), ' x ')}, but the file lists ", + "{nrow(rows)} SNPs and {length(meta$sampleIds)} samples." + )) + } + seed <- methods::new( + "GenotypeDosageSeed", + backend = backend, + field = if (meta$snpFirst) "snpGdsSnpOrder" else "snpGdsSampleOrder", + rowRecord = rows$record, + rowAllele = rows$allele, + records = IRanges(rows$record, width = 1L), + dn = list(normalizeVariantId(rows$SNP), meta$sampleIds) + ) + .dosageSeedPanel(seed, rows, "gds", path) +} + +# An open SNPRelate GDS's SNPs, its samples, and how its genotype matrix is +# stored: SNP by SNP unless its node says sample.order, as SNPRelate reads +# it. +# @noRd +.snpGdsMeta <- function(gds) { + node <- gdsfmt::index.gdsn(gds, "genotype") + list( + snpInfo = .gdsReadSnpInfo(gds), + sampleIds = .gdsReadSampleIds(gds), + snpFirst = !is_in("sample.order", names(gdsfmt::get.attr.gdsn(node))) + ) +} + +# A SeqArray GDS's panel. +# @noRd +.seqArrayPanel <- function(path) { + meta <- .withGdsFile(path, .seqArrayMeta, fnArgs = list(path = path)) + rows <- .recordVariantRows(meta$records, path, "SeqArray GDS") + counts <- as.integer(meta$counts) + seed <- methods::new( + "GenotypeDosageSeed", + backend = DelayedArray::seed(GDSArray::GDSArray(path, meta$node)), + field = meta$field, + rowRecord = rows$record, + rowAllele = rows$allele, + records = IRanges(start = cumsum(counts) - counts + 1L, width = counts), + dn = list(normalizeVariantId(rows$SNP), meta$sampleIds) + ) + .dosageSeedPanel(seed, rows, "gds", path) +} + +# An open SeqArray GDS's samples and records, and the node its dosages are +# read from, with how many of that node's columns (or 2-bit planes) each +# record takes. +# @noRd +.seqArrayMeta <- function(gds, path) { + alleles <- str_split(as.character(.gdsRead(gds, "allele")), ",") + c( + list( + sampleIds = as.character(.gdsRead(gds, "sample.id")), + records = tibble( + chrom = as.character(.gdsRead(gds, "chromosome")), + pos = as.integer(.gdsRead(gds, "position")), + id = .seqArrayIds(gds, length(alleles)), + ref = map_chr(alleles, 1L), + alt = map(alleles, .seqArrayAltAlleles) + ) + ), + .seqArrayDosageNode(gds, path) + ) +} + +# Each record's own ID, or NA where it has none or the file stores none. +# @noRd +.seqArrayIds <- function(gds, nRecords) { + node <- gdsfmt::index.gdsn(gds, "annotation/id", silent = TRUE) + if (is.null(node)) { + return(rep(NA_character_, nRecords)) + } + ids <- as.character(gdsfmt::read.gdsn(node)) + if_else(is_in(ids, c("", ".")), NA_character_, ids) +} + +# A record's ALT alleles: every allele after its first, the REF. +# @noRd +.seqArrayAltAlleles <- function(alleles) { + .vcfAltAlleles(alleles[-1L]) +} + +# Where a SeqArray GDS's dosages are: its FORMAT/DS when it stores one, with +# one value per ALT allele or one per record, else its genotype calls. +# @noRd +.seqArrayDosageNode <- function(gds, path) { + ds <- gdsfmt::index.gdsn(gds, "annotation/format/DS", silent = TRUE) + if (!is.null(ds)) { + number <- as.character(gdsfmt::get.attr.gdsn(ds)$Number %||% "") + if (!is_in(number, c("A", "1"))) { + abort(glue( + "{path} stores FORMAT/DS with Number={number}; a dosage has ", + "one value per ALT allele (Number=A) or one per record ", + "(Number=1)." + )) + } + return(list( + node = "annotation/format/DS/data", + field = "seqArrayDs", + counts = .gdsRead(gds, "annotation/format/DS/@data") + )) + } + .seqArrayCheckGenotypes(gds, path) + list( + node = "genotype/data", + field = "seqArrayGt", + counts = .gdsRead(gds, "genotype/@data") + ) +} + +# The genotype calls are read from their 2-bit planes, so a file storing +# them otherwise, or storing calls beyond its ploidy apart from them, is +# refused rather than misread. +# @noRd +.seqArrayCheckGenotypes <- function(gds, path) { + data <- gdsfmt::objdesp.gdsn(gdsfmt::index.gdsn(gds, "genotype/data")) + if (!identical(data$trait, "Bit2")) { + abort(glue( + "{path} stores its genotype calls as {data$trait}; SeqArray ", + "stores them in 2-bit planes, which is what is read." + )) + } + extra <- gdsfmt::index.gdsn(gds, "genotype/extra.index", silent = TRUE) + nExtra <- if (is.null(extra)) 0L else gdsfmt::objdesp.gdsn(extra)$dim[[2L]] + if (nExtra > 0L) { + abort(glue( + "{path} stores {nExtra} genotype call(s) beyond its ploidy, ", + "which are not read." + )) + } + invisible(NULL) +} + +# ---- PLINK1 ---------------------------------------------------------------- + +# A PLINK1 fileset's panel: its .bim and .fam are read here, its genotypes a +# block at a time through PlinkMatrix (.plinkBedSeedRead()). The stem is +# recorded absolute, as a VCF's or GDS file's path is, so the panel still +# reads from another working directory. +# @noRd +.plinkBedPanel <- function(path) { + .requireReaderPackage("PlinkMatrix", "PLINK1") + named <- .plink1RequireFiles(path) + stem <- file.path(normalizePath(dirname(named)), basename(named)) + meta <- .plink1ReadMeta(stem) + nVariants <- nrow(meta$snpInfo) + seed <- methods::new( + "GenotypeDosageSeed", + backend = stem, + field = "plinkBed", + rowRecord = seq_len(nVariants), + rowAllele = rep(1L, nVariants), + records = IRanges(seq_len(nVariants), width = 1L), + dn = list(normalizeVariantId(meta$snpInfo$SNP), meta$sampleIds) + ) + .dosageSeedPanel(seed, meta$snpInfo, "plink1", stem) +} + +# Resolve the plink1 stem and assert its .bed/.bim/.fam all exist. +# @noRd +#' @importFrom checkmate assertFileExists +.plink1RequireFiles <- function(path) { + stem <- .genotypeStem(path) + assertFileExists( + str_c(stem, c(".bed", ".bim", ".fam")), + access = "r", + .var.name = "Plink file" + ) + stem +} + +# Read the .bim / .fam sidecars into snpInfo + sample metadata. Returns +# list(snpInfo, sampleIds, nSamples). +# @noRd +#' @importFrom readr read_table cols col_character +.plink1ReadMeta <- function(stem) { + # col_types all-character so readr never coerces a column: a bim whose + # allele column is uniformly "T"/"F" (all-A/T SNPs) would otherwise become + # logical, silently corrupting A1/A2 (BP is cast to integer below). + bim <- read_table( + str_c(stem, ".bim"), + col_names = c("CHR", "SNP", "CM", "BP", "A1", "A2"), + col_types = cols(.default = col_character()) + ) + fam <- read_table( + str_c(stem, ".fam"), + col_names = FALSE, + col_types = cols(.default = col_character()) + ) + # plink1 bim: col5 = A1 (minor/effect), col6 = A2 (major/ref); matches the + # pecotmr convention directly. + snpInfo <- tibble( + SNP = bim$SNP, + CHR = as.character(bim$CHR), + BP = as.integer(bim$BP), + A1 = bim$A1, + A2 = bim$A2 + ) + list( + snpInfo = snpInfo, + sampleIds = as.character(fam[[2]]), + nSamples = nrow(fam) + ) +} + +# ---- Per-chromosome VCF / GDS / PLINK1 sets -------------------------------- + +# The panel of a per-chromosome VCF, GDS or PLINK1 set: the shards' panels +# stacked -- DelayedArray binds their assays, so nothing is read -- recording +# each chromosome's file as a sharded GenotypeHandle does. Every shard must +# hold the same samples, in the same order. +# @noRd +.stackDosagePanels <- function(panels, format, metaPath, paths) { + .stackCheckSamples(panels, paths) + rowRangesList <- unname(map(panels, SummarizedExperiment::rowRanges)) + SummarizedExperiment::SummarizedExperiment( + assays = list( + dosage = exec( + BiocGenerics::rbind, + !!!unname(map(panels, .seDosage)) + ) + ), + rowRanges = suppressWarnings(exec(c, !!!rowRangesList)), + colData = SummarizedExperiment::colData(panels[[1L]]), + metadata = list( + genotypeSource = list( + format = format, + path = metaPath, + chromPaths = .panelChromPaths(panels) + ) + ) + ) +} + +# @noRd +.stackCheckSamples <- function(panels, paths) { + first <- colnames(panels[[1L]]) + same <- map_lgl(map(panels, colnames), identical, first) + if (all(same)) { + return(invisible(NULL)) + } + abort(glue( + "genoMeta: all per-chromosome files must have ", + "identical sample IDs in the same order (mismatch at ", + "'{paths[[which(!same)[[1L]]]]}')." + )) +} + +# Each chromosome's file, named by chromosome; a chromosome found in two +# files is refused, as for a sharded GenotypeHandle. +# @noRd +.panelChromPaths <- function(panels) { + chromPaths <- list_c(map(panels, .panelShardPaths)) + counts <- table(names(chromPaths)) + walk2(names(counts), as.integer(counts), .checkChromNotSplit) + chromPaths +} + +# One shard panel's chromosomes, each mapped to its file. +# @noRd +.panelShardPaths <- function(panel) { + chroms <- unique(.ldRefChrom(panel)) + set_names(rep(.ldRefSource(panel)$path, length(chroms)), chroms) +} diff --git a/R/gwasSumStats.R b/R/gwasSumStats.R index 013773065..9e488c0ca 100644 --- a/R/gwasSumStats.R +++ b/R/gwasSumStats.R @@ -4,7 +4,7 @@ # DFrame-subclass collection keyed by the identity tuple (study). Each # row holds a per-study GRanges of GWAS summary statistics covering a # single LD block; build a separate collection per block when sweeping -# the genome. Class-level slots ldSketch + genome + qcInfo apply +# the genome. Class-level slots ldReference + genome + qcInfo apply # uniformly across rows. # ============================================================================= @@ -18,7 +18,7 @@ NULL #' block when sweeping the genome. #' @details Required column: \code{study}, unique across rows. The class-level #' slots inherited from \code{\linkS4class{SumStatsBase}} -- -#' \code{ldSketch}, \code{genome} and \code{qcInfo} -- apply uniformly to +#' \code{ldReference}, \code{genome} and \code{qcInfo} -- apply uniformly to #' every row. #' @seealso \code{\link{GwasSumStats}} for the constructor and #' \code{\linkS4class{QtlSumStats}} for the QTL counterpart. @@ -28,7 +28,7 @@ setClass( "GwasSumStats", contains = "SumStatsBase", validity = function(object) { - # The ldSketch slot's class union enforces its type. + # The ldReference slot's class union enforces its type. coll <- makeAssertCollection() assertNames( colnames(mcols(object)) %||% character(0), @@ -65,13 +65,13 @@ setMethod("show", "GwasSumStats", function(object) { "genome build {GenomeInfoDb::genome(object)}\n", .trim = FALSE )) - ld <- object@ldSketch + ld <- object@ldReference ldSrc <- if (is.null(ld)) { "none (LD-free)" } else { - .ldSketchLabel(ld) + .ldRefLabel(ld) } - cat(glue(" LD sketch: {ldSrc}\n", .trim = FALSE)) + cat(glue(" LD reference: {ldSrc}\n", .trim = FALSE)) }) @@ -107,7 +107,7 @@ NULL #' @title Create a GwasSumStats Collection Object #' @description Construct a \code{GwasSumStats} S4 DFrame-subclass collection #' from per-study tuple vectors and a list of \code{GRanges} entries (one per -#' study), plus a single LD sketch handle and a single genome build that apply +#' study), plus a single LD reference and a single genome build that apply #' to the whole collection. #' #' Each \code{GRanges} entry must carry per-variant statistics in its mcols (at @@ -118,9 +118,10 @@ NULL #' study. #' @param genome Single character string giving the genome build (e.g., #' \code{"hg19"}, \code{"hg38"}). Uniform across the collection because all -#' entries share the same LD sketch. -#' @param ldSketch A genotype panel (see \code{\link{readGenotypes}}) -#' carrying the LD reference. +#' entries share the same LD reference. +#' @param ldReference The LD reference: a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +#' \code{\link{LdMatrix}}. #' @param varY Optional numeric vector of per-study phenotype variances #' (\code{NA_real_} entries allowed). Used by the sufficient-statistic #' interface; z-score RSS analyses should leave entries as NA. @@ -137,10 +138,9 @@ NULL #' no per-variant \code{N} column and no case/control counts. Named #' \code{nSample} to avoid clashing with \code{nSamples()} (the LD-panel #' sample size). -#' @param ldBlocks Optional LD-block specification: an \code{LdBlocks}, a -#' \code{GRanges}, a data.frame with \code{chrom}/\code{start}/\code{end} -#' (plus an optional \code{blockId}), or a path to such a table. When -#' supplied, each +#' @param ldBlocks Optional LD-block specification: a \code{GRanges}, a +#' data.frame with \code{chrom}/\code{start}/\code{end} (plus an optional +#' \code{blockId}), or a path to such a table. When supplied, each #' study's variants are split into one element per block rather than one per #' chromosome, and \code{blockId} takes the block's key (its \code{names}, #' else a \code{blockId} metadata column, else its coordinates). cTWAS needs @@ -170,13 +170,13 @@ NULL #' S4Vectors::mcols(gr) <- S4Vectors::DataFrame(SNP = paste0("rs", 1:3), #' A1 = "A", A2 = "G", Z = rnorm(3), N = 100L) #' GwasSumStats(studyName = "t1", entry = list(gr), genome = "hg38", -#' ldSketch = panel) +#' ldReference = panel) #' @export GwasSumStats <- function( studyName, entry, genome, - ldSketch = NULL, + ldReference = NULL, varY = NA_real_, nCase = NULL, nControl = NULL, @@ -217,7 +217,7 @@ GwasSumStats <- function( GenomicRanges::GRangesList(split$entry), value = md ) - .sumStatsNewValidated("GwasSumStats", grl, ldSketch, genome, qcInfo) + .sumStatsNewValidated("GwasSumStats", grl, ldReference, genome, qcInfo) } # Build and validate a SumStatsBase subclass from its GRangesList plus the @@ -225,7 +225,7 @@ GwasSumStats <- function( # rather than duplicated so the two constructors cannot drift in how they # coerce those slots. Used by qtlSumStats.R too. # @noRd -.sumStatsNewValidated <- function(Class, grl, ldSketch, genome, qcInfo) { +.sumStatsNewValidated <- function(Class, grl, ldReference, genome, qcInfo) { # The build goes into seqinfo, which is where a GRangesList keeps it and # where every Bioconductor consumer reads it from. Assigned before new() # so validity sees the finished object. @@ -233,7 +233,7 @@ GwasSumStats <- function( obj <- methods::new( Class, built, - ldSketch = .asLdSketch(ldSketch), + ldReference = .asLdRef(ldReference), qcInfo = as.list(qcInfo) ) methods::validObject(obj) @@ -302,7 +302,7 @@ GwasSumStats <- function( if (length(genome) != 1L) { msg <- glue( "`genome` must be a single character string (one build per ", - "collection, because all entries share the LD sketch)." + "collection, because all entries share the LD reference)." ) abort(msg) } @@ -525,15 +525,18 @@ setMethod("varY", "GwasSumStats", function(x, studyName = NULL) { #' across the inputs (a mismatch is an error, not a silent first-wins), the #' per-element \code{qcInfo$entryAudit} concatenates in element order so #' \code{\link{qcDiagnostics}} keeps addressing the right element, and the -#' LD sketches union into one panel over the shared genotype handle. That last -#' one matters: block-parallel pipelines narrow each piece's panel to its own -#' block, so keeping only the first would leave a multi-block collection whose -#' LD reference covers one block. +#' LD references combine: genotype panels union into one panel over the shared +#' genotype handle. That last one matters: block-parallel pipelines narrow each +#' piece's panel to its own block, so keeping only the first would leave a +#' multi-block collection whose LD reference covers one block. An +#' \code{LdMatrix} or a \code{GenotypeMixture} cannot be unioned that way; +#' one of the inputs' references must already cover the others, or the +#' combined one is passed as \code{ldReference}. #' #' @param ... Two or more \code{GwasSumStats} objects, or a single \code{list} #' of them. -#' @param ldSketch Optional genotype panel (see \code{\link{readGenotypes}}) to -#' attach to the combined collection, overriding the unioned one. Default +#' @param ldReference Optional genotype panel (see \code{\link{readGenotypes}}) +#' to attach to the combined collection, overriding the unioned one. Default #' \code{NULL}. #' @return A single combined \code{GwasSumStats}. #' @seealso \code{\link{combineQtlSumStats}}, @@ -542,7 +545,7 @@ setMethod("varY", "GwasSumStats", function(x, studyName = NULL) { #' data(gwasSumStatsS4Example) #' combineGwasSumStats(gwasSumStatsS4Example) #' @export -combineGwasSumStats <- function(..., ldSketch = NULL) { +combineGwasSumStats <- function(..., ldReference = NULL) { parts <- .asCombineList( list(...), "GwasSumStats", @@ -551,5 +554,5 @@ combineGwasSumStats <- function(..., ldSketch = NULL) { if (length(parts) == 1L) { return(parts[[1L]]) } - .rbindSumStats(parts, ldSketch, "combineGwasSumStats") + .rbindSumStats(parts, ldReference, "combineGwasSumStats") } diff --git a/R/h2Annotations.R b/R/h2Annotations.R index 72179c116..1a23f69bb 100644 --- a/R/h2Annotations.R +++ b/R/h2Annotations.R @@ -102,8 +102,9 @@ setMethod( #' @title Detect Annotation File Format #' @description Detect annotation file format from extension. This is separate -#' from \code{.h2DetectFormat} because BED annotation files (genomic intervals -#' for rtracklayer) must be distinguished from plink BED files. +#' from the genotype format detection (\code{.genotypePathFormat}) because +#' BED annotation files (genomic intervals for rtracklayer) must be +#' distinguished from plink BED files. #' @param path Character, file path. #' @return Character, one of "bigwig", "ldsc_annot", or "bed". #' @keywords internal diff --git a/R/h2EstimationWrappers.R b/R/h2EstimationWrappers.R index 6d7bfb1c7..a35a813bd 100644 --- a/R/h2EstimationWrappers.R +++ b/R/h2EstimationWrappers.R @@ -8,10 +8,10 @@ # * HDL/sHDL (High-Definition Likelihood, Ning et al. 2020 + Zhao 2023) # * LDER (LD Eigenvalue Regression, Song et al. 2022) # -# Plus shared utilities (block ops, WLS, jackknife SE, enrichment, LD -# shrinkage, genome-build checks, tauStar standardization, meta-analysis) -# and the converter that bridges H2Estimate results into the sLDSC -# postprocessing pipeline. +# Plus shared utilities (block ops, WLS, jackknife SE, enrichment, +# genome-build checks, tauStar standardization, meta-analysis) and the +# converter that bridges H2Estimate results into the sLDSC postprocessing +# pipeline. # # The H2Estimate result class itself lives in R/h2Estimate.R. # ============================================================================= @@ -22,7 +22,6 @@ #' @name pecotmr-h2-utils #' @keywords internal #' @importFrom GenomicRanges GRanges -#' @importFrom BiocParallel bplapply bpparam #' @importFrom IRanges findOverlaps #' @importFrom S4Vectors queryHits subjectHits NULL @@ -48,45 +47,6 @@ snpsPerBlock <- function(snpInfo, ldBlocks) { split(queryHits(hits), subjectHits(hits)) } -#' @title Apply Function Per Block with BiocParallel -#' @description Apply a function to each LD block in parallel. -#' @param blockIndices List of SNP index vectors per block. -#' @param FUN Function to apply to each block's indices. -#' @param BPPARAM BiocParallel parameter object. -#' @param ... Additional arguments passed to FUN. -#' @return A list of results, one per block. -#' @keywords internal -bplapplyBlocks <- function(blockIndices, FUN, BPPARAM = NULL, ...) { - if (is.null(BPPARAM)) { - BPPARAM <- bpparam() - } - bplapply(blockIndices, FUN, BPPARAM = BPPARAM, ...) -} - -# ============================================================================= -# Regression utilities -# ============================================================================= - -#' @title Jackknife Standard Errors by Block -#' @description Compute jackknife SE estimates using leave-one-block-out. -#' @param estimatesFull Numeric vector, full-sample parameter estimates. -#' @param estimatesLoo A matrix (nBlocks x nParams), leave-one-out estimates. -#' @return Numeric vector of jackknife SEs. -#' @keywords internal -jackknifeSe <- function(estimatesFull, estimatesLoo) { - nBlocks <- nrow(estimatesLoo) - pseudoVals <- nBlocks * - matrix( - estimatesFull, - nrow = nBlocks, - ncol = length(estimatesFull), - byrow = TRUE - ) - - (nBlocks - 1) * estimatesLoo - jkVar <- apply(pseudoVals, 2, var) / nBlocks - sqrt(jkVar) -} - # ============================================================================= # Baseline enrichment computation # ============================================================================= @@ -165,42 +125,6 @@ computeBaselineEnrichment <- function( ) } -# ============================================================================= -# LD shrinkage -# ============================================================================= - -#' @title Apply LD Shrinkage -#' @description Apply shrinkage to sample LD matrix to reduce noise from finite -#' reference panel size, following Wen & Stephens (2010). -#' @param R Numeric matrix, sample LD correlation matrix. -#' @param nSamples Integer, reference panel sample size. -#' @param shrinkageType Character, one of "wen_stephens", "constant". -#' @param geneticMap Numeric vector, genetic map positions for SNPs in R. -#' @return Shrunk LD correlation matrix. -#' @keywords internal -shrinkLd <- function( - R, - nSamples, - shrinkageType = "wen_stephens", - geneticMap = NULL -) { - if (shrinkageType == "wen_stephens" && !is.null(geneticMap)) { - # Wen & Stephens (2010) shrinkage based on genetic distance - p <- nrow(R) - theta <- 2 * nSamples / (22 * nSamples + 16) # effective recombination - distCm <- abs(outer(geneticMap, geneticMap, "-")) - shrinkFactor <- exp( - -4 * nSamples * distCm / (100 * (2 * nSamples + 16)) - ) - RShrunk <- `diag<-`(R * shrinkFactor, 1) - } else { - # Simple constant shrinkage - lambda <- 1 / sqrt(nSamples) - RShrunk <- (1 - lambda) * R + lambda * diag(nrow(R)) - } - RShrunk -} - # ============================================================================= # Genome build utilities # ============================================================================= @@ -209,9 +133,9 @@ shrinkLd <- function( #' @description Check that genome builds match between objects. Each object #' contributes a single genome build (from its \code{genome} slot). An #' object that records no build is skipped rather than treated as a -#' mismatch: \code{loadLdMatrix()} leaves the build unset, so an LD -#' reference built from it names no build, and an unknown build cannot -#' contradict a known one. +#' mismatch: an LD reference often names no build (a genotype panel's +#' variants rarely carry one), and an unknown build cannot contradict a +#' known one. #' @param ... Objects with a \code{genome} slot. #' @return TRUE if all match, error otherwise. #' @keywords internal @@ -235,10 +159,10 @@ checkGenomeBuild <- function(...) { } # genome() is per-seqlevel, so flatten across objects before uniquing: one # object naming two builds and two objects disagreeing are the same error. - # An object naming none contributes NA and is skipped, because - # loadLdMatrix() leaves the build unset and demanding one here would - # reject every LD reference the package's own loader produces. The - # coordinate check in .h2CheckPositions() is the stronger guard regardless. + # An object naming none contributes NA and is skipped, because an LD + # reference often names no build and demanding one here would reject most + # of them. The coordinate check in .h2CheckPositions() is the stronger + # guard regardless. builds <- unname(discard( unique(list_c(map(objects, GenomeInfoDb::genome))), is.na @@ -304,24 +228,9 @@ standardizeTauStar <- function( # DerSimonian-Laird random-effects meta-analysis # ============================================================================= -#' @title Random-Effects Meta-Analysis (metafor wrapper) -#' @description Thin convenience wrapper around \code{metafor::rma()}. pecotmr -#' does not implement its own meta-analysis engine -- this helper only guards -#' the degenerate 0- and 1-study cases (where \code{rma} is undefined) and -#' reshapes the \code{metafor} fit into a small list. The between-study -#' variance estimator is chosen by \code{method} and passed straight through. -#' @param means Numeric vector of study-level point estimates. -#' @param ses Numeric vector of study-level standard errors (must be positive -#' and finite). -#' @param method Between-study variance estimator forwarded to -#' \code{metafor::rma(method = )} (e.g. \code{"DL"} (default), \code{"REML"}, -#' \code{"ML"}, \code{"EB"}). -#' @return A list with \code{mean}, \code{se}, \code{tau2}, \code{I2} (a [0, 1] -#' proportion) and \code{Q} (Cochran's Q). -#' @importFrom metafor rma -#' @noRd # Degenerate meta-analysis inputs: k = 0 (all NA) or k = 1 (pass-through), plus # positivity validation. Returns NULL when the full estimator should run. +# @noRd .rmaMetaEarly <- function(means, ses, k) { if (k == 0L) { return(list( @@ -405,6 +314,24 @@ RmaOptions <- function(...) { ) } +#' @title Random-Effects Meta-Analysis (metafor wrapper) +#' @description Thin convenience wrapper around \code{metafor::rma()}. pecotmr +#' does not implement its own meta-analysis engine -- this helper only guards +#' the degenerate 0- and 1-study cases (where \code{rma} is undefined) and +#' reshapes the \code{metafor} fit into a small list. The between-study +#' variance estimator is chosen by \code{method} and passed straight through. +#' @param means Numeric vector of study-level point estimates. +#' @param ses Numeric vector of study-level standard errors (must be positive +#' and finite). +#' @param method Between-study variance estimator forwarded to +#' \code{metafor::rma(method = )} (e.g. \code{"DL"} (default), \code{"REML"}, +#' \code{"ML"}, \code{"EB"}). +#' @param metaArgs Extra \code{metafor::rma()} arguments, an +#' \code{\link{RmaOptions}} record. +#' @return A list with \code{mean}, \code{se}, \code{tau2}, \code{I2} (a [0, 1] +#' proportion) and \code{Q} (Cochran's Q). +#' @importFrom metafor rma +#' @noRd #' @importFrom rlang try_fetch .rmaMeta <- function(means, ses, method = "DL", metaArgs = list()) { k <- length(means) @@ -506,18 +433,48 @@ NULL # Per-block whitened statistics x_i = (u_i'z)/sqrt(lam_i) and stratified # eigenvalue scores l_{ia} = sum_j A_{ja} V_{ji}^2 (all-ones column when -# unstratified). Near-null directions (lam < 1e-6) are zeroed (as upstream). -.lderBlockStats <- function(block, z, baselineMat) { - V <- block$vectors - lam <- block$values - raw <- as.vector(crossprod(V, z[block$snpIdx]) / sqrt(pmax(lam, 1e-12))) - x <- replace(raw, lam < 1e-6, 0) - ldAnnot <- if (is.null(baselineMat)) { - matrix(1, length(lam), 1) - } else { - crossprod(V^2, baselineMat[block$snpIdx, , drop = FALSE]) +# unstratified), plus the candidate annotations' scores, from the block's +# decomposition. Near-null directions (lam < 1e-6) are zeroed, as in the +# original LDER implementation, which keeps every direction of the block: +# the zero-eigenvalue directions a decomposition from a panel's factor does +# not list are added as rows with x = 0 and lam = 0. +.lderBlockStats <- function(block, eigenRef, z, baselineMat, candMat) { + dec <- .ldEigenBlockAt(block, eigenRef) + lam <- dec$values + raw <- as.vector( + crossprod(dec$vectors, z[dec$snpIdx]) / sqrt(pmax(lam, 1e-12)) + ) + nAll <- length(lam) + dec$nNull + list( + x = c(replace(raw, lam < 1e-6, 0), numeric(dec$nNull)), + lam = c(lam, numeric(dec$nNull)), + ldAnnot = .h2EigenAnnot(dec, baselineMat) %||% matrix(1, nAll, 1), + ldCand = .h2EigenAnnot(dec, candMat) + ) +} + +# One block's eigenvalue scores sum_k V_ki^2 a_k for each column of +# `annotMat`, with a zero row for each zero-eigenvalue direction the +# decomposition does not list: every use multiplies a direction's row by its +# eigenvalue. NULL without annotations. +.h2EigenAnnot <- function(dec, annotMat) { + if (is.null(annotMat)) { + return(NULL) + } + listed <- crossprod( + dec$vectors^2, + annotMat[dec$snpIdx, , drop = FALSE] + ) + rbind(listed, matrix(0, dec$nNull, ncol(annotMat))) +} + +# The candidate (tested) annotations, or NULL when there are none to score. +.h2CandidateMat <- function(annotations) { + if (is.null(annotations)) { + return(NULL) } - list(x = x, lam = lam, ldAnnot = ldAnnot) + candMat <- assay(testedAnnotations(annotations), "annotations") + if (ncol(candMat) == 0L) NULL else candMat } # Concatenate per-block stats into the genome-wide regression design. M_a is @@ -645,15 +602,23 @@ NULL aLoo <- map_dbl(loo, "a") tauList <- map(loo, "tau") jkCoefs <- exec(rbind, !!!tauList) - jkSe <- function(v) sqrt((nB - 1) / nB * sum((v - mean(v))^2)) list( - h2Se = jkSe(h2Loo), - aSe = jkSe(aLoo), - tauSe = apply(jkCoefs, 2, jkSe), + h2Se = .jackknifeSeFromLoo(h2Loo), + aSe = .jackknifeSeFromLoo(aLoo), + tauSe = apply(jkCoefs, 2, .jackknifeSeFromLoo), annotationJackknifeCoefs = jkCoefs ) } +# Delete-one-block jackknife standard error from the n leave-one-out +# estimates `v`: sqrt((n - 1) / n * sum((v - mean(v))^2)). The LDER, gLDSC, +# HDL and S-LDSC jackknifes all report this quantity. +# @noRd +.jackknifeSeFromLoo <- function(v) { + n <- length(v) + sqrt((n - 1) / n * sum((v - mean(v))^2)) +} + # tau / tauSe / annotationJackknifeCoefs for the enrichment framework # (univariate: tau = h2). .lderEnrichParts <- function(fit, jk, baselineMat) { @@ -735,7 +700,7 @@ NULL } # LDER candidate-annotation score statistics against the fitted baseline. -.lderScoreStats <- function(eigenRef, annotations, design, fit, N) { +.lderScoreStats <- function(blockStats, annotations, design, fit, N) { candidate <- testedAnnotations(annotations) candMat <- assay(candidate, "annotations") nCand <- ncol(candMat) @@ -749,12 +714,7 @@ NULL ) w <- 1 / (2 * mu^2) resid <- design$x^2 - mu - candCross <- map( - eigenList(eigenRef), - .h2EigenCandCrossprod, - candMat = candMat - ) - ldCand <- exec(rbind, !!!candCross) + ldCand <- exec(rbind, !!!map(blockStats, "ldCand")) keepAll <- rep(TRUE, length(lam)) scoreZ <- map_dbl( seq_len(nCand), @@ -779,11 +739,15 @@ lderUnivariate <- function( ) { rough <- !inSample(eigenRef) baselineMat <- .h2BaselineMat(annotations) + # One pass over the blocks, each decomposed only while its statistics are + # taken, so a reference read from a panel holds one block at a time. blockStats <- map( - eigenList(eigenRef), + .ldEigenBlocks(eigenRef), .lderBlockStats, + eigenRef = eigenRef, z = z, - baselineMat = baselineMat + baselineMat = baselineMat, + candMat = .h2CandidateMat(annotations) ) design <- .lderDesign(blockStats, baselineMat) M <- length(design$x) @@ -800,24 +764,31 @@ lderUnivariate <- function( jk <- .lderJackknife(blockStats, baselineMat, n, M, design$M_a, rough, TRUE) ep <- .lderEnrichParts(fit, jk, baselineMat) localDf <- if (local) .lderLocal(blockStats, n, fit$a) else NULL - scoreStats <- if (is.null(annotations)) { - NULL - } else { - .lderScoreStats(eigenRef, annotations, design, fit, n)$scoreStats - } - jkRes <- list( + .h2JackknifeResult( + h2 = fit$h2, + intercept = fit$a, se = c(jk$h2Se, jk$aSe), - tauSe = ep$tauSe, - annotationJackknifeCoefs = ep$annotationJackknifeCoefs - ) - enrichmentDf <- .h2Enrichment( - baselineMat, - ep$tau, - ep$tauSe, - ep$annotationJackknifeCoefs, - fit$h2 + ep = ep, + baselineMat = baselineMat, + localDf = localDf, + scoreStats = .lderCandidateScores( + blockStats, + annotations, + design, + fit, + n + ) ) - .h2Result(fit$h2, jkRes, fit$a, ep$tau, localDf, enrichmentDf, scoreStats) +} + +# LDER's score statistics for the candidate annotations; NULL when there are +# none to test. +# @noRd +.lderCandidateScores <- function(blockStats, annotations, design, fit, n) { + if (is.null(annotations)) { + return(NULL) + } + .lderScoreStats(blockStats, annotations, design, fit, n)$scoreStats } @@ -860,6 +831,35 @@ lderUnivariate <- function( ) } +# The result of an estimator jackknifed over its blocks (LDER, HDL): `se` +# holds the standard errors of h2 and of the intercept, and `ep` the +# enrichment parts (tau, tauSe, annotationJackknifeCoefs) that the +# per-annotation enrichment table is built from. +# @noRd +.h2JackknifeResult <- function( + h2, + intercept, + se, + ep, + baselineMat, + localDf, + scoreStats +) { + jkRes <- list( + se = se, + tauSe = ep$tauSe, + annotationJackknifeCoefs = ep$annotationJackknifeCoefs + ) + enrichmentDf <- .h2Enrichment( + baselineMat, + ep$tau, + ep$tauSe, + ep$annotationJackknifeCoefs, + h2 + ) + .h2Result(h2, jkRes, intercept, ep$tau, localDf, enrichmentDf, scoreStats) +} + # Per-annotation enrichment table via the shared tau-based framework (used by # HDL and LDER; g-LDSC builds its own from partitioned h2). NULL when # unstratified. @@ -892,10 +892,15 @@ lderUnivariate <- function( #' @description Estimate heritability and functional enrichment by feasible #' generalized least squares (FGLS) on LD scores (Xiong et al. 2024). The #' response \eqn{Z_j^2 - 1} is regressed on stratified LD scores -#' \eqn{\ell_{ja} = \sum_k R^2_{jk} A_{ka}} (with a confounding intercept) -#' using the full residual covariance +#' \eqn{\ell_{ja} = \sum_k R^2_{jk} A_{ka}} (with a confounding intercept; +#' the raw sample \eqn{R^2}, as the original gLDSC implementation forms +#' them, not the unbiased \eqn{r^2} of the S-LDSC scores) using the full +#' residual covariance #' \eqn{\Omega = (\hat{N\tau}\, R D_a R + R)^2} (elementwise), inverted per LD -#' block via a 99\%-eigenvalue-mass truncation. \eqn{\hat{N\tau} = \sum(Z^2-1) +#' block via a 99\%-eigenvalue-mass truncation. Each block's \eqn{\Omega} +#' is formed, decomposed and dropped in turn; for a reference read from a +#' genotype panel it is formed from the panel's factor, never from the +#' block's \eqn{R}. \eqn{\hat{N\tau} = \sum(Z^2-1) #' / \sum \ell} is a method-of-moments plug-in; #' \eqn{D_a = diag(\sum_a A_{ja})}. #' Coefficients are \eqn{\tau = (X'\Omega^{-1}X)^{-1} X'\Omega^{-1} y / N} and @@ -919,32 +924,89 @@ NULL if (is.null(baselineMat)) matrix(1, M, 1) else cbind(base = 1, baselineMat) } -# Per-block quantities: LD matrix R, block annotations, stratified LD scores -# l = (R^2) A, and response y = Z^2 - 1. -.gldscBlockPrep <- function(block, z, A) { - R <- block$R - idx <- block$snpIdx +# Per-block design: the block's annotations, its stratified LD scores +# l = (R o R) A, the candidate annotations' scores (R o R) C, and the +# response y = Z^2 - 1. The one LD score here that stays on the raw r^2: the +# original gLDSC implementation squares its LD matrix as is (middle_fun.R +# LDSCmatrix), and the GLS design is reproduced from it. A block read from a +# genotype panel gets its scores from the panel's factor a stripe of rows at +# a time (.ldSquaredProduct()). +.gldscBlockDesign <- function(block, panel, z, A, candMat) { + idx <- block$idx Ab <- A[idx, , drop = FALSE] - list(R = R, Ab = Ab, ldsc = (R^2) %*% Ab, y = z[idx]^2 - 1, snpIdx = idx) + Cb <- if (!is.null(candMat)) candMat[idx, , drop = FALSE] + scores <- .ldSquaredProduct(.ldStatBlockLd(block, panel), cbind(Ab, Cb)) + nA <- ncol(Ab) + list( + Ab = Ab, + ldsc = scores[, seq_len(nA), drop = FALSE], + ldCand = if (!is.null(Cb)) scores[, -seq_len(nA), drop = FALSE], + y = z[idx]^2 - 1 + ) } -# 99%-mass truncated inverse of Omega = (rawNtau * R Da R + R)^2 (upstream -# eigen.cut). Da = diag(rowSums(A)) so R Da R = crossprod(R sqrt(Da)). -.gldscOmegaInv <- function(R, Ab, rawNtau, cutpoint = 0.99) { - Omega <- (rawNtau * crossprod(R * sqrt(rowSums(Ab))) + R)^2 - ei <- eigen(Omega, symmetric = TRUE) +# Omega = S o S, with S = rawNtau * R Da R + R and Da = diag(rowSums(A)), +# reduced to its leading eigenpairs carrying `cutpoint` of the eigenvalue +# mass (eigen.cut in the original gLDSC implementation): Omega^-1 is applied +# as V diag(1 / values) V' and never formed. +.gldscOmegaEigen <- function(ld, Ab, rawNtau, cutpoint = 0.99) { + S <- .gldscS(ld, rowSums(Ab), rawNtau) + ei <- eigen(S^2, symmetric = TRUE) k <- which(cumsum(ei$values) / sum(ei$values) >= cutpoint)[1] - Vc <- ei$vectors[, seq_len(k), drop = FALSE] - Vc %*% (t(Vc) / ei$values[seq_len(k)]) + list( + vectors = ei$vectors[, seq_len(k), drop = FALSE], + values = ei$values[seq_len(k)] + ) +} + +# S = rawNtau * R Da R + R for a block's LD source, with Da = diag(d). From a +# stored R, R Da R = crossprod(R sqrt(Da)). From a factor F, with +# R = F'F / (m - 1), S = F' (rawNtau / (m - 1) * (F Da F') F + F) / (m - 1): +# only S is formed, which Omega needs whole, never the block's R. +.gldscS <- function(ld, d, rawNtau) { + if (!is.null(ld$R)) { + return(rawNtau * crossprod(ld$R * sqrt(d)) + ld$R) + } + F <- ld$F + m1 <- nrow(F) - 1 + gram <- tcrossprod(sweep(F, 2L, sqrt(d), "*")) + crossprod(F, rawNtau / m1 * (gram %*% F) + F) / m1 +} + +# One block's contribution to the GLS normal equations, L = X'Omega^-1 X and +# R = X'Omega^-1 y with X = [1 | l], plus its candidate-score pieces. Omega +# is formed for the block, decomposed and dropped, so only one block's is +# ever in memory. +.gldscBlockContrib <- function(block, design, panel, rawNtau) { + om <- .gldscOmegaEigen(.ldStatBlockLd(block, panel), design$Ab, rawNtau) + X <- cbind(1, design$ldsc) + P <- crossprod(om$vectors, X) + Py <- crossprod(om$vectors, design$y) + Pw <- P / om$values + list( + L = crossprod(Pw, P), + R = as.vector(crossprod(Pw, Py)), + p = length(block$idx), + cand = .gldscCandidatePieces(om, design$ldCand, P, Py) + ) } -# Block contribution to the GLS normal equations: L = X'Omega^-1 X, -# R = X'Omega^-1 y, with X = [1 | l]. -.gldscBlockGls <- function(prep, rawNtau) { - OmInv <- .gldscOmegaInv(prep$R, prep$Ab, rawNtau) - X <- cbind(1, prep$ldsc) - XtOi <- crossprod(X, OmInv) - list(L = XtOi %*% X, R = as.vector(XtOi %*% prep$y)) +# A block's candidate-score pieces. The score is taken against the FITTED +# baseline residual, U_c = l_c' Omega^-1 (y - X coef), which is linear in +# coef: keeping l_c' Omega^-1 y and l_c' Omega^-1 X lets the block's score be +# formed once the fit is known, without revisiting the block. Alongside, +# I_c = l_c' Omega^-1 l_c. NULL without candidates. +.gldscCandidatePieces <- function(om, ldCand, P, Py) { + if (is.null(ldCand)) { + return(NULL) + } + Q <- crossprod(om$vectors, ldCand) + Qw <- Q / om$values + list( + Uy = as.vector(crossprod(Qw, Py)), + UX = crossprod(Qw, P), + I = colSums(Q * Qw) + ) } # GLS estimate from accumulated normal equations: tau = solve(L, R)/N (the @@ -968,7 +1030,6 @@ NULL # from the accumulated normal equations (so folds stay GLS-weighted). Jackknife # variance = var * (nB-1)^2 / nB (Xiong et al.). .gldscJackknife <- function(contrib, left, right, A, N) { - nB <- length(contrib) loo <- map( contrib, .gldscLooEstimate, @@ -982,11 +1043,10 @@ NULL tauList <- map(loo, "tau") jkCoefs <- exec(rbind, !!!tauList) intLoo <- map_dbl(loo, "intercept") - jkSe <- function(v) sqrt(var(v) * (nB - 1)^2 / nB) list( - h2Se = jkSe(estHBlocks[, 1]), - intSe = jkSe(intLoo), - tauSe = apply(jkCoefs, 2, jkSe), + h2Se = .jackknifeSeFromLoo(estHBlocks[, 1]), + intSe = .jackknifeSeFromLoo(intLoo), + tauSe = apply(jkCoefs, 2, .jackknifeSeFromLoo), annotationJackknifeCoefs = jkCoefs, estHBlocks = estHBlocks ) @@ -1022,64 +1082,48 @@ NULL ) } -# Local heritability for one LD block: a per-block GLS on [1 | base LD score]; +# Local heritability for one LD block: a per-block GLS on [1 | base LD score], +# whose normal equations are the leading 2 x 2 of the block's own; # h2Local = tau_base * (block SNPs), SE from the GLS coefficient covariance. -.gldscLocalBlock <- function(prep, b, rawNtau, N) { - OmInv <- .gldscOmegaInv(prep$R, prep$Ab, rawNtau) - X <- cbind(1, prep$ldsc[, 1]) - XtOi <- crossprod(X, OmInv) - L <- XtOi %*% X - coef <- solve(L, as.vector(XtOi %*% prep$y)) - p <- nrow(prep$R) +.gldscLocalBlock <- function(cb, b, N) { + L <- cb$L[1:2, 1:2] + coef <- solve(L, cb$R[1:2]) covTau <- (solve(L) / N^2)[2, 2] tibble( blockId = b, - h2Local = coef[2] / N * p, - h2LocalSe = sqrt(max(covTau, 0)) * p + h2Local = coef[2] / N * cb$p, + h2LocalSe = sqrt(max(covTau, 0)) * cb$p ) } # Per-block local heritability (NULL unless requested). -.gldscLocal <- function(preps, rawNtau, N) { +.gldscLocal <- function(contrib, N) { bind_rows( map( - seq_along(preps), + seq_along(contrib), .gldscLocalRow, - preps = preps, - rawNtau = rawNtau, + contrib = contrib, N = N ) ) } -# Candidate-annotation score against the FITTED baseline GLS residual -# r = y - X coef: U_c = sum_b l_c' Omega^-1 r, I_c = sum_b l_c' Omega^-1 l_c, -# scoreZ = U_c / sqrt(I_c). Uses the real fitted coefficients (not a refit). -.gldscCandidateBlock <- function(prep, candMat, rawNtau, coef) { - OmInv <- .gldscOmegaInv(prep$R, prep$Ab, rawNtau) - r <- prep$y - as.vector(cbind(1, prep$ldsc) %*% coef) - ldCand <- (prep$R^2) %*% candMat[prep$snpIdx, , drop = FALSE] - ct <- crossprod(ldCand, OmInv) - list(U = as.vector(ct %*% r), I = diag(ct %*% ldCand)) +# One block's candidate scores at the fitted coefficients, against the +# fitted baseline GLS residual r = y - X coef: U_c = l_c' Omega^-1 r and +# I_c = l_c' Omega^-1 l_c. +.gldscCandidateBlock <- function(cb, coef) { + list(U = cb$cand$Uy - as.vector(cb$cand$UX %*% coef), I = cb$cand$I) } -# sHDL-style candidate score statistics + jackknife score correlation. -.gldscScoreStats <- function(preps, candMat, rawNtau, coef) { - nCand <- ncol(candMat) - if (nCand == 0) { - return(NULL) - } - per <- map( - preps, - .gldscCandidateBlock, - candMat = candMat, - rawNtau = rawNtau, - coef = coef - ) +# sHDL-style candidate score statistics + jackknife score correlation: +# scoreZ = sum_b U_c / sqrt(sum_b I_c), at the real fitted coefficients (not +# a refit). +.gldscScoreStats <- function(contrib, coef) { + per <- map(contrib, .gldscCandidateBlock, coef = coef) U <- reduce(map(per, "U"), `+`) I <- reduce(map(per, "I"), `+`) scoreZ <- U / sqrt(pmax(I, 1e-10)) - R <- if (nCand == 1) { + R <- if (length(U) == 1L) { matrix(1, 1, 1) } else { looRows <- map( @@ -1089,8 +1133,7 @@ NULL U = U, I = I ) - looZ <- exec(rbind, !!!looRows) - Rc <- cor(looZ) + Rc <- cor(exec(rbind, !!!looRows)) replace(Rc, is.na(Rc), 0) } list(scoreZ = scoreZ, R = R) @@ -1103,39 +1146,53 @@ gldscUnivariate <- function( annotations = NULL, local = FALSE ) { - ldMatrixList <- ldMatrixList(ldRef) - if (length(ldMatrixList) == 0L) { - msg <- glue( - "g-LDSC requires full per-block LD matrices (ldMatrixList). ", - "Read the LD reference with the LD matrices retained." - ) - abort(msg) + if (!.ldScoreHasLd(ldRef)) { + abort(c( + "g-LDSC needs each LD block's LD, and this LdScore carries none.", + i = str_c( + "Build it from a genotype panel, or from LdMatrix blocks ", + "with `keepLdMatrices = TRUE`." + ) + )) } M <- length(ldRef) A <- .gldscAnnotMatrix(annotations, M) - preps <- map(ldMatrixList, .gldscBlockPrep, z = z, A = A) - rawNtau <- sum(list_c(map(preps, "y"))) / - sum(list_c(map(preps, "ldsc"))) - contrib <- map(preps, .gldscBlockGls, rawNtau = rawNtau) + panel <- ldReference(ldRef) + blocks <- .ldScoreBlocks(ldRef) + # Two passes over the blocks: Omega depends on rawNtau, which needs every + # block's design first. A block read from a panel is read once per pass. + designs <- map( + blocks, + .gldscBlockDesign, + panel = panel, + z = z, + A = A, + candMat = .h2CandidateMat(annotations) + ) + rawNtau <- sum(list_c(map(designs, "y"))) / + sum(list_c(map(designs, "ldsc"))) + contrib <- map2( + blocks, + designs, + .gldscBlockContrib, + panel = panel, + rawNtau = rawNtau + ) left <- reduce(map(contrib, "L"), `+`) right <- reduce(map(contrib, "R"), `+`) fit <- .gldscEstimate(left, right, A, n) jk <- .gldscJackknife(contrib, left, right, A, n) - .gldscResult(fit, jk, annotations, preps, rawNtau, local, n, M) + .gldscResult(fit, jk, annotations, contrib, local, n, M) } -# The candidate-annotation score statistics, when candidates were supplied and -# the score test could be formed for them. NULL otherwise. +# The candidate-annotation score statistics, when candidates were supplied. +# NULL otherwise. # @noRd -.gldscCandidateScores <- function(annotations, preps, rawNtau, fit) { - if (is.null(annotations)) { - return(NULL) - } - candMat <- assay(testedAnnotations(annotations), "annotations") - sc <- .gldscScoreStats(preps, candMat, rawNtau, fit$coef) - if (is.null(sc)) { +.gldscCandidateScores <- function(annotations, contrib, fit) { + if (is.null(.h2CandidateMat(annotations))) { return(NULL) } + sc <- .gldscScoreStats(contrib, fit$coef) list( z = sc$scoreZ, R = sc$R, @@ -1146,9 +1203,9 @@ gldscUnivariate <- function( } # Assemble the gldscUnivariate return (enrichment, local, candidate scores). -.gldscResult <- function(fit, jk, annotations, preps, rawNtau, local, n, M) { +.gldscResult <- function(fit, jk, annotations, contrib, local, n, M) { baselineMat <- .h2BaselineMat(annotations) - localDf <- if (local) .gldscLocal(preps, rawNtau, n) else NULL + localDf <- if (local) .gldscLocal(contrib, n) else NULL enrichmentDf <- if (is.null(baselineMat)) { NULL } else { @@ -1162,7 +1219,7 @@ gldscUnivariate <- function( M ) } - scoreStats <- .gldscCandidateScores(annotations, preps, rawNtau, fit) + scoreStats <- .gldscCandidateScores(annotations, contrib, fit) tau <- if (is.null(baselineMat)) fit$h2 else fit$tau[-1] tauSe <- if (is.null(baselineMat)) jk$h2Se else jk$tauSe[-1] jkRes <- list( @@ -1216,9 +1273,9 @@ NULL # variance of rotated coordinate i is # lamh2_i = s_i lam_i^2 - lam_i h2Total / nRef + int lam_i / n, # s_i = (ldAnnotScaled %*% h2a)_i and h2Total = sum(h2a). With a single 1/M -# score column this is exactly upstream HDL's llfun (Ning et al. 2020). -# param = c(h2_1, .., h2_nTau, int). -# `lim` is upstream HDL's floor on the modelled per-direction variance +# score column this is exactly llfun in the original HDL implementation +# (Ning et al. 2020). param = c(h2_1, .., h2_nTau, int). +# `lim` is the original HDL's floor on the modelled per-direction variance # (llfun.R uses exp(-10)). It has to match: with 40% of a real reference's # eigen-directions near zero the floor is active for most of them, and the # `bstar^2 / lamh2` term it feeds dominates the likelihood -- a smaller floor @@ -1247,23 +1304,34 @@ NULL } # Per-block HDL quantities: eigenvalues, rotated N-normalized effects -# bstar = V'(z/sqrt(n)), and stratified eigenvalue scores l_{ia} (NULL when -# unstratified). -.hdlBlockData <- function(block, z, n, baselineMat) { - idx <- block$snpIdx - V <- block$vectors - ldAnnot <- if (is.null(baselineMat)) { - NULL - } else { - crossprod(V^2, baselineMat[idx, , drop = FALSE]) - } +# bstar = V'(z/sqrt(n)), stratified eigenvalue scores l_{ia} (NULL when +# unstratified) and the candidate annotations' scores, from the block's +# decomposition. The zero-eigenvalue directions a decomposition from a +# panel's factor does not list are added with lam = 0. +.hdlBlockData <- function(block, eigenRef, z, n, baselineMat, candMat) { + dec <- .ldEigenBlockAt(block, eigenRef) + zb <- z[dec$snpIdx] / sqrt(n) + bstar <- as.vector(crossprod(dec$vectors, zb)) list( - lam = block$values, - bstar = as.vector(crossprod(V, z[idx] / sqrt(n))), - ldAnnot = ldAnnot + lam = c(dec$values, numeric(dec$nNull)), + bstar = c(bstar, .hdlNullBstar(zb, bstar, dec$nNull)), + ldAnnot = .h2EigenAnnot(dec, baselineMat), + ldCand = .h2EigenAnnot(dec, candMat) ) } +# The rotated effects along a block's unlisted zero-eigenvalue directions. +# HDL gives every such direction the same modelled variance, its floor, so +# the likelihood sees only their total sum of squares: the part of z outside +# the listed directions, spread evenly over them, leaves every estimate as a +# full decomposition would give it. +.hdlNullBstar <- function(zb, bstar, nNull) { + if (nNull == 0L) { + return(numeric()) + } + rep(sqrt(max(sum(zb^2) - sum(bstar^2), 0) / nNull), nNull) +} + # Genome-wide design: eigenvalues, rotated effects, block ids, the M_a-scaled # eigenvalue-score matrix, and M_a. Univariate uses a single all-ones score # column (l_{i,base} = 1) scaled by total M. @@ -1395,11 +1463,10 @@ NULL h2aList <- map(loo, "h2a") h2aBlocks <- exec(rbind, !!!h2aList) intLoo <- map_dbl(loo, "int") - jkSe <- function(x) sqrt(mean((x - mean(x))^2) * (nBlocks - 1)) list( - h2aSe = apply(h2aBlocks, 2, jkSe), - h2Se = jkSe(rowSums(h2aBlocks)), - intSe = jkSe(intLoo), + h2aSe = apply(h2aBlocks, 2, .jackknifeSeFromLoo), + h2Se = .jackknifeSeFromLoo(rowSums(h2aBlocks)), + intSe = .jackknifeSeFromLoo(intLoo), h2aBlocks = h2aBlocks ) } @@ -1429,15 +1496,19 @@ NULL # intercept fixed at the global fit; SE from the Gaussian-variance Fisher # information sum((dlamh2/dh2)^2 / (2 lamh2^2)). .hdlLocalBlock <- function(bd, b, n, nSamples, int, M, lim = exp(-10)) { - varOf <- function(h2) { - pmax( - h2 / M * bd$lam^2 - h2 * bd$lam / nSamples + int * bd$lam / n, - lim - ) - } - nll <- function(h2) sum(log(varOf(h2)) + bd$bstar^2 / varOf(h2)) - h2 <- optimize(nll, c(0, 1))$minimum - lamh2 <- varOf(h2) + # `intercept`, not `int`: optimize() would partially match `int` to its + # own `interval` argument. + h2 <- optimize( + .hdlLocalNll, + c(0, 1), + bd = bd, + M = M, + nSamples = nSamples, + intercept = int, + n = n, + lim = lim + )$minimum + lamh2 <- .hdlLocalVar(h2, bd, M, nSamples, int, n, lim) g <- bd$lam^2 / M - bd$lam / nSamples info <- sum(g^2 / (2 * lamh2^2)) tibble( @@ -1447,6 +1518,24 @@ NULL ) } +# Modeled variance of one block's bstar^2 at local heritability `h2`, the +# intercept fixed at the global fit; floored at `lim`. +# @noRd +.hdlLocalVar <- function(h2, bd, M, nSamples, intercept, n, lim) { + pmax( + h2 / M * bd$lam^2 - h2 * bd$lam / nSamples + intercept * bd$lam / n, + lim + ) +} + +# Gaussian negative log-likelihood (up to a constant) of one block's bstar at +# local heritability `h2` -- what .hdlLocalBlock() minimizes. +# @noRd +.hdlLocalNll <- function(h2, bd, M, nSamples, intercept, n, lim) { + lamh2 <- .hdlLocalVar(h2, bd, M, nSamples, intercept, n, lim) + sum(log(lamh2) + bd$bstar^2 / lamh2) +} + # Per-block local heritability (NULL unless requested). .hdlLocal <- function(blockData, n, nSamples, int, M) { bind_rows( @@ -1480,21 +1569,15 @@ NULL } # sHDL candidate-annotation score statistics + jackknife score correlation. -.shdlStratified <- function(eigenRef, annotations, design, lamh2) { +.shdlStratified <- function(blockData, nPanel, annotations, design, lamh2) { candidate <- testedAnnotations(annotations) candMat <- assay(candidate, "annotations") nCand <- ncol(candMat) if (nCand == 0) { return(list(enrichment = NULL, scoreStats = NULL)) } - nPanel <- ldPanelNSamples(eigenRef) M_c <- colSums(candMat) - candCross <- map( - eigenList(eigenRef), - .h2EigenCandCrossprod, - candMat = candMat - ) - ldCand <- exec(rbind, !!!candCross) + ldCand <- exec(rbind, !!!map(blockData, "ldCand")) scoreResid <- design$bstar^2 / lamh2^2 - 1 / lamh2 keepAll <- rep(TRUE, length(lamh2)) scoreZ <- map_dbl( @@ -1554,41 +1637,51 @@ hdlUnivariate <- function( annotations = NULL, local = FALSE ) { - eigenList <- eigenList(eigenRef) M <- length(eigenRef) nPanel <- ldPanelNSamples(eigenRef) baselineMat <- .h2BaselineMat(annotations) + # One pass over the blocks, each decomposed only while its data are taken. blockData <- map( - eigenList, + .ldEigenBlocks(eigenRef), .hdlBlockData, + eigenRef = eigenRef, z = z, n = n, - baselineMat = baselineMat + baselineMat = baselineMat, + candMat = .h2CandidateMat(annotations) ) design <- .hdlDesign(blockData, M, baselineMat) ft <- .hdlFit(design, n, nPanel) jk <- .hdlJackknife(blockData, M, baselineMat, n, nPanel) ep <- .hdlEnrichParts(ft, jk, design, baselineMat) localDf <- if (local) .hdlLocal(blockData, n, nPanel, ft$int, M) else NULL - scoreStats <- if (is.null(annotations)) { - NULL - } else { - lamh2 <- .hdlBaselineVar(design, ft, n, nPanel) - .shdlStratified(eigenRef, annotations, design, lamh2)$scoreStats - } - jkRes <- list( + .h2JackknifeResult( + h2 = ft$h2, + intercept = ft$int, se = c(jk$h2Se, jk$intSe), - tauSe = ep$tauSe, - annotationJackknifeCoefs = ep$annotationJackknifeCoefs - ) - enrichmentDf <- .h2Enrichment( - baselineMat, - ep$tau, - ep$tauSe, - ep$annotationJackknifeCoefs, - ft$h2 + ep = ep, + baselineMat = baselineMat, + localDf = localDf, + scoreStats = .hdlCandidateScores( + blockData, + nPanel, + annotations, + design, + ft, + n + ) ) - .h2Result(ft$h2, jkRes, ft$int, ep$tau, localDf, enrichmentDf, scoreStats) +} + +# sHDL's score statistics for the candidate annotations, under the variances +# the baseline fit implies; NULL when there are none to test. +# @noRd +.hdlCandidateScores <- function(blockData, nPanel, annotations, design, ft, n) { + if (is.null(annotations)) { + return(NULL) + } + lamh2 <- .hdlBaselineVar(design, ft, n, nPanel) + .shdlStratified(blockData, nPanel, annotations, design, lamh2)$scoreStats } @@ -1622,8 +1715,10 @@ NULL #' least squares on LD scores (Finucane et al. 2015) -- the original method #' the other three estimators descend from. Per-variant \eqn{\chi^2_j} is #' regressed on annotation-stratified LD scores -#' \eqn{\ell_{jC} = \sum_{k \in C} r^2_{jk}} with a confounding -#' intercept, fitting +#' \eqn{\ell_{jC} = \sum_{k \in C} r^2_{jk}}, each \eqn{r^2} being ldsc's +#' unbiased estimate \code{r^2 - (1 - r^2) / (n - 2)} at the reference +#' panel size \code{n} (see \code{\link{buildLdScore}}), with a +#' confounding intercept, fitting #' \eqn{E[\chi^2_j] = N \sum_C \tau_C \ell_{jC} + Na + 1}. #' #' Weights are LDSC's two multiplied factors, both floored at 1: the @@ -1638,8 +1733,9 @@ NULL #' \item{unstratified}{the two-step estimator: the intercept is fit on #' the variants with \eqn{\chi^2 < 30}, then held fixed while the #' slope is fit over all of them.} -#' \item{stratified}{no two-step -- upstream refuses one on a -#' partitioned design. Variants with \eqn{\chi^2 >} \code{max(0.001 +#' \item{stratified}{no two-step -- the original \code{ldsc} refuses +#' one on a partitioned design. Variants with \eqn{\chi^2 >} +#' \code{max(0.001 #' N, 80)} are dropped, the design is weighted once, and a single #' weighted least-squares fit follows.} #' } @@ -1649,15 +1745,17 @@ NULL #' than an error to clamp away, and clamping would move the heritability #' too. #' -#' Estimates agree with upstream \code{ldsc} to roughly 1e-6 relative; -#' the residual is a small ridge in the weighted solve, which upstream has -#' no equivalent of and which exists so an exactly singular design returns -#' a value rather than \code{NA}. +#' Estimates agree with the original \code{ldsc} implementation to +#' roughly 1e-6 relative; the residual is a small ridge in the weighted +#' solve, which the original has no equivalent of and which exists so an +#' exactly singular design returns a value rather than \code{NA}. #' #' Unlike \code{\link{pecotmr-h2-gldsc}} this needs only the per-variant #' scores when unstratified, so it runs on a scores-only #' \code{\link{LdScore}}; the stratified fit forms per-annotation scores -#' from the per-block LD matrices and therefore requires them. +#' from each block's LD, so it needs an \code{LdScore} that carries it: +#' one built from a genotype panel, or from \code{LdMatrix} blocks with +#' their matrices kept. #' #' \strong{Scale.} LD score regression is a genome-scale method -- real #' analyses regress over roughly a million variants. On a reference of a @@ -1698,62 +1796,60 @@ sldscUnivariate <- function( } # The design's LD-score columns: the base score first, then one stratified -# score per baseline annotation. Stratified scores come from the per-block LD -# matrices, the same source g-LDSC uses. +# score per baseline annotation. Stratified scores come from each block's LD, +# the same source g-LDSC uses, and take ldsc's unbiased r^2 as the stored +# base score does: ldsc applies it to every annotation column. # @noRd .sldscScoreMatrix <- function(ldRef, baselineMat, M) { base <- as.vector(mcols(ldRef)$ldScores[, 1L]) if (is.null(baselineMat)) { return(matrix(base, ncol = 1L, dimnames = list(NULL, "base_l2"))) } - ldMatrixList <- ldMatrixList(ldRef) - if (length(ldMatrixList) == 0L) { - msg <- glue( - "stratified S-LDSC requires full per-block LD matrices ", - "(ldMatrixList) to form the per-annotation LD scores. Build the ", - "reference with `buildLdScore(keepLdMatrices = TRUE)`." - ) - abort(msg) + if (!.ldScoreHasLd(ldRef)) { + abort(str_c( + "stratified S-LDSC needs each LD block's LD to form the ", + "per-annotation LD scores. Build the reference from a genotype ", + "panel, or with `buildLdScore(keepLdMatrices = TRUE)`." + )) } - strat <- .h2ScatterBlockRows( - matrix(0, M, ncol(baselineMat)), - map(ldMatrixList, .h2BlockAnnotScores, baselineMat = baselineMat) - ) - cbind(base_l2 = base, strat) + cbind(base_l2 = base, .h2StratifiedScores(ldRef, baselineMat)) } -# One block's per-annotation LD scores from its full LD matrix. +# Annotation-stratified LD scores sum_k r^2_jk a_k under ldsc's unbiased r^2, +# one column per annotation, from each block's LD: stored, or read from the +# genotype panel a block at a time. # @noRd -.h2BlockAnnotScores <- function(block, baselineMat) { - idx <- block$snpIdx - list( - idx = idx, - values = (block$R^2) %*% baselineMat[idx, , drop = FALSE] +.h2StratifiedScores <- function(ldRef, annotMat) { + .h2ScatterBlockRows( + matrix(0, length(ldRef), ncol(annotMat)), + map( + .ldScoreBlocks(ldRef), + .h2BlockAnnotScores, + panel = ldReference(ldRef), + annotMat = annotMat, + nRef = .ldscPanelN(ldRef) + ) ) } -# Per-block variant indices, from the LD matrices when present and otherwise -# by overlapping the reference's variants with its LD blocks. The jackknife -# leaves one of these out at a time. +# One block's per-annotation LD scores from its LD, summing ldsc's unbiased +# r^2 by its summed form. +# @noRd +.h2BlockAnnotScores <- function(block, panel, annotMat, nRef) { + idx <- block$idx + Ab <- annotMat[idx, , drop = FALSE] + raw <- .ldSquaredProduct(.ldStatBlockLd(block, panel), Ab) + list(idx = idx, values = .ldscUnbiasedSum(raw, colSums(Ab), nRef)) +} + +# Per-block variant indices: the LD blocks the estimators walk, which the +# jackknife leaves out one at a time. # @noRd .sldscBlockIndex <- function(ldRef) { - ldMatrixList <- ldMatrixList(ldRef) - if (length(ldMatrixList) > 0L) { - return(map(ldMatrixList, "snpIdx")) - } - snpInfo <- tibble( - CHR = as.character(seqnames(ldRef)), - BP = start(ldRef) - ) - idx <- snpsPerBlock(snpInfo, ldBlocks(ldRef)) - keep <- idx[map_int(idx, length) > 0L] - if (length(keep) == 0L) { - abort("S-LDSC: no LD block covers any reference variant.") - } - keep + map(.ldScoreBlocks(ldRef), "idx") } -# Upstream `Hsq.weights` verbatim (ldsc/ldscore/regressions.py): +# `Hsq.weights` from the original ldsc, verbatim (ldscore/regressions.py): # # hsq = clamp(hsq, 0, 1) # ld = max(ld, 1); w_ld = max(w_ld, 1) @@ -1763,8 +1859,8 @@ sldscUnivariate <- function( # # `ld` is the LD score entering the model and `w_ld` the one computed over # just the regression variants. pecotmr carries a single score, so both read -# the same column -- also the usual case upstream, where --w-ld-chr names the -# same file as --ref-ld-chr. +# the same column -- also the usual case with the original ldsc, where +# --w-ld-chr names the same file as --ref-ld-chr. # @noRd .sldscWeights <- function(ld, wLd, n, M, hsq, intercept) { hsq <- min(max(hsq, 0), 1) @@ -1781,8 +1877,8 @@ sldscUnivariate <- function( M * (mean(chi2) - intercept) / mean(n * baseScore) } -# Upstream takes two different routes and the split is on annotation count, -# not on preference (ldscore/sumstats.py): +# The original ldsc takes two different routes and the split is on annotation +# count, not on preference (ldscore/sumstats.py): # # univariate -- two-step estimator, chi2 < 30 selects step 1, IRWLS twice # partitioned -- NO two-step; it raises rather than attempt one. Variants @@ -1807,7 +1903,8 @@ sldscUnivariate <- function( capped <- chi2 < 30 keep <- if (sum(capped) < 4L) rep(TRUE, length(chi2)) else capped # One set of initial weights, formed on the full data, reused by both - # steps -- upstream computes `initial_w` once and subsets it for step 1. + # steps -- the original ldsc computes `initial_w` once and subsets it for + # step 1. xTot <- rowSums(scores) aggH2 <- .sldscAggregateH2(chi2, xTot, n, M) w0 <- .sldscWeights(xTot, baseScore, n, M, aggH2, 1) @@ -1821,8 +1918,8 @@ sldscUnivariate <- function( freeIntercept = TRUE, w0 = w0[keep] ) - # Not floored at 1. The model implies an intercept of at least 1, but - # upstream reports whatever step 1 estimates -- a value below 1 is + # Not floored at 1. The model implies an intercept of at least 1, but the + # original ldsc reports whatever step 1 estimates -- a value below 1 is # informative (it says the data are inconsistent with the model, often # deflation) and clamping it silently would change the h2 as well. intercept <- step1$intercept @@ -1854,15 +1951,16 @@ sldscUnivariate <- function( chi2 <- chi2[keep] scores <- scores[keep, , drop = FALSE] baseScore <- baseScore[keep] - # `x_tot` upstream: the row-sum of the design's annotation columns, which - # coincides with the base score only when there is a single column. + # `x_tot` in the original ldsc: the row-sum of the design's annotation + # columns, which coincides with the base score only when there is a + # single column. xTot <- rowSums(scores) hsq <- .sldscAggregateH2(chi2, xTot, n, M) w <- .sldscWeights(xTot, baseScore, n, M, hsq, 1) .sldscCoefToFit(.sldscWlsCoef(cbind(scores, 1), chi2, w), n, A) } -# Two IRWLS passes, matching upstream's `for i in range(2)`. +# Two IRWLS passes, matching the original ldsc's `for i in range(2)`. # @noRd .sldscIrwls <- function( y, @@ -1885,19 +1983,19 @@ sldscUnivariate <- function( coef <- NULL for (i in seq_len(max(1L, nIter))) { coef <- .sldscWlsCoef(design, y, w) - # Upstream builds the weight from the FIRST coefficient and `x_tot` - # alone -- a univariate approximation even for a partitioned design -- - # rather than from the full fitted values. + # The original ldsc builds the weight from the FIRST coefficient and + # `x_tot` alone -- a univariate approximation even for a partitioned + # design -- rather than from the full fitted values. hsq <- M * coef[[1L]] / n if (freeIntercept) { intercept <- max(coef[[length(coef)]], 0) } w <- .sldscWeights(xTot, baseScore, n, M, hsq, intercept) } - # Upstream's loop updates the weights `nIter` times and then solves once - # more with the converged weights -- three solves for its two passes, not - # two. Stopping at the loop's last solve leaves the final weight update - # unused and shifts the estimate by around a percent. + # The original ldsc's loop updates the weights `nIter` times and then + # solves once more with the converged weights -- three solves for its two + # passes, not two. Stopping at the loop's last solve leaves the final + # weight update unused and shifts the estimate by around a percent. coef <- .sldscWlsCoef(design, y, w) list( coef = coef[seq_len(ncol(scores))], @@ -1955,12 +2053,10 @@ sldscUnivariate <- function( jkCoefs <- exec(rbind, !!!map(loo, "tau")) estHBlocks <- exec(rbind, !!!map(loo, "estH")) intLoo <- map_dbl(loo, "intercept") - nB <- length(loo) - jkSe <- function(v) sqrt(var(v) * (nB - 1)^2 / nB) list( - h2Se = jkSe(estHBlocks[, 1L]), - intSe = jkSe(intLoo), - tauSe = apply(jkCoefs, 2, jkSe), + h2Se = .jackknifeSeFromLoo(estHBlocks[, 1L]), + intSe = .jackknifeSeFromLoo(intLoo), + tauSe = apply(jkCoefs, 2, .jackknifeSeFromLoo), annotationJackknifeCoefs = jkCoefs, estHBlocks = estHBlocks ) @@ -2065,8 +2161,9 @@ sldscUnivariate <- function( # trailing arguments (`nIter` for sldsc; the others take none today), so # an unknown name should fail here rather than at whichever estimator the # method token happens to select. lder/gldsc/hdl used to advertise a - # ridge `lambda` here that nothing read -- upstream LDER and HDL have no - # such penalty, and the function behind it had no callers. + # ridge `lambda` here that nothing read -- the original LDER and HDL + # implementations have no such penalty, and the function behind it had no + # callers. base <- list(z, n, ldRef, annotations, local) fn <- switch( method, @@ -2249,50 +2346,83 @@ setMethod( base } -# One block's base LD scores. +# One block's base LD scores. sum_k r^2_jk is sum_i (V[j,i] d[i])^2 because +# R = V D V' with orthonormal V, so the raw sum needs no R; the summed form of +# ldsc's unbiased r^2 then corrects it exactly, the block size being the +# weight sum. # @noRd -.h2BlockBaseScores <- function(block) { +.h2BlockBaseScores <- function(block, nRef) { Vd <- sweep(block$vectors, 2, block$values, "*") - list(idx = block$snpIdx, values = rowSums(Vd^2)) + list( + idx = block$snpIdx, + values = .ldscUnbiasedSum( + cbind(rowSums(Vd^2)), + length(block$snpIdx), + nRef + ) + ) } -# Base LD scores l2[j] = sum_i (V[j,i] * d[i])^2 (since R = V D V'). -.computeLdScoresBase <- function(eigenList, nSnps) { +# Base LD scores: ldsc's unbiased r^2 summed over each variant's block. +.computeLdScoresBase <- function(ldRef, nRef) { .h2ScatterBlockRows( - matrix(0, nrow = nSnps, ncol = 1, dimnames = list(NULL, "base_l2")), - map(eigenList, .h2BlockBaseScores) + matrix( + 0, + nrow = length(ldRef), + ncol = 1, + dimnames = list(NULL, "base_l2") + ), + map( + .ldEigenBlocks(ldRef), + .h2BlockBaseScoresAt, + ldRef = ldRef, + nRef = nRef + ) ) } +# @noRd +.h2BlockBaseScoresAt <- function(block, ldRef, nRef) { + .h2BlockBaseScores(.ldEigenBlockAt(block, ldRef), nRef) +} + # Base + annotation-stratified LD scores. Stratified column a: -# l2_a[j] = sum_i (V[j,i] d[i])^2 * (sum_k V[k,i]^2 annot[k,a]). -.computeLdScoresStratified <- function(eigenList, annotations, nSnps) { +# l2_a[j] = sum_k r^2_jk annot[k, a], under ldsc's unbiased r^2. +.computeLdScoresStratified <- function(ldRef, annotations, nRef) { annotMat <- assay(annotations, "annotations") annotNames <- SummarizedExperiment::colData(annotations)$name .h2ScatterBlockRows( matrix( 0, - nrow = nSnps, + nrow = length(ldRef), ncol = 1 + ncol(annotMat), dimnames = list(NULL, c("base_l2", annotNames)) ), - map(eigenList, .h2BlockStratScores, annotMat = annotMat) + map( + .ldEigenBlocks(ldRef), + .h2BlockStratScores, + ldRef = ldRef, + annotMat = annotMat, + nRef = nRef + ) ) } -# One block's base + annotation-stratified scores. All annotations are taken -# in a single matrix product rather than one column at a time. +# One block's base + annotation-stratified scores. The weighted sums need R's +# entries: the eigen shortcut sum_i (V[j,i] d[i])^2 * sum_k V[k,i]^2 +# annot[k,a] drops the cross terms between eigenvectors, which cancel only +# when every annot[k, a] is 1, so it is not the stratified score. R's rows +# are rebuilt from the decomposition a stripe at a time, and the summed form +# of ldsc's unbiased r^2 corrects every column at once. # @noRd -.h2BlockStratScores <- function(block, annotMat) { - idx <- block$snpIdx - V <- block$vectors - Vd2 <- sweep(V, 2, block$values, "*")^2 +.h2BlockStratScores <- function(block, ldRef, annotMat, nRef) { + dec <- .ldEigenBlockAt(block, ldRef) + idx <- dec$snpIdx + Ab <- annotMat[idx, , drop = FALSE] + raw <- .ldSquaredProduct(dec[c("vectors", "values")], cbind(1, Ab)) list( idx = idx, - values = cbind( - rowSums(Vd2), - Vd2 %*% crossprod(V^2, annotMat[idx, , drop = FALSE]) - ) + values = .ldscUnbiasedSum(raw, c(length(idx), colSums(Ab)), nRef) ) } @@ -2302,14 +2432,13 @@ setMethod( "computeLdScores", signature(ldRef = "LdEigen"), function(ldRef, annotations = NULL) { - # Reconstruct LD scores from eigendecompositions - # l2[j] = sum_k r^2_{jk} = sum_b sum_{eigenvalues in b} V[j,.]^2 * d - nSnps <- length(ldRef) - eigenList <- eigenList(ldRef) + # LD scores from the eigendecompositions, under ldsc's unbiased r^2, + # so they match buildLdScore() on the same reference. + nRef <- .ldscPanelN(ldRef) if (is.null(annotations)) { - return(.computeLdScoresBase(eigenList, nSnps)) + return(.computeLdScoresBase(ldRef, nRef)) } - .computeLdScoresStratified(eigenList, annotations, nSnps) + .computeLdScoresStratified(ldRef, annotations, nRef) } ) @@ -2322,25 +2451,20 @@ setMethod( if (is.null(annotations)) { return(mcols(ldRef)$ldScores) } - - # Compute annotation-stratified LD scores using LD matrices - ldMatrixList <- ldMatrixList(ldRef) - if (length(ldMatrixList) == 0) { - msg <- glue( - "Annotation-stratified LD scores require ldMatrixList in ", - "LdScore. ", - "Recompute the LD reference with full LD matrices." - ) - abort(msg) + if (!.ldScoreHasLd(ldRef)) { + abort(str_c( + "Annotation-stratified LD scores need each LD block's LD, ", + "and this LdScore carries none. Build it from a genotype ", + "panel, or from LdMatrix blocks with `keepLdMatrices = TRUE`." + )) } - - annotMat <- assay(annotations, "annotations") - # The stratified columns l2_a[j] = sum_k R^2_{jk} annot[k, a] are - # scattered per block; the base column comes from the reference and - # is joined on afterwards, so the scatter never touches it. - strat <- .h2ScatterBlockRows( - matrix(0, nrow = length(ldRef), ncol = ncol(annotMat)), - map(ldMatrixList, .h2BlockAnnotScores, baselineMat = annotMat) + # The stratified columns l2_a[j] = sum_k r^2_jk annot[k, a], under + # ldsc's unbiased r^2, are scattered per block; the base column comes + # from the reference and is joined on afterwards, so the scatter + # never touches it. + strat <- .h2StratifiedScores( + ldRef, + assay(annotations, "annotations") ) `colnames<-`( cbind(mcols(ldRef)$ldScores[, 1], strat), @@ -2423,14 +2547,6 @@ h2EstimateToSldscTrait <- function(h2Est) { # ---- map/apply helpers (lambda-free callbacks) --------------------------- -# crossprod of one eigen block's squared vectors against its -# candidate-annotation -# rows. Shared by the LDER and sHDL candidate-score assemblies. -# @noRd -.h2EigenCandCrossprod <- function(bk, candMat) { - crossprod(bk$vectors^2, candMat[bk$snpIdx, , drop = FALSE]) -} - # One LDER delete-one-block jackknife fold: design and fit with block `b` left # out. # @noRd @@ -2486,8 +2602,8 @@ h2EstimateToSldscTrait <- function(h2Est) { # One g-LDSC local-heritability row for block `b`. # @noRd -.gldscLocalRow <- function(b, preps, rawNtau, N) { - .gldscLocalBlock(preps[[b]], b, rawNtau, N) +.gldscLocalRow <- function(b, contrib, N) { + .gldscLocalBlock(contrib[[b]], b, N) } # g-LDSC leave-one-block-out standardized candidate score vector for block `b`. diff --git a/R/jointEngine.R b/R/jointEngine.R index fce1a4eaa..77a9f6a52 100644 --- a/R/jointEngine.R +++ b/R/jointEngine.R @@ -328,6 +328,28 @@ setMethod( # fsusie joint fit (functional SuSiE over the trait domain; individual-level, # cross-trait). Keep the first post-processed entry for this joint fit. +# +# The credible-set arguments supply what .fmOwnedEngineArgs("fsusieR::susiF") +# says is supplied: these are refused in FsusieOptions, so the pipeline is +# their only source. They are fitFsusie() formals, so .splitMethodArgs() +# routes them past the constructor that refuses them. +# +# The functional fit is collapsed to a variants x features weight matrix now +# (trimming later drops fitted_wc) and stored on $coef, so a trimmed fit can +# still yield TWAS weights. +# +# Returns ONE entry for the whole joint fit, unlike mvsusie's +# one-per-condition. mvsusie's posteriors carry a conditions axis, so +# .fmSliceCond() gives each condition its own 2-D slice and N rows partition +# the fit at no cost. An fsusie fit has no such axis: each trait is a POSITION +# on a shared functional grid, so `fitted_func` / `cred_band` / `outing_grid` +# describe all traits at once and cannot be sliced per trait. One row per +# trait would therefore store N copies of the same curve. +# +# The trait list itself is not lost -- every row carries the full joint +# membership in its `jointTraits` column. Only the grid POSITIONS are +# unrecoverable from that, and they are what maps a curve position back to a +# trait, so they ride on the fit. # @noRd .jointFitFsusie <- function(group, Xc, Yc, nCond, cfg, args) { if (length(.jgTraitPos(group)) != nCond) { @@ -338,10 +360,31 @@ setMethod( abort(msg) } verbose <- if (is.null(cfg$verbose)) 1 else cfg$verbose - # Supply what .fmOwnedEngineArgs("fsusieR::susiF") says is supplied: - # these are refused in FsusieOptions, so the pipeline is their only - # source. They are fitFsusie() formals, so .splitMethodArgs() routes them - # past the constructor that refuses them. + fit <- if (.jointFitsFullData(cfg)) { + .jointFsusieFullFit(group, Xc, Yc, cfg, args) + } else { + NULL + } + cvM <- .jointFsusieCv(Xc, Yc, group, cfg, args, verbose) + entry <- .jointFsusieEntry( + r = 1L, + fit = fit, + cvM = cvM, + Xc = Xc, + cfg = cfg, + af = args$af, + region = args$region + ) + if (!is.null(fit)) { + entry@susieFit$trait_positions <- .jgTraitPos(group) + } + list(entry) +} + +# The full-data fSuSiE fit of one joint group, with its functional fit +# collapsed to a variants x features weight matrix on $coef. +# @noRd +.jointFsusieFullFit <- function(group, Xc, Yc, cfg, args) { csp <- cfg$credibleSetParam fitArgs <- .fmMergeUserArgs( list( @@ -352,14 +395,10 @@ setMethod( covLev = csp$coverage, minPurity = csp$minAbsCorr ), - "fsusie", args$methodArgs[["fsusie"]] ) raw <- exec(fitFsusie, !!!.splitMethodArgs(fitFsusie, fitArgs)) - # Collapse the functional fit to a variants x features weight matrix now - # (trimming later drops fitted_wc); store on $coef so a trimmed fit - # can still yield TWAS weights. - fit <- list_assign( + list_assign( raw, coef = try_fetch( fsusieWeights(fsusieFit = raw, variantIds = colnames(Xc)), @@ -367,36 +406,12 @@ setMethod( ) ) |> .setFinemappingFitClass("fsusie") - cvM <- .jointFsusieCv(Xc, Yc, group, cfg, args, verbose) - entry <- .jointFsusieEntry( - r = 1L, - fit = fit, - cvM = cvM, - Xc = Xc, - cfg = cfg, - af = args$af, - region = args$region - ) - # ONE entry for the whole joint fit, unlike mvsusie's one-per-condition. - # mvsusie's posteriors carry a conditions axis, so .fmSliceCond() gives - # each condition its own 2-D slice and N rows partition the fit at no - # cost. An fsusie fit has no such axis: each trait is a POSITION on a - # shared functional grid, so `fitted_func` / `cred_band` / `outing_grid` - # describe all traits at once and cannot be sliced per trait. One row per - # trait would therefore store N copies of the same curve. - # - # The trait list itself is not lost -- every row carries the full joint - # membership in its `jointTraits` column. Only the grid POSITIONS are - # unrecoverable from that, and they are what maps a curve position back - # to a trait, so they ride on the fit. - entry@susieFit$trait_positions <- .jgTraitPos(group) - list(entry) } # Per-fold fsusie CV slice, or NULL when CV is disabled. # @noRd .jointFsusieCv <- function(Xc, Yc, group, cfg, args, verbose) { - cv <- cfg$crossValidationArgs %||% list() + cv <- cfg$crossValidationParam %||% list() cvFolds <- cv$folds %||% 0L if (cvFolds <= 1L) { return(NULL) @@ -407,11 +422,11 @@ setMethod( "fsusie", args$methodArgs, cvFolds, - samplePartition = cfg$crossValidationArgs$samplePartition, + samplePartition = cfg$crossValidationParam$samplePartition, coverage = cfg$credibleSetParam$coverage, pos = .jgTraitPos(group), verbose = verbose, - numThreads = cv$threads %||% 1L, + numThreads = cv$numThreads %||% 1L, seed = cfg$seed ) .fmSliceCv(cv, "fsusie") @@ -430,18 +445,22 @@ setMethod( af = NULL, region = NULL ) { - bare <- .fmPostprocessOne( - fit = fit, - method = "fsusie", - dataX = Xc, - dataY = NULL, - af = af, - region = region, - conditionIdx = r, - csInput = "fsusie", - credibleSetParam = cfg$credibleSetParam, - fitRetention = cfg$fitRetention - ) + bare <- if (is.null(fit)) { + .fmCvOnlyRow() + } else { + .fmPostprocessOne( + fit = fit, + method = "fsusie", + dataX = Xc, + dataY = NULL, + af = af, + region = region, + conditionIdx = r, + csInput = "fsusie", + credibleSetParam = cfg$credibleSetParam, + fitRetention = cfg$fitRetention + ) + } e <- if (is.null(cvM)) { bare } else { @@ -531,22 +550,11 @@ setMethod( context = key$context ) mvPrior <- .buildMvsusieReweightedPrior(mvFitParts, colnames(Ys), ddCut) - mvBaseArgs <- c( - list( - X = Xc, - Y = Ys, - prior_variance = mvPrior$priorVariance, - coverage = cfg$credibleSetParam$coverage - ), - compact(list(residual_variance = mvPrior$residualVariance)) - ) - fitArgs <- .fmMergeUserArgs( - mvBaseArgs, - "mvsusie", - args$methodArgs[["mvsusie"]] - ) - fit <- exec(fitMvsusie, !!!.splitMethodArgs(fitMvsusie, fitArgs)) |> - .setFinemappingFitClass("mvsusie") + fit <- if (.jointFitsFullData(cfg)) { + .jointMvFullFit(Xc, Ys, cfg, args, mvPrior) + } else { + NULL + } cvM <- .jointMvCv( Xc, Ys, @@ -561,6 +569,30 @@ setMethod( list(fit = fit, cvM = cvM) } +# The full-data mvSuSiE fit of one joint group, under the reweighted prior. +# @noRd +.jointMvFullFit <- function(Xc, Ys, cfg, args, mvPrior) { + mvBaseArgs <- c( + list( + X = Xc, + Y = Ys, + prior_variance = mvPrior$priorVariance, + coverage = cfg$credibleSetParam$coverage + ), + compact(list(residual_variance = mvPrior$residualVariance)) + ) + fitArgs <- .fmMergeUserArgs(mvBaseArgs, args$methodArgs[["mvsusie"]]) + exec(fitMvsusie, !!!.splitMethodArgs(fitMvsusie, fitArgs)) |> + .setFinemappingFitClass("mvsusie") +} + +# Whether a joint run fits the full data as well as cross-validating, from the +# CrossValidationParam's fitFullData (TRUE when unset). +# @noRd +.jointFitsFullData <- function(cfg) { + isTRUE(cfg$crossValidationParam$fitFullData %||% TRUE) +} + # Per-fold mvsusie CV slice (reusing the mr.mash prior per fold), or NULL. # @noRd .jointMvCv <- function( @@ -574,12 +606,12 @@ setMethod( ddCut, verbose ) { - cv <- cfg$crossValidationArgs %||% list() + cv <- cfg$crossValidationParam %||% list() cvFolds <- cv$folds %||% 0L if (cvFolds <= 1L) { return(NULL) } - sp <- cfg$crossValidationArgs$samplePartition %||% mvCv$samplePartition + sp <- cfg$crossValidationParam$samplePartition %||% mvCv$samplePartition mvPriorCv <- .fmBuildMvsusiePriorCv(mvCv, mvFitParts, colnames(Ys), ddCut) cv <- .fmWeightsCv( Xc, @@ -592,7 +624,7 @@ setMethod( verbose = verbose, mvPrior = mvPrior, mvPriorCv = mvPriorCv, - numThreads = cv$threads %||% 1L, + numThreads = cv$numThreads %||% 1L, seed = cfg$seed ) .fmSliceCv(cv, "mvsusie") @@ -617,18 +649,22 @@ setMethod( return(NULL) } r <- match(i, survivors) - bare <- .fmPostprocessOne( - fit = fitted$fit, - method = "mvsusie", - dataX = Xc, - dataY = NULL, - af = af, - region = region, - conditionIdx = r, - csInput = "X", - credibleSetParam = cfg$credibleSetParam, - fitRetention = cfg$fitRetention - ) + bare <- if (is.null(fitted$fit)) { + .fmCvOnlyRow() + } else { + .fmPostprocessOne( + fit = fitted$fit, + method = "mvsusie", + dataX = Xc, + dataY = NULL, + af = af, + region = region, + conditionIdx = r, + csInput = "X", + credibleSetParam = cfg$credibleSetParam, + fitRetention = cfg$fitRetention + ) + } e <- if (is.null(fitted$cvM)) { bare } else { @@ -702,11 +738,7 @@ setMethod( coverage = cfg$credibleSetParam$coverage ) |> c(compact(list(residual_variance = mvPrior$residualVariance))) - fitArgs <- .fmMergeUserArgs( - mvBaseArgs, - "mvsusie", - args$methodArgs[["mvsusie"]] - ) + fitArgs <- .fmMergeUserArgs(mvBaseArgs, args$methodArgs[["mvsusie"]]) fit <- exec( fitMvsusieRss, !!!.splitMethodArgs(fitMvsusieRss, fitArgs) @@ -715,10 +747,10 @@ setMethod( } # One RSS per-condition FineMappingRow (csInput = "Xcorr"). -# @noRd -# `credibleSet` / `fitRetention` come off `cfg`, which is what the caller +# `credibleSetParam` / `fitRetention` come off `cfg`, which is what the caller # supplies; they were also declared as formals with no defaults, so nothing # could ever have passed them without erroring. `group` was unused too. +# @noRd .jointRssEntry <- function(r, fit, ldMat, cfg, region = NULL) { .fmPostprocessOne( fit = fit, @@ -960,8 +992,30 @@ setMethod( if (identical(level, "none")) "slim" else level } +# The mr.mash RSS fit of one summary-statistics joint group, with the caller's +# per-method options split across the wrapper's own formals and the engine's +# arguments exactly as the per-tuple path splits them (.twasWeightCallArgs()). +# @noRd +.jointMrmashRssWeights <- function(group, cfg, args) { + callArgs <- .twasWeightCallArgs( + "mrmashRssWeights", + list( + stat = list( + z = .jgZ(group), + n = .jgN(group), + variantNames = .jgVariantIds(group) + ), + ldReference = .jgLdRef(group), + fitRetention = .jointRetentionLevel(cfg) + ), + .twasUserArgs(args$methodArgs, "mrmash") + ) + exec(mrmashRssWeights, !!!callArgs) +} + # Full-data TWAS weight fit for a joint group. Returns list(W, fitParts, vids); -# W is NULL (a CV-only run) when fitFullData is FALSE. +# W is NULL (a CV-only run) when the CrossValidationParam's fitFullData is +# FALSE. # @noRd .jointTwasFitFull <- function( Xc, @@ -973,12 +1027,7 @@ setMethod( stdz, nCond ) { - fitFullData <- if (is.null(cfg$fitFullData)) { - TRUE - } else { - isTRUE(cfg$fitFullData) - } - if (!fitFullData) { + if (!.jointFitsFullData(cfg)) { return(list(W = NULL, fitParts = NULL, vids = colnames(Xc))) } retention <- .jointRetentionLevel(cfg) @@ -1053,13 +1102,12 @@ setMethod( is_in(token, c(canonical[!is.na(canonical)], bare)) } -# @noRd # Whether this token is barred from cross-validation: not requested, or its # weights are all zero so there is nothing to validate. A fine-mapping method # with no recoverable per-fold fits is an error rather than a silent skip. # @noRd .jointTwasCvBlocked <- function(W, cfg, token) { - if (!.jointTwasCvRequested(cfg$crossValidationArgs$weightMethods, token)) { + if (!.jointTwasCvRequested(cfg$crossValidationParam$weightMethods, token)) { return(TRUE) } if (!is.null(W) && all(W == 0)) { @@ -1091,7 +1139,7 @@ setMethod( # per-call args first and the pipeline config as the fallback. # @noRd .jointTwasRunCv <- function(Xc, Yc, wm, args, cfg, cvFolds) { - cv <- cfg$crossValidationArgs %||% list() + cv <- cfg$crossValidationParam %||% list() maxCv <- if ((cv$maxVariants %||% -1) <= 0) { Inf } else { @@ -1105,15 +1153,16 @@ setMethod( weightMethods = wm, fitRetention = "slim", maxNumVariants = maxCv, - numThreads = cfg$crossValidationArgs$threads %||% 1, + numThreads = cfg$crossValidationParam$numThreads %||% 1, dataDrivenPriorMatricesCv = args$dataDrivenPriorMatricesCv, verbose = cfg$verbose %||% 1, seed = cfg$seed ) } +# @noRd .jointTwasCv <- function(Xc, Yc, wm, ma, W, args, cfg, token) { - cv <- cfg$crossValidationArgs %||% list() + cv <- cfg$crossValidationParam %||% list() cvFolds <- cv$folds %||% 0L if (cvFolds <= 1L) { return(NULL) @@ -1168,11 +1217,7 @@ setMethod( signature("SumStatsJointGroup", "TwasJointPipeline"), function(group, pipeline, token, args) { cfg <- .jpConfig(pipeline) - weights <- mrmashRssWeights( - stat = list(z = .jgZ(group), n = .jgN(group)), - LD = .jgLdMatrix(group), - fitRetention = .jointRetentionLevel(cfg) - ) + weights <- .jointMrmashRssWeights(group, cfg, args) vids <- rownames(weights) %||% rownames(.jgZ(group)) fitParts <- attr(weights, "fit") # A single-condition fit comes back as a bare vector; the per-condition @@ -1206,29 +1251,30 @@ setMethod( # columns for axes that actually vary are attached. # Fold the accumulator's per-row records into one collection: build each record # into a 1-row collection via `constructor`, then union them with the generic -# .rbindCollections (which aligns optional columns and sets the ldSketch slot). -# The only per-row transforms are: wrap `entry` in a list, and drop an NA joint* -# value so the 1-row collection omits that column (the union re-adds it, padded, -# only when some row is joint). Every other field -- study/context/trait/method, -# region, and any future column -- flows through untouched. -.buildJointResult <- function(constructor, records, ldSketch = NULL) { +# .rbindCollections (which aligns optional columns and sets the ldReference +# slot). The only per-row transforms are: wrap `entry` in a list, and drop an NA +# joint* value so the 1-row collection omits that column (the union re-adds it, +# padded, only when some row is joint). Every other field -- +# study/context/trait/method, region, and any future column -- flows through +# untouched. +.buildJointResult <- function(constructor, records, ldReference = NULL) { if (length(records) == 0L) { return(NULL) } parts <- map(records, .jointBuildRecordPart, constructor = constructor) - .rbindCollections(parts, ldSketch = ldSketch) + .rbindCollections(parts, ldReference = ldReference) } setMethod("construct", "FmJointPipeline", function(pipeline, records) { .buildJointResult( QtlFineMappingResult, records, - .jpConfig(pipeline)$ldSketch + .jpConfig(pipeline)$ldReference ) }) setMethod("construct", "TwasJointPipeline", function(pipeline, records) { - .buildJointResult(TwasWeights, records, .jpConfig(pipeline)$ldSketch) + .buildJointResult(TwasWeights, records, .jpConfig(pipeline)$ldReference) }) # ---- enumerators (pattern x dataForm -> list) -------------------- @@ -1275,7 +1321,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { verbose, label = "jointCrossContext", region = args$region, - residualizationArgs = args$residualizationArgs + residualizationParam = args$residualizationParam ) if (is.null(xy)) { return(NULL) @@ -1294,7 +1340,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # cross-context / sumstats. .enumCrossContextSumstats <- function(data, scope, args = list()) { - ldSketch <- ldSketch(data) + ldReference <- ldReference(data) studyCol <- as.character(data$study) contextCol <- as.character(data$context) traitCol <- as.character(data$trait) @@ -1304,7 +1350,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { data = data, scope = scope, args = args, - ldSketch = ldSketch, + ldReference = ldReference, studyCol = studyCol, contextCol = contextCol, traitCol = traitCol @@ -1327,7 +1373,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { data, scope, args, - ldSketch, + ldReference, studyCol, contextCol, traitCol @@ -1343,7 +1389,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { s = s, scopedContexts = scopedContexts, args = args, - ldSketch = ldSketch, + ldReference = ldReference, studyCol = studyCol, contextCol = contextCol, traitCol = traitCol @@ -1359,7 +1405,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { s, scopedContexts, args, - ldSketch, + ldReference, studyCol, contextCol, traitCol @@ -1376,14 +1422,14 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { tupleRows, ctxNames, errorLabel = "jointCrossContext (QtlSumStats)", - ldSketch = ldSketch, + ldReference = ldReference, cutoffs = args$cutoffs ) new( "SumStatsJointGroup", conditions = tibble(study = s, context = ctxNames, trait = tid), Z = jz$Z, - ldSketch = ldSketch, + ldReference = ldReference, N = jz$nVec ) } @@ -1428,7 +1474,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { label = "jointCrossTrait", studyName = studyName, region = args$region, - residualizationArgs = args$residualizationArgs + residualizationParam = args$residualizationParam ) if (is.null(xy)) { return(NULL) @@ -1455,7 +1501,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # cross-trait / sumstats. .enumCrossTraitSumstats <- function(data, scope, args = list()) { - ldSketch <- ldSketch(data) + ldReference <- ldReference(data) studyCol <- as.character(data$study) contextCol <- as.character(data$context) traitCol <- as.character(data$trait) @@ -1465,7 +1511,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { data = data, scope = scope, args = args, - ldSketch = ldSketch, + ldReference = ldReference, studyCol = studyCol, contextCol = contextCol, traitCol = traitCol @@ -1478,7 +1524,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { data, scope, args, - ldSketch, + ldReference, studyCol, contextCol, traitCol @@ -1490,7 +1536,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { s = s, scopedTraits = scope$traits[[s]], args = args, - ldSketch = ldSketch, + ldReference = ldReference, studyCol = studyCol, contextCol = contextCol, traitCol = traitCol @@ -1506,7 +1552,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { s, scopedTraits, args, - ldSketch, + ldReference, studyCol, contextCol, traitCol @@ -1523,14 +1569,14 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { tupleRows, trNames, errorLabel = "jointCrossTrait (QtlSumStats)", - ldSketch = ldSketch, + ldReference = ldReference, cutoffs = args$cutoffs ) new( "SumStatsJointGroup", conditions = tibble(study = s, context = cx, trait = trNames), Z = jz$Z, - ldSketch = ldSketch, + ldReference = ldReference, N = jz$nVec ) } @@ -1539,7 +1585,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # disjoint samples). One group per (context, trait) present in >= 2 scoped # studies; the study axis varies -> "joint" + jointStudies. .enumCrossStudySumstats <- function(data, scope, args = list()) { - ldSketch <- ldSketch(data) + ldReference <- ldReference(data) cols <- list( study = as.character(data$study), context = as.character(data$context), @@ -1555,7 +1601,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { args = args, cols = cols, allTrs = allTrs, - ldSketch = ldSketch + ldReference = ldReference )) } @@ -1568,7 +1614,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { args, cols, allTrs, - ldSketch + ldReference ) { compact(map( allTrs, @@ -1578,7 +1624,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { args = args, cols = cols, cx = cx, - ldSketch = ldSketch + ldReference = ldReference )) } @@ -1591,16 +1637,24 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { args, cols, cx, - ldSketch + ldReference ) { - .enumCrossStudyGroup(data, scope, args, cols, cx, tid, ldSketch) + .enumCrossStudyGroup(data, scope, args, cols, cx, tid, ldReference) } # One cross-study joint group for a (context, trait) cell, or NULL when fewer # than two studies survive the scope filter -- a "joint" fit over one study is # just that study, so the cell contributes nothing. # @noRd -.enumCrossStudyGroup <- function(data, scope, args, cols, cx, tid, ldSketch) { +.enumCrossStudyGroup <- function( + data, + scope, + args, + cols, + cx, + tid, + ldReference +) { candidates <- which( cols$context == cx & cols$trait == tid & @@ -1624,7 +1678,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { tupleRows, stNames, errorLabel = "jointCrossStudy", - ldSketch = ldSketch, + ldReference = ldReference, cutoffs = args$cutoffs ) new( @@ -1635,7 +1689,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { trait = tid ), Z = jz$Z, - ldSketch = ldSketch, + ldReference = ldReference, N = jz$nVec ) } @@ -1658,7 +1712,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { verbose, label = "composed", region = args$region, - residualizationArgs = args$residualizationArgs + residualizationParam = args$residualizationParam ) if (is.null(xy)) { return(list()) @@ -1707,8 +1761,15 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { naAction ) { se <- molecularTraits(data, contexts = cx) - compact(map( + traits <- keep( intersect(scope$traits[[studyName]], rownames(se)), + .traitSelectedAt, + traitId = scope$traitSelection, + s = studyName, + cx = cx + ) + compact(map( + traits, .enumUnivariateGroupFor, data = data, args = args, @@ -1727,7 +1788,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { contexts = cx, traitId = tid, naAction = naAction, - residualizationArgs = args$residualizationArgs + residualizationParam = args$residualizationParam ) X <- if (is.null(args$region)) { .fmResidGeno( @@ -1735,14 +1796,14 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { contexts = cx, traitId = tid, cisWindow = args$cisWindow, - residualizationArgs = args$residualizationArgs + residualizationParam = args$residualizationParam ) } else { .fmResidGeno( data, contexts = cx, region = args$region, - residualizationArgs = args$residualizationArgs + residualizationParam = args$residualizationParam ) } common <- intersect(rownames(X), rownames(Y)) @@ -1762,7 +1823,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # (fixed) axes form one group each. Reuses .enumerateComposedSumstatGroups. .enumComposedSumstats <- function(data, scope, args = list()) { axes <- args$axes %||% c("context", "trait") - ldSketch <- ldSketch(data) + ldReference <- ldReference(data) gi <- .enumerateComposedSumstatGroups(list(axes = axes), data, scope) if (is.null(gi)) { return(list()) @@ -1776,14 +1837,14 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { data = data, gi = gi, args = args, - ldSketch = ldSketch + ldReference = ldReference ))) } # One composed cell's group, or NULL when it spans fewer than two tuples -- # a "joint" fit over one tuple is just that tuple. # @noRd -.enumComposedGroupFor <- function(gIdx, data, gi, args, ldSketch) { +.enumComposedGroupFor <- function(gIdx, data, gi, args, ldReference) { if (length(gIdx) < 2L) { return(NULL) } @@ -1792,7 +1853,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { gIdx, map_chr(gIdx, .jointGroupColLabel, gi = gi), errorLabel = "composed (QtlSumStats)", - ldSketch = ldSketch, + ldReference = ldReference, cutoffs = args$cutoffs ) new( @@ -1803,7 +1864,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { trait = gi$traitCol[gIdx] ), Z = jz$Z, - ldSketch = ldSketch, + ldReference = ldReference, N = jz$nVec ) } @@ -1821,7 +1882,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { cfg <- .jpConfig(pipeline) cond <- .jgConditions(g) out <- list_assign(args, !!!.twasGroupFmArgs(args, cond)) - cv <- cfg$crossValidationArgs %||% list() + cv <- cfg$crossValidationParam %||% list() cvF <- cv$folds %||% 0L if (cvF <= 1L || !is(g, "IndividualJointGroup")) { return(out) @@ -1950,13 +2011,22 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # -- one method -> per-condition entries; the SR-TWAS ensemble is a layer ON TOP # of that. .runJointCell <- function(cell, pipeline, data, scope, tokens, args = list()) { + # PC groups are labelled by component, not by trait: their enumerator + # applies the selection itself, to the traits the components come from. + selection <- if (identical(.jcPattern(cell), "topPc")) { + NULL + } else { + scope$traitSelection + } groups <- .jcEnumerate(cell)(data, scope, args) |> + map(.jointGroupSelect, traitId = selection) |> + compact() |> keep(.jointGroupMeetsMin, minGroup = .jcMinGroup(cell)) if (length(groups) == 0L) { return(NULL) } doEnsemble <- is(pipeline, "TwasJointPipeline") && - isTRUE(.jpConfig(pipeline)$ensembleArgs$enabled) + isTRUE(.jpConfig(pipeline)$ensembleParam$enabled) records <- list_flatten(map( groups, .jointCellGroup, @@ -1969,30 +2039,63 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { construct(pipeline, records) } +# The group less any (context, trait) condition a per-context `traitId` +# selection leaves out, or NULL when it leaves out every one. A NULL +# selection keeps the group whole. +# @noRd +.jointGroupSelect <- function(g, traitId) { + if (is.null(traitId)) { + return(g) + } + cond <- .jgConditions(g) + .jgKeepConditions( + g, + map_lgl( + seq_len(nrow(cond)), + .jointConditionSelectedAt, + cond = cond, + traitId = traitId + ) + ) +} + +# Whether the selection keeps condition `i` of a group's conditions table. +# @noRd +.jointConditionSelectedAt <- function(i, cond, traitId) { + .traitSelectedAt( + cond$trait[[i]], + traitId, + cond$study[[i]], + cond$context[[i]] + ) +} + # Fit every token for one joint group -> records, plus the optional SR-TWAS # ensemble layer (built ON TOP of the shared per-method fits, when >= 2 methods # produced entries). +# +# `grp` carries provenance: the ";"-joined members of each varying axis +# (identical on every per-context row of this group), and the window this +# group was analysed over -- the caller's region when one was named, else the +# group's own cis window (the union span of its traits +/- cisWindow). The +# window is recorded because the fit only ever sees whichever variants +# survived QC; it is read back by genomicRegion(). +# +# `fitArgs$af` / `fitArgs$region` are provenance the fitters cannot recover for +# themselves: `data` lives here but not inside fitJointGroup(), and the +# requested window is only ever known to the caller. Both are read back as +# args$af / args$region where the entries are post-processed. # @noRd .jointCellGroup <- function(g, pipeline, data, tokens, args, doEnsemble) { cond <- .jgConditions(g) - # Provenance: the ";"-joined members of each varying axis (identical on - # every per-context row of this group). grp <- list( cond = cond, js = .jointAxisMembers(cond, "study"), jc = .jointAxisMembers(cond, "context"), jt = .jointAxisMembers(cond, "trait"), - # The window this group was analysed over: the caller's region when - # one was named, else the group's own cis window (the union span of - # its traits +/- cisWindow). Recorded because the fit only ever sees - # whichever variants survived QC; read back by genomicRegion(). region = .jointGroupWindow(data, cond, args) ) fitArgs <- .twasGroupArgs(g, pipeline, args) - # Provenance the fitters cannot recover for themselves: `data` lives here - # but not inside fitJointGroup(), and the requested window is only ever - # known to the caller. Both are read back as args$af / args$region where - # the entries are post-processed. fitArgs$af <- .jointAfForGroup(data, g) fitArgs$region <- args$region perTokenEntries <- compact(set_names( @@ -2095,17 +2198,21 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { .twasEnsembleLayer <- function(group, perTokenEntries, cfg) { tokens <- names(perTokenEntries) Y <- .jgY(group) - r2Cut <- if (is.null(cfg$ensembleArgs$r2Threshold)) { + r2Cut <- if (is.null(cfg$ensembleParam$r2Threshold)) { 0.01 } else { - cfg$ensembleArgs$r2Threshold + cfg$ensembleParam$r2Threshold } - solver <- if (is.null(cfg$ensembleArgs$solver)) { + solver <- if (is.null(cfg$ensembleParam$solver)) { "quadprog" } else { - cfg$ensembleArgs$solver + cfg$ensembleParam$solver + } + alpha <- if (is.null(cfg$ensembleParam$alpha)) { + 1 + } else { + cfg$ensembleParam$alpha } - alpha <- if (is.null(cfg$ensembleArgs$alpha)) 1 else cfg$ensembleArgs$alpha stdz <- cfg$standardized %||% FALSE map( seq_len(nrow(.jgConditions(group))), @@ -2121,9 +2228,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { ) } -# Per-condition CV predictions + weights + R^2 across the group's methods. -# Returns list(preds, wts, rsq), skipping methods with no CV / weights. -# @noRd # One token's ensemble inputs for condition `r`, or NULL when it has no # cross-validated predictions or no weights to contribute. # @noRd @@ -2158,6 +2262,9 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { ) } +# Per-condition CV predictions + weights + R^2 across the group's methods. +# Returns list(preds, wts, rsq), skipping methods with no CV / weights. +# @noRd .twasEnsembleCollect <- function(r, perTokenEntries, tokens) { parts <- compact(map( tokens, @@ -2259,7 +2366,13 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # @noRd .enumTopPcForContext <- function(cx, data, scope, args, studyName, naAction) { se <- molecularTraits(data, contexts = cx) - traits <- intersect(scope$traits[[studyName]], rownames(se)) + traits <- keep( + intersect(scope$traits[[studyName]], rownames(se)), + .traitSelectedAt, + traitId = scope$traitSelection, + s = studyName, + cx = cx + ) # PCA is undefined for a single trait, matching the fine-mapping rule. if (length(traits) < 2L) { return(list()) @@ -2269,7 +2382,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { contexts = cx, traitId = traits, naAction = naAction, - residualizationArgs = args$residualizationArgs + residualizationParam = args$residualizationParam ) scores <- .fmTopPcScores(Y, args$nPCs %||% 10L) if (is.null(scores)) { @@ -2298,14 +2411,14 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { contexts = cx, traitId = traits, cisWindow = args$cisWindow, - residualizationArgs = args$residualizationArgs + residualizationParam = args$residualizationParam )) } .fmResidGeno( data, contexts = cx, region = args$region, - residualizationArgs = args$residualizationArgs + residualizationParam = args$residualizationParam ) } @@ -2422,7 +2535,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { if (length(jointMethods) == 0L || length(parsedJointSpec) == 0L) { return(NULL) } - ldSketch <- .jpConfig(pipeline)$ldSketch + ldReference <- .jpConfig(pipeline)$ldReference isFm <- is(pipeline, "FmJointPipeline") results <- compact(map( parsedJointSpec, @@ -2441,9 +2554,9 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { rbindFn <- if (isFm) .rbindFineMappingResult else .rbindTwasWeights reduce( results, - .jointRbindWithSketch, + .jointRbindWithLdRef, rbindFn = rbindFn, - ldSketch = ldSketch + ldReference = ldReference ) } @@ -2472,8 +2585,8 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { } # @noRd -.jointRbindWithSketch <- function(acc, res, rbindFn, ldSketch) { - rbindFn(acc, res, ldSketch = ldSketch) +.jointRbindWithLdRef <- function(acc, res, rbindFn, ldReference) { + rbindFn(acc, res, ldReference = ldReference) } # Run all joint methods for ONE spec: resolve its scope (optionally @@ -2511,10 +2624,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { .runJointCell(cell, pipeline, data, scope, jointMethods, spArgs) } -# Region mode without an explicit traitId: restrict each study's scoped traits -# to the genes overlapping the locus (matches fineMappingPipeline). Gene coords -# are context-independent, so the first scoped context's SE supplies them. -# @noRd # One study's traits narrowed to those inside `region`; left alone when the # study has no context to read a phenotype from. # @noRd @@ -2531,6 +2640,10 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { ) } +# Region mode without an explicit traitId: restrict each study's scoped traits +# to the genes overlapping the locus (matches fineMappingPipeline). Gene coords +# are context-independent, so the first scoped context's SE supplies them. +# @noRd .jointRestrictRegionTraits <- function(scope, data, region) { studies <- names(scope$traits) list_assign( @@ -2596,9 +2709,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { ) } -# Build one record into a 1-row collection: wrap `entry` in a list and drop any -# NA joint* axis (so the union re-adds it, padded, only when some row is joint). -# @noRd # A joint-axis column holding a lone NA means "not a joint axis", so it is # dropped rather than carried as a column of NA. # @noRd @@ -2606,6 +2716,9 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { !is.null(value) && length(value) == 1L && is.na(value) } +# Build one record into a 1-row collection: wrap `entry` in a list and drop any +# NA joint* axis (so the union re-adds it, padded, only when some row is joint). +# @noRd .jointBuildRecordPart <- function(rec, constructor) { jointCols <- c("jointStudies", "jointContexts", "jointTraits") absent <- jointCols[map_lgl(rec[jointCols], .jointAxisIsAbsent)] diff --git a/R/jointSpecification.R b/R/jointSpecification.R index 3030c80e9..1d3e38f63 100644 --- a/R/jointSpecification.R +++ b/R/jointSpecification.R @@ -1,7 +1,7 @@ # ============================================================================= # Joint-specification grammar and ragged input-argument parsing for the -# fineMapping / twasWeights pipelines. Pure validation + normalization; -# no pipeline dispatch or fits live here. +# fineMapping / twasWeights pipelines, plus the joint-specification +# dispatchers and multi-region / multi-study merges they share. # ============================================================================= # ----------------------------------------------------------------------------- @@ -76,9 +76,6 @@ abort(msg) } -# Return character vector of contexts in `data` (across all studies when -# `study = NULL`, or for one study otherwise). -# @noRd # Concatenate a list of pieces into one, the way `c()` did, but safe on the # empty case (`list_c()` has no zero-length identity to return). # @noRd @@ -89,6 +86,9 @@ list_c(pieces) } +# Return character vector of contexts in `data` (across all studies when +# `study = NULL`, or for one study otherwise). +# @noRd .spListContexts <- function(data, studyName = NULL) { if (is(data, "QtlDataset")) { if (!is.null(studyName) && !identical(studyName, studyName(data))) { @@ -134,9 +134,6 @@ abort(msg) } -# Return character vector of traits in `data` (filtered by study and/or -# context when supplied). -# @noRd # The trait ids present in one context of a QtlDataset. # @noRd .spTraitsInContext <- function(context, data) { @@ -193,6 +190,9 @@ character(0) } +# Return character vector of traits in `data` (filtered by study and/or +# context when supplied). +# @noRd .spListTraits <- function(data, studyName = NULL, context = NULL) { if (is(data, "QtlDataset")) { return(.spListTraitsQtlDataset(data, studyName, context)) @@ -230,7 +230,6 @@ .spValidJointAxes <- c("study", "context", "trait") -# @noRd # --- parseJointSpecification helpers ---------------------------------------- # Extract (axes, scope) from a spec (character vector or named list). @@ -341,6 +340,7 @@ list(axes = axes, scope = scope) } +# @noRd parseJointSpecification <- function(jointSpecification, data) { if (is.null(jointSpecification)) { return(list()) @@ -371,10 +371,12 @@ parseJointSpecification <- function(jointSpecification, data) { # of selected contexts. NULL input is preserved as NULL ("all contexts"). # ----------------------------------------------------------------------------- -# @noRd # --- parseContexts helpers -------------------------------------------------- -# Vector form: apply uniformly to every study, filtering to availability. +# Vector form: apply uniformly to every study, filtering to availability. A +# context no study has is a mistake rather than a gap -- with one study it +# is the only way to name a missing context -- so that is an error; one that +# only some studies lack is dropped for those, with a warning. .parseContextsVec <- function(contexts, studies, data) { if (length(contexts) == 0L) { msg <- glue( @@ -383,6 +385,12 @@ parseJointSpecification <- function(jointSpecification, data) { ) abort(msg) } + unknown <- setdiff(contexts, .spListContexts(data)) + if (length(unknown) > 0L) { + unknownStr <- str_flatten(unknown, ", ") + msg <- glue("`contexts` names context(s) no study has: {unknownStr}") + abort(msg) + } set_names( map(studies, .parseContextsAvail, data = data, contexts = contexts), studies @@ -454,6 +462,7 @@ parseJointSpecification <- function(jointSpecification, data) { ) } +# @noRd parseContexts <- function(contexts, data) { if (is.null(contexts)) { return(NULL) @@ -482,7 +491,6 @@ parseContexts <- function(contexts, data) { # available traits). Validates IDs against `.spListTraits` lookups. # ----------------------------------------------------------------------------- -# @noRd # --- parseTraitIds helpers -------------------------------------------------- # Validate a per-(study, context) trait vector against the data. @@ -561,6 +569,7 @@ parseContexts <- function(contexts, data) { abort(msg) } +# @noRd parseTraitIds <- function(traitId, data) { if (is.null(traitId)) { return(NULL) @@ -614,379 +623,100 @@ parseTraitIds <- function(traitId, data) { } # ----------------------------------------------------------------------------- -# parseMethods -- normalize and validate the `methods` argument with optional -# `sumStatsMethods` / `qtlDatasetMethods` overrides. Validates: -# * mutual exclusivity (methods XOR split-by-data-form) -# * nested list structure (vector OR named list at each level; never both) -# * method names against the capability table -# * multi-axis methods may NOT appear at per-context or per-trait levels -# * mr.mash and mvsusie pipeline scope -# -# `caps` is the capability table for the pipeline (see -# `.fineMappingMethodCapabilities` and `.twasMethodCapabilities`). -# `multivariateMethods` is the subset of tokens whose `multivariate = TRUE`; -# used for per-context / per-trait placement rejection. -# `rejectedAtUser` is a character vector of tokens forbidden as user-requested -# methods on this pipeline (e.g. "mrmash" in fineMapping, "mvsusie" in twas). -# -# Returns a list with components: -# methods (NULL if not given) -# sumStatsMethods (NULL if not given) -# qtlDatasetMethods (NULL if not given) -# shape "primary" if `methods` was given, "split" otherwise +# Reading a parsed selection. The pipelines normalize `contexts` / `traitId` +# once, at entry, with parseContexts() / parseTraitIds(); these answer "what +# does it select here?" for one study, context or row. A study or context the +# selection does not mention keeps everything it has. # ----------------------------------------------------------------------------- -# Walk a (possibly nested) methods spec and return the depth at which leaf -# vectors live: 1 = top-level vector, 2 = per-study, 3 = per-(study,context), -# 4 = per-(study,context,trait). Returns a tibble-like list of (path, vec). -# `levelNames` is c("study", "context", "trait"); the leaf level is where -# the vector lives. -# @noRd -# Validate a named-list method node before recursing into it. -.spWalkValidate <- function(spec, label, depth, maxDepth) { - if (!is.list(spec)) { - cls <- class(spec)[[1L]] - msg <- glue( - "{label}: every node must be a character vector or a named ", - "list (got class '{cls}')" - ) - abort(msg) - } - if (depth >= maxDepth) { - msg <- glue( - "{label}: cannot nest below the trait level (depth ", - "{maxDepth} is the deepest a vector may appear at)." - ) - abort(msg) - } - specNm <- names(spec) - if (is.null(specNm) || any(str_length(specNm) == 0L, na.rm = TRUE)) { - d <- depth + 1L - msg <- glue( - "{label}: named-list nodes must have non-empty names at ", - "depth {d}" - ) - abort(msg) - } - if (length(spec) == 0L) { - d <- depth + 1L - msg <- glue("{label}: empty named list at depth {d}") - abort(msg) - } -} - -.spWalkMethods <- function( - spec, - label = "methods", - depth = 0L, - maxDepth = 3L, - path = character(0) -) { - if (is.character(spec)) { - return(list(list(depth = depth, path = path, methods = unique(spec)))) - } - .spWalkValidate(spec, label, depth, maxDepth) - out <- .spConcat(map( - names(spec), - .spWalkMethodsAt, - spec = spec, - label = label, - depth = depth, - maxDepth = maxDepth, - path = path - )) - out -} - -# Walk one named branch of a methods spec. +# The contexts selected for study `s` (possibly none), or NULL for all. # @noRd -.spWalkMethodsAt <- function(nm, spec, label, depth, maxDepth, path) { - .spWalkMethods( - spec[[nm]], - label = label, - depth = depth + 1L, - maxDepth = maxDepth, - path = c(path, nm) - ) +.selectedContexts <- function(contexts, s) { + if (is.null(contexts)) NULL else contexts[[s]] } -# Validate one leaf method vector: non-empty character, all tokens known (in -# `caps`), and none in `rejectedAtUser`. +# The traits selected for study `s` in context `cx`, or NULL for all. # @noRd -.jointValidateLeafVec <- function(vec, label, caps, rejectedAtUser) { - if (!is.character(vec) || length(vec) == 0L) { - msg <- glue( - "{label}: method vector must be a non-empty character vector" - ) - abort(msg) - } - bad <- setdiff(vec, names(caps)) - if (length(bad) > 0L) { - badStr <- str_flatten(bad, ", ") - knownStr <- str_flatten(names(caps), ", ") - msg <- glue( - "{label}: unknown method token(s): {badStr}. ", - "Known tokens: {knownStr}" - ) - abort(msg) - } - rejected <- intersect(vec, rejectedAtUser) - if (length(rejected) > 0L) { - rejectedStr <- str_flatten(rejected, ", ") - msg <- glue( - "{label}: method(s) cannot be user-requested on this ", - "pipeline: {rejectedStr}" - ) - abort(msg) +.selectedTraits <- function(traitId, s, cx) { + if (!is.list(traitId)) { + return(traitId) } - invisible(NULL) + entry <- traitId[[s]] + if (is.list(entry)) entry[[cx]] else entry } +# TRUE when trait `tid` is selected for study `s` in context `cx`. # @noRd -# --- parseMethods helpers --------------------------------------------------- - -# Validate mutual exclusivity of primary vs split method specs. -#' @importFrom checkmate assertCharacter -.parseMethodsValidateArgs <- function( - primaryGiven, - splitGiven, - sumStatsMethods, - qtlDatasetMethods -) { - if (primaryGiven && splitGiven) { - msg <- glue( - "Use either `methods` or (`sumStatsMethods` + ", - "`qtlDatasetMethods`), not both." - ) - abort(msg) - } - if (!primaryGiven && !splitGiven) { - msg <- glue( - "Specify `methods`, or both `sumStatsMethods` and ", - "`qtlDatasetMethods`." - ) - abort(msg) - } - if (splitGiven) { - if (is.null(sumStatsMethods) || is.null(qtlDatasetMethods)) { - msg <- glue( - "`sumStatsMethods` and `qtlDatasetMethods` must be given ", - "together." - ) - abort(msg) - } - assertCharacter(sumStatsMethods, min.len = 1L) - assertCharacter(qtlDatasetMethods, min.len = 1L) - } -} - -# Multi-axis methods may not appear below the per-study level. -.parseMethodsCheckMultiAxis <- function(leaf, lab, multivariateMethods) { - if (leaf$depth < 2L) { - return(invisible(NULL)) - } - bad <- intersect(leaf$methods, multivariateMethods) - if (length(bad) > 0L) { - badStr <- str_flatten(bad, ", ") - levelName <- c("per-study", "per-context", "per-trait")[[leaf$depth]] - msg <- glue( - "{lab}: multi-axis method(s) {badStr} cannot be assigned at ", - "the {levelName} level (multi-axis methods operate across ", - "axes)." - ) - abort(msg) - } +.traitSelectedAt <- function(tid, traitId, s, cx) { + sel <- .selectedTraits(traitId, s, cx) + is.null(sel) || is_in(tid, sel) } -# Study/context/trait keys of a method leaf must reference valid entities. -.parseMethodsCheckPath <- function(leaf, lab, data, studyNames) { - # The path is (study, context, trait); each level is only checked once the - # leaf is deep enough to name it -- a shallower leaf has no such entry to - # read, so the depth guard has to come before the extraction. - if (leaf$depth < 1L) { - return(invisible(NULL)) - } - s <- leaf$path[[1L]] - if (!is_in(s, studyNames)) { - msg <- glue("{lab}: unknown study '{s}'") - abort(msg) - } - if (leaf$depth < 2L) { - return(invisible(NULL)) - } - cx <- leaf$path[[2L]] - if (!is_in(cx, .spListContexts(data, s))) { - msg <- glue("{lab}: unknown context '{cx}' for study '{s}'") - abort(msg) - } - if (leaf$depth < 3L) { - return(invisible(NULL)) +# The traits study `s` takes part with across `studyContexts`, the contexts in +# play for it -- what a fit spanning those contexts draws on: the union of +# their selections, or NULL when any of them keeps all of its traits. +# @noRd +.selectedStudyTraits <- function(traitId, s, studyContexts) { + entry <- if (is.list(traitId)) traitId[[s]] else traitId + if (!is.list(entry)) { + return(entry) } - tr <- leaf$path[[3L]] - if (!is_in(tr, .spListTraits(data, studyName = s, context = cx))) { - msg <- glue( - "{lab}: unknown trait '{tr}' for (study '{s}', ", - "context '{cx}')" - ) - abort(msg) + if (!all(is_in(studyContexts, names(entry)))) { + return(NULL) } + unique(as.character(list_c(unname(entry[studyContexts])))) } -# Validate one method leaf (leaf vector + multi-axis + path references). -.parseMethodsCheckLeaf <- function( - leaf, - data, - caps, - multivariateMethods, - rejectedAtUser, - studyNames -) { - lab <- if (length(leaf$path) == 0L) { - "methods" - } else { - pathStr <- str_flatten(str_c("'", leaf$path, "'"), "$") - glue("methods[[{pathStr}]]") - } - .jointValidateLeafVec(leaf$methods, lab, caps, rejectedAtUser) - .parseMethodsCheckMultiAxis(leaf, lab, multivariateMethods) - .parseMethodsCheckPath(leaf, lab, data, studyNames) +# TRUE when some study's traits are chosen context by context. Only then can +# a (context, trait) pair inside a study's selected traits still be left out. +# @noRd +.hasNestedTraitSelection <- function(traitId) { + is.list(traitId) && any(map_lgl(traitId, is.list)) } -# Walk a primary `methods` tree and validate every leaf. -.parseMethodsWalked <- function( - methods, - data, - caps, - multivariateMethods, - rejectedAtUser -) { - walked <- .spWalkMethods(methods, label = "methods", maxDepth = 3L) - studyNames <- .spListStudies(data) - for (leaf in walked) { - .parseMethodsCheckLeaf( - leaf, - data, - caps, - multivariateMethods, - rejectedAtUser, - studyNames - ) - } +# Which rows of a summary-statistics collection the parsed `contexts` / +# `traitId` selection keeps. +# @noRd +.sumStatsRowsSelected <- function(data, contexts, traitId) { + map_lgl( + seq_len(nrow(data)), + .sumStatsRowSelectedAt, + studyCol = as.character(data$study), + contextCol = as.character(data$context), + traitCol = as.character(data$trait), + contexts = contexts, + traitId = traitId + ) } -parseMethods <- function( - methods, - sumStatsMethods = NULL, - qtlDatasetMethods = NULL, - data, - caps, - multivariateMethods, - rejectedAtUser = character(0) +# Whether the selection keeps row `i`. +# @noRd +.sumStatsRowSelectedAt <- function( + i, + studyCol, + contextCol, + traitCol, + contexts, + traitId ) { - primaryGiven <- !is.null(methods) - splitGiven <- !is.null(sumStatsMethods) || !is.null(qtlDatasetMethods) - .parseMethodsValidateArgs( - primaryGiven, - splitGiven, - sumStatsMethods, - qtlDatasetMethods - ) - if (splitGiven) { - .jointValidateLeafVec( - sumStatsMethods, - "sumStatsMethods", - caps, - rejectedAtUser - ) - .jointValidateLeafVec( - qtlDatasetMethods, - "qtlDatasetMethods", - caps, - rejectedAtUser - ) - } else { - .parseMethodsWalked( - methods, - data, - caps, - multivariateMethods, - rejectedAtUser - ) - } - list( - methods = methods, - sumStatsMethods = sumStatsMethods, - qtlDatasetMethods = qtlDatasetMethods, - shape = if (primaryGiven) "primary" else "split" - ) + s <- studyCol[[i]] + cx <- contextCol[[i]] + ctxSel <- .selectedContexts(contexts, s) + (is.null(ctxSel) || is_in(cx, ctxSel)) && + .traitSelectedAt(traitCol[[i]], traitId, s, cx) } - -# ----------------------------------------------------------------------------- -# validateMethodsVsJointSpec -- cross-validation. A per-axis method assignment -# at or below the axis being jointed in any spec contradicts user intent. -# E.g. axes = "context" + per-context methods = contradiction. Joint flags -# operate on axes that haven't been pinned to per-axis methods. -# -# The rule: for each jointSpec, every axis in `axes` must NOT be a level at -# which the methods list nests. Concretely: -# - "study" in axes -> methods must not be a named list keyed by study -# (i.e. methods must be a top-level vector OR the -# split form). Per-study methods would mean different -# methods per study, incompatible with cross-study -# joints. -# - "context" in axes -> no per-(study, context) nesting at any study. -# - "trait" in axes -> no per-(study, context, trait) nesting at any -# (study, context). -# ----------------------------------------------------------------------------- - +# Study `s`'s share of a parsed `traitId`, in a form the single-study entry +# point parses back to the same selection: unchanged when it is one vector +# for every study, else that study's entry, keyed by the study when it is +# chosen context by context. NULL when the study keeps all of its traits. # @noRd -validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { - # Split-form methods are flat per-data-form vectors -- nothing to check. - if (methodsParsed$shape == "split") { - return(invisible(NULL)) - } - if (length(jointSpecParsed) == 0L) { - return(invisible(NULL)) - } - methods <- methodsParsed$methods - if (is.character(methods)) { - return(invisible(NULL)) - } # top-level vector OK - - walked <- .spWalkMethods(methods, label = "methods", maxDepth = 3L) - # depth observed at leaves; max depth in the spec reflects nesting level. - maxDepth <- max(map_int(walked, "depth")) - - for (i in seq_along(jointSpecParsed)) { - axes <- jointSpecParsed[[i]]$axes - lab <- glue("jointSpecification[[{i}]]") - if (is_in("study", axes) && maxDepth >= 1L) { - msg <- glue( - "{lab}: `axes` includes 'study' but `methods` nests ", - "per-study; remove per-study method assignment when ", - "joining over studies." - ) - abort(msg) - } - if (is_in("context", axes) && maxDepth >= 2L) { - msg <- glue( - "{lab}: `axes` includes 'context' but `methods` nests ", - "per-context; remove per-context method assignment when ", - "joining over contexts." - ) - abort(msg) - } - if (is_in("trait", axes) && maxDepth >= 3L) { - msg <- glue( - "{lab}: `axes` includes 'trait' but `methods` nests ", - "per-trait; remove per-trait method assignment when ", - "joining over traits." - ) - abort(msg) - } +.studyTraitIdArg <- function(traitId, s) { + if (!is.list(traitId)) { + return(traitId) } - invisible(NULL) + entry <- traitId[[s]] + if (is.list(entry)) set_names(list(entry), s) else entry } # ============================================================================= @@ -1019,7 +749,6 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { avail = .spListContexts, scopeLimit = scope$context, userSpec = contexts, - requireCharacter = FALSE, data = data ), studies @@ -1027,16 +756,23 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { traitsOut <- set_names( map( studies, - .fmScopeAxis, - avail = .fmScopeTraits, + .fmScopeStudyTraits, scopeLimit = scope$trait, - userSpec = traitIds, - requireCharacter = TRUE, + traitIds = traitIds, + contextsOut = contextsOut, data = data ), studies ) - list(studies = studies, contexts = contextsOut, traits = traitsOut) + # A joint fit spans a study's contexts, so its traits are the union of + # the per-context selections; when the selection is per context, the + # cell runner then drops each (context, trait) pair it leaves out. + list( + studies = studies, + contexts = contextsOut, + traits = traitsOut, + traitSelection = if (.hasNestedTraitSelection(traitIds)) traitIds + ) } # `.spListTraits` takes the study by name, so give it the same (data, s) @@ -1046,41 +782,32 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { .spListTraits(data, studyName = s) } -# What a pipeline-level `contexts` / `traitIds` argument narrows study `s` to, -# or NULL when it says nothing about it. `requireCharacter` mirrors the trait -# axis, which ignores a non-character per-study entry. +# What a pipeline-level `contexts` argument narrows study `s` to, or NULL when +# it says nothing about it: one vector for every study, or parseContexts()'s +# per-study list. # @noRd -.fmScopeUserLimit <- function(spec, s, requireCharacter) { - if (is.null(spec)) { - return(NULL) - } - if (is.character(spec)) { - return(spec) - } - if (!is.list(spec) || !is_in(s, names(spec))) { - return(NULL) - } - entry <- spec[[s]] - if (!requireCharacter || is.character(entry)) entry else NULL +.fmScopeUserLimit <- function(spec, s) { + if (is.list(spec)) .selectedContexts(spec, s) else spec } # One axis for one study: everything it has, narrowed by the spec's scope and # then by the caller's argument. Each narrowing is an intersect, so the chain # is a fold rather than a variable rewritten in place. # @noRd -.fmScopeAxis <- function( - s, - avail, - scopeLimit, - userSpec, - requireCharacter, - data -) { +.fmScopeAxis <- function(s, avail, scopeLimit, userSpec, data) { + limits <- compact(list(scopeLimit, .fmScopeUserLimit(userSpec, s))) + reduce(limits, intersect, .init = avail(data, s)) +} + +# Study `s`'s traits: everything it has, narrowed by the spec's scope and by +# the caller's `traitId` over the contexts in play for it. +# @noRd +.fmScopeStudyTraits <- function(s, scopeLimit, traitIds, contextsOut, data) { limits <- compact(list( scopeLimit, - .fmScopeUserLimit(userSpec, s, requireCharacter) + .selectedStudyTraits(traitIds, s, contextsOut[[s]]) )) - reduce(limits, intersect, .init = avail(data, s)) + reduce(limits, intersect, .init = .fmScopeTraits(data, s)) } @@ -1094,7 +821,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { tupleRows, colLabels, errorLabel, - ldSketch = NULL, + ldReference = NULL, cutoffs = NULL ) { cols <- list( @@ -1113,7 +840,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # entry's ids filters the group: Z is built against this vector and each # entry is checked against it. firstDf <- allDf[ - .panelKeepMask(allDf$variant_id, ldSketch, cutoffs, errorLabel), + .panelKeepMask(allDf$variant_id, ldReference, cutoffs, errorLabel), , drop = FALSE ] @@ -1196,20 +923,16 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } -# Build a multi-context Y matrix for a single (study, trait) from an -# individual-level QtlDataset. Returns list(X, Y, perTraitContexts) or -# NULL when fewer than 2 contexts carry `tid` or the sample / complete-Y -# subset is too small to fit. -# @noRd # --- .buildIndividualCrossContextXy helpers --------------------------------- -# Scoped contexts in which a trait is present; NULL if fewer than 2. # Does context `cx` carry trait `tid`? # @noRd .ccContextHasTrait <- function(cx, data, tid) { is_in(tid, rownames(molecularTraits(data, contexts = cx))) } +# Scoped contexts in which a trait is present; NULL if fewer than 2. +# @noRd .crossContextPerTrait <- function(data, tid, scopedContexts, verbose, label) { perTraitContexts <- keep( scopedContexts, @@ -1283,6 +1006,11 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { ) } +# Build a multi-context Y matrix for a single (study, trait) from an +# individual-level QtlDataset. Returns list(X, Y, perTraitContexts) or +# NULL when fewer than 2 contexts carry `tid` or the sample / complete-Y +# subset is too small to fit. +# @noRd .buildIndividualCrossContextXy <- function( data, tid, @@ -1291,7 +1019,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { verbose, label, region = NULL, - residualizationArgs + residualizationParam ) { perTraitContexts <- .crossContextPerTrait( data, @@ -1309,13 +1037,13 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { tid, cisWindow, region, - residualizationArgs + residualizationParam ) Yres <- .fmResidPheno( data, contexts = perTraitContexts, traitId = tid, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ) .crossContextAssemble(X, Yres, perTraitContexts, verbose, label, tid) } @@ -1335,12 +1063,8 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { traits[IRanges::overlapsAny(rr[traits], region)] } -# Build a multi-trait Y matrix for a single (study, context) from an -# individual-level QtlDataset. Returns list(X, Y, traitsHere, se) or NULL -# when fewer than 2 traits live in the context or the sample / complete-Y -# subset is too small. -# @noRd # Warn + signal skip when a context has fewer than 2 scoped traits. +# @noRd .crossTraitTooFew <- function(traitsHere, cx, studyName, verbose, label) { if (length(traitsHere) >= 2L) { return(FALSE) @@ -1356,6 +1080,11 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { TRUE } +# Build a multi-trait Y matrix for a single (study, context) from an +# individual-level QtlDataset. Returns list(X, Y, traitsHere, se) or NULL +# when fewer than 2 traits live in the context or the sample / complete-Y +# subset is too small. +# @noRd .buildIndividualCrossTraitXy <- function( data, cx, @@ -1365,7 +1094,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { label, studyName, region = NULL, - residualizationArgs + residualizationParam ) { se <- molecularTraits(data, contexts = cx) # scopedTraits is already region-restricted upstream (.runJointSpecs) when @@ -1380,13 +1109,13 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { traitsHere, cisWindow, region, - residualizationArgs + residualizationParam ) allY <- .fmResidPheno( data, contexts = cx, traitId = traitsHere, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ) common <- intersect(rownames(allX), rownames(allY)) if (length(common) < 2L) { @@ -1407,18 +1136,16 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } -# Build a composed-axes (context, trait) X/Y for individual-level -# QtlDataset. Returns list(X, Y, tuples) or NULL. -# @noRd # Residualized genotype for the cross-* / composed builders (cis-window or an # explicit region). Shared by the individual multi-axis Xy builders. +# @noRd .buildResidGeno <- function( data, contexts, traitId, cisWindow, region, - residualizationArgs + residualizationParam ) { if (is.null(region)) { .fmResidGeno( @@ -1426,14 +1153,14 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts = contexts, traitId = traitId, cisWindow = cisWindow, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ) } else { .fmResidGeno( data, contexts = contexts, region = region, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ) } } @@ -1515,7 +1242,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { allTraits, cisWindow, region, - residualizationArgs + residualizationParam ) { # Genotypes first, as the inline version did: reading them is what # fails on a missing panel file, and that error must stay the one the @@ -1526,13 +1253,13 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { allTraits, cisWindow, region, - residualizationArgs + residualizationParam ) resid <- .fmResidPheno( data, contexts = allContexts, traitId = allTraits, - residualizationArgs = residualizationArgs + residualizationParam = residualizationParam ) list( X = allX, @@ -1545,6 +1272,9 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { ) } +# Build a composed-axes (context, trait) X/Y for individual-level +# QtlDataset. Returns list(X, Y, tuples) or NULL. +# @noRd .buildComposedIndividualXy <- function( data, scope, @@ -1553,7 +1283,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { verbose, label, region = NULL, - residualizationArgs + residualizationParam ) { tuples <- .composedTuples(data, scope, studyName, verbose, label) if (is.null(tuples)) { @@ -1567,7 +1297,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { allTraits, cisWindow, region, - residualizationArgs + residualizationParam ) allX <- sides$X YresList <- sides$YresList @@ -1662,8 +1392,6 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { ) } -# Top-level joint dispatcher for fineMappingPipeline(QtlDataset). -# @noRd # Merge per-region QtlFineMappingResult collections (same keys across regions) # into one by merging each (study, context, trait, method) row's entry via # .fmMergeEntries (per-region susieFit list + renumbered credible sets). @@ -1690,7 +1418,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { entry = mergedEntries ), .jointCols(base), - list(ldSketch = NULL) + list(ldReference = NULL) ) exec(QtlFineMappingResult, !!!qfmrArgs) } @@ -1726,22 +1454,12 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { ) } -# Shared tail of the MultiStudyQtlDataset fineMapping / twasWeights pipeline -# methods: recurse into each embedded QtlDataset then the embedded QtlSumStats, -# row-bind the per-study results, build the per-tuple result object, and combine -# it with any joint-specification result. `perStudyFn` / `sumStatsFn` are the -# (method-specific) single-study recursions; `rbindFn` / `resultCtor` / -# `pipelineName` supply the per-pipeline pieces. Each method keeps its own -# (divergent) method-gating / joint-dispatch preamble and passes the computed -# `jointResult` in. -# @noRd # --- .multiStudyPipelineDriver helpers -------------------------------------- -# Accumulate per-study + sumstats results (tracking the embedded LD sketch). # rbind two results with no LD sketch -- the per-study combine. # @noRd .msRbindNoLd <- function(acc, x, rbindFn) { - rbindFn(acc, x, ldSketch = NULL) + rbindFn(acc, x, ldReference = NULL) } # Fold per-study results together, skipping studies that produced nothing. @@ -1755,6 +1473,8 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { reduce(kept, .msRbindNoLd, rbindFn = rbindFn) } +# Accumulate per-study + sumstats results (tracking the embedded LD sketch). +# @noRd .msDriverAccumulate <- function( qtlDatasets, sumStats, @@ -1771,19 +1491,19 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { if (is.null(ssRes)) { return(list(out = fromStudies, embeddedLd = NULL)) } - embeddedLd <- ldSketch(ssRes) + embeddedLd <- ldReference(ssRes) out <- if (is.null(fromStudies)) { ssRes } else { - rbindFn(fromStudies, ssRes, ldSketch = embeddedLd) + rbindFn(fromStudies, ssRes, ldReference = embeddedLd) } list(out = out, embeddedLd = embeddedLd) } # Reconstruct the per-tuple result object from the accumulated rows. .msDriverPerTuple <- function(out, resultCtor, embeddedLd) { - # ldSketch: NULL if all studies were individual-level; the embedded - # sumStats's ldSketch otherwise. + # ldReference: NULL if all studies were individual-level; the embedded + # sumStats's ldReference otherwise. ctorArgs <- c( list( study = as.character(out$study), @@ -1793,11 +1513,20 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { entry = .collectionEntries(out) ), .jointCols(out), - list(ldSketch = embeddedLd) + list(ldReference = embeddedLd) ) exec(resultCtor, !!!ctorArgs) } +# Shared tail of the MultiStudyQtlDataset fineMapping / twasWeights pipeline +# methods: recurse into each embedded QtlDataset then the embedded QtlSumStats, +# row-bind the per-study results, build the per-tuple result object, and combine +# it with any joint-specification result. `perStudyFn` / `sumStatsFn` are the +# (method-specific) single-study recursions; `rbindFn` / `resultCtor` / +# `pipelineName` supply the per-pipeline pieces. Each method keeps its own +# (divergent) method-gating / joint-dispatch preamble and passes the computed +# `jointResult` in. +# @noRd .multiStudyPipelineDriver <- function( data, jointResult, @@ -1837,7 +1566,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { if (is.null(perTupleResult)) { return(jointResult) } - rbindFn(perTupleResult, jointResult, ldSketch = embeddedLd) + rbindFn(perTupleResult, jointResult, ldReference = embeddedLd) } # Synthesize a jointSpecification for the AUTO-DETECTION path (no explicit @@ -1859,366 +1588,201 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { list() } } - - +# ---- fine-mapping joint dispatch -------------------------------------------- +# +# Every fine-mapping joint dispatch hands the engine a pipeline config and an +# `args` list built from ONE record: the pipeline's own joint record +# (.fmIndividualJointCfg() / .fmQssConfigs()), or, for a component of a +# MultiStudyQtlDataset, that record with the component's data in it. +# Re-listing the settings at each dispatch layer is how they went missing -- +# the per-study dispatch dropped cross-validation, residualization, the +# screen, fitRetention and the seed, and passed the rest positionally into +# the wrong slots. + +# Run joint specs on a QtlDataset, once per region block, merging per (study, +# context, trait, method) across the blocks. A study axis has no meaning on +# individual-level data, and rejecting it up front keeps the error ahead of +# the fit. +# @noRd .fmDispatchJointSpecsQtlDataset <- function( parsedJointSpec, - data, - methods, - contexts, - traitIds, - cisWindow, - credibleSetParam = CredibleSetParam(includeAllCs = FALSE), - verbose, - methodArgs = list(), - xRegions = list(NULL), - mrmashPrior = NULL, - dataDrivenPriorWeightsCutoff = 1e-10, - crossValidationArgs = CrossValidationParam(), - residualizationArgs = ResidualizationParam(), - pipCutoffToSkip = 0, - fineMappingResult = NULL, - fitRetention = c("slim", "none", "full"), - seed = NULL + tokens, + methodArgs, + cfg ) { - fitRetention <- arg_match(fitRetention) - # Run the joint dispatch once per region block, then merge per - # (study, context, trait, method) across regions. A single block (cis or - # jointRegions=TRUE concatenated) returns its result directly. - # xRegions is deliberately absent: each region is supplied per call. - perRegion <- map( - xRegions, + .jointRejectStudyOnIndividual(parsedJointSpec) + perRegion <- compact(map( + cfg$xRegions, .fmDispatchJointSpecRegion, parsedJointSpec = parsedJointSpec, - data = data, - methods = methods, - contexts = contexts, - traitIds = traitIds, - cisWindow = cisWindow, - credibleSetParam = credibleSetParam, - verbose = verbose, + tokens = tokens, methodArgs = methodArgs, - mrmashPrior = mrmashPrior, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, - crossValidationArgs = crossValidationArgs, - residualizationArgs = residualizationArgs, - pipCutoffToSkip = pipCutoffToSkip, - fineMappingResult = fineMappingResult, - fitRetention = fitRetention, - seed = seed - ) |> - compact() + cfg = cfg + )) .fmCombineRegionResults(perRegion) } -# Merge the per-region joint results by (study, context, trait, method). A -# single block -- cis, or jointRegions = TRUE concatenated -- is returned -# directly rather than merged with itself. +# One region block of .fmDispatchJointSpecsQtlDataset(). # @noRd -.fmCombineRegionResults <- function(perRegion) { - if (length(perRegion) == 0L) { - return(NULL) - } - if (length(perRegion) == 1L) { - return(perRegion[[1L]]) - } - .fmMergeResultsByKey(perRegion) +.fmDispatchJointSpecRegion <- function( + region, + parsedJointSpec, + tokens, + methodArgs, + cfg +) { + .runJointSpecs( + parsedJointSpec, + cfg$data, + dataForm = "individual", + pipeline = .fmJointPipeline(cfg, cfg$crossValidationParam, NULL), + jointMethods = intersect(tokens, c("mvsusie", "fsusie")), + contexts = cfg$contexts, + traitIds = cfg$traitId, + args = .fmJointIndividualArgs(cfg, methodArgs, region) + ) } -# FmJointPipeline for individual-level fine-mapping, built from the call params. -.fmJointPipeline <- function( - credibleSetParam = CredibleSetParam(includeAllCs = FALSE), - dataDrivenPriorWeightsCutoff, - crossValidationArgs, - residualizationArgs, - verbose, - fitRetention = c("slim", "none", "full"), - seed -) { - fitRetention <- arg_match(fitRetention) +# The FmJointPipeline a joint run fits under: the settings the fitters read +# off the pipeline. Summary statistics pass the no-CV record (there are no +# samples to hold out) and the collection's LD sketch; individual-level data +# pass the caller's resolved CV record and no sketch. +# @noRd +.fmJointPipeline <- function(cfg, crossValidationParam, ldReference) { new( "FmJointPipeline", config = list( - credibleSetParam = credibleSetParam, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, - crossValidationArgs = crossValidationArgs, - residualizationArgs = residualizationArgs, - verbose = verbose, - fitRetention = fitRetention, - seed = seed, - ldSketch = NULL + credibleSetParam = cfg$credibleSetParam, + dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff, + crossValidationParam = crossValidationParam, + verbose = cfg$verbose, + fitRetention = cfg$fitRetention, + seed = cfg$seed, + ldReference = ldReference ) ) } -# The joint pipeline record, once the spec has been checked against the -# individual-level form -- a study axis has no meaning there, and building -# a pipeline for a spec that names one would defer the error past the fit. +# The engine `args` of an individual-level joint run over one region block. +# Residualization rides here rather than on the pipeline config: the group +# enumerators read it while extracting X and Y. # @noRd -.fmJointPipelineChecked <- function( - parsedJointSpec, - credibleSetParam, - dataDrivenPriorWeightsCutoff, - crossValidationArgs, - residualizationArgs, - verbose, - fitRetention, - seed -) { - .jointRejectStudyOnIndividual(parsedJointSpec) - .fmJointPipeline( - credibleSetParam = credibleSetParam, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, - crossValidationArgs = crossValidationArgs, - residualizationArgs = residualizationArgs, - verbose = verbose, - fitRetention = fitRetention, - seed = seed - ) -} - -# Engine routing (jointEngine.R) for one region block; the caller loops the -# regions. -# @noRd -.fmDispatchJointSpecsQtlDatasetOneRegion <- function( - parsedJointSpec, - data, - methods, - contexts, - traitIds, - cisWindow, - verbose, - methodArgs = list(), - region = NULL, - mrmashPrior = NULL, - dataDrivenPriorWeightsCutoff = 1e-10, - crossValidationArgs = CrossValidationParam(), - residualizationArgs = ResidualizationParam(), - pipCutoffToSkip = 0, - fineMappingResult = NULL, - seed = NULL, - credibleSetParam, - fitRetention -) { - pipeline <- .fmJointPipelineChecked( - parsedJointSpec, - credibleSetParam = credibleSetParam, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, - crossValidationArgs = crossValidationArgs, - residualizationArgs = residualizationArgs, - verbose = verbose, - fitRetention = fitRetention, - seed = seed - ) - .runJointSpecs( - parsedJointSpec, - data, - dataForm = "individual", - pipeline = pipeline, - jointMethods = intersect(methods, c("mvsusie", "fsusie")), - contexts = contexts, - traitIds = traitIds, - args = list( - mrmashPrior = mrmashPrior, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, - methodArgs = methodArgs, - cisWindow = cisWindow, - region = region, - verbose = verbose, - pipCutoffToSkip = pipCutoffToSkip, - cache = fineMappingResult - ) +.fmJointIndividualArgs <- function(cfg, methodArgs, region) { + list( + mrmashPrior = cfg$mrmashPrior, + dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff, + methodArgs = methodArgs, + cisWindow = cfg$cisWindow, + region = region, + verbose = cfg$verbose, + pipCutoffToSkip = cfg$screen, + cache = cfg$fineMappingResult, + residualizationParam = cfg$residualizationParam ) } - -# Top-level joint dispatcher for fineMappingPipeline(QtlSumStats). +# Run joint specs on a QtlSumStats collection. `cfg` is the summary-statistics +# joint record (.fmQssConfigs()$joint), or a MultiStudy record with the +# collection as its data. # @noRd -# FmJointPipeline for summary-statistics fine-mapping (RSS: no sample folds; -# LD sketch drawn from the data). -.fmSumStatsPipeline <- function( - data, - credibleSetParam, - dataDrivenPriorWeightsCutoff, - verbose, - fitRetention -) { - new( - "FmJointPipeline", - config = list( - credibleSetParam = credibleSetParam, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, - verbose = verbose, - fitRetention = fitRetention, - crossValidationArgs = .cvResolve(CrossValidationParam()), - ldSketch = ldSketch(data) - ) - ) -} - .fmDispatchJointSpecsQtlSumStats <- function( parsedJointSpec, - data, - methods, - contexts, - traitIds, - verbose, - methodArgs = list(), - mrmashPrior = NULL, - dataDrivenPriorWeightsCutoff = 1e-10, - fineMappingResult = NULL, - panelFilterParam = PanelFilterParam(), - credibleSetParam, - fitRetention + tokens, + methodArgs, + cfg ) { - # Engine routing (jointEngine.R): the dispatch table + .runJointCell replace - # the per-axis switch + the cross-context/trait/study/composed leaf - # dispatchers. - pipeline <- .fmSumStatsPipeline( - data = data, - credibleSetParam = credibleSetParam, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, - verbose = verbose, - fitRetention = fitRetention - ) .runJointSpecs( parsedJointSpec, - data, + cfg$data, dataForm = "sumstats", - pipeline = pipeline, - jointMethods = intersect(methods, c("mvsusie", "fsusie")), - contexts = contexts, - traitIds = traitIds, + pipeline = .fmJointPipeline( + cfg, + .cvResolve(CrossValidationParam()), + ldReference(cfg$data) + ), + jointMethods = intersect(tokens, c("mvsusie", "fsusie")), + contexts = cfg$contexts, + traitIds = cfg$traitId, args = list( - mrmashPrior = mrmashPrior, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + mrmashPrior = cfg$mrmashPrior, + dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff, methodArgs = methodArgs, - verbose = verbose, - cache = fineMappingResult, - cutoffs = .panelCutoffs(panelFilterParam) + verbose = cfg$verbose, + cache = cfg$fineMappingResult, + cutoffs = .panelCutoffs( + cfg$panelFilterParam %||% PanelFilterParam() + ) ) ) } - -# Top-level joint dispatcher for fineMappingPipeline(MultiStudyQtlDataset). -# Routes per-component AND per-axis: a spec with `axes = "study"` only -# touches the sumStats slot; `axes = "context"` and `axes = "trait"` run -# on every component. +# Joint dispatch for a MultiStudyQtlDataset. Per component AND per axis: a +# spec with a `study` axis only touches the summary statistics, while the +# other specs run on every individual-level component -- each under the same +# settings, with the component's own data (its genotype-filter overrides +# applied, as the per-study recursion applies them) -- and on the summary +# statistics too. `cfg` is the individual-level joint record plus +# `genotypeFilterParam` and `panelFilterParam`, with the collection as data. # @noRd -# --- .fmDispatchJointSpecsMultiStudy helpers -------------------------------- - -# Partition joint specs into those with a `study` axis and the rest. -.fmSplitStudyAxisSpecs <- function(parsedJointSpec) { - hasStudy <- map_lgl(parsedJointSpec, .jsHasStudyAxis) - list( - study = parsedJointSpec[hasStudy], - nonStudy = parsedJointSpec[!hasStudy] - ) -} - -# Note that individual-level studies are excluded from cross-study fits. -.fmMultiStudyWarnExcluded <- function(studyAxisSpecs, qtlDatasets, verbose) { - if ( - length(studyAxisSpecs) > 0L && length(qtlDatasets) > 0L && verbose >= 1 - ) { - qdNames <- str_flatten(names(qtlDatasets), ", ") - msg <- glue( - "jointCrossStudy: excluding individual-level studies ", - "({qdNames}) from cross-study fits (no LD sketch available); ", - "sumstats studies participate." - ) - inform(msg) - } -} - -# Fine-map the non-study-axis specs on each individual-level QtlDataset. -.fmMultiStudyQtlLoop <- function( - nonStudyAxisSpecs, - qtlDatasets, - methods, - contexts, - traitIds, - cisWindow, - credibleSetParam, - verbose, +.fmDispatchJointSpecsMultiStudy <- function( + parsedJointSpec, + tokens, methodArgs, - xRegions, - mrmashPrior, - dataDrivenPriorWeightsCutoff + cfg ) { - if (length(nonStudyAxisSpecs) == 0L) { - return(NULL) + qtlDatasets <- qtlDatasets(cfg$data) + specs <- .fmSplitStudyAxisSpecs(parsedJointSpec) + .fmMultiStudyWarnExcluded(specs$study, qtlDatasets, cfg$verbose) + out <- if (length(specs$nonStudy) == 0L) { + NULL + } else { + .msFoldStudyResults( + map( + qtlDatasets, + .fmStudyJointResult, + specs = specs$nonStudy, + tokens = tokens, + methodArgs = methodArgs, + cfg = cfg + ), + .rbindFineMappingResult + ) } - .msFoldStudyResults( - map( - qtlDatasets, - .fmDispatchForStudy, - nonStudyAxisSpecs = nonStudyAxisSpecs, - methods = methods, - contexts = contexts, - traitIds = traitIds, - cisWindow = cisWindow, - credibleSetParam = credibleSetParam, - verbose = verbose, - methodArgs = methodArgs, - xRegions = xRegions, - mrmashPrior = mrmashPrior, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff - ), - .rbindFineMappingResult + .fmMultiStudySumStats( + parsedJointSpec, + specs$study, + out, + tokens, + methodArgs, + cfg ) } -# `map()` hands the dataset first; the dispatcher wants the specs first. +# One individual-level component's joint fits: the shared record with the +# component as its data. # @noRd -.fmDispatchForStudy <- function( - qd, - nonStudyAxisSpecs, - methods, - contexts, - traitIds, - cisWindow, - verbose, - methodArgs, - xRegions, - mrmashPrior, - dataDrivenPriorWeightsCutoff, - credibleSetParam -) { - .fmDispatchJointSpecsQtlDataset( - nonStudyAxisSpecs, - qd, - methods = methods, - contexts = contexts, - traitIds = traitIds, - cisWindow = cisWindow, - credibleSetParam = credibleSetParam, - verbose = verbose, - methodArgs = methodArgs, - xRegions = xRegions, - mrmashPrior = mrmashPrior, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff +.fmStudyJointResult <- function(qd, specs, tokens, methodArgs, cfg) { + studyCfg <- list_assign( + cfg, + data = .qtlApplyFilterOverrides(qd, cfg$genotypeFilterParam) ) + .fmDispatchJointSpecsQtlDataset(specs, tokens, methodArgs, studyCfg) } -# Fine-map all specs on the sumstats collection; rbind onto `out`. +# Fine-map every spec on the summary-statistics component and rbind onto the +# individual-level results `out`. +# @noRd .fmMultiStudySumStats <- function( parsedJointSpec, - sumStats, studyAxisSpecs, out, - methods, - contexts, - traitIds, - verbose, + tokens, methodArgs, - mrmashPrior, - dataDrivenPriorWeightsCutoff, - credibleSetParam + cfg ) { + sumStats <- sumStats(cfg$data) if (is.null(sumStats)) { - if (length(studyAxisSpecs) > 0L && verbose >= 1) { + if (length(studyAxisSpecs) > 0L && cfg$verbose >= 1) { msg <- glue( "jointCrossStudy: no sumStats slot present on this ", "MultiStudyQtlDataset; cross-study specs produce no result." @@ -2229,81 +1793,66 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } ssRes <- .fmDispatchJointSpecsQtlSumStats( parsedJointSpec, - sumStats, - methods = methods, - contexts = contexts, - traitIds = traitIds, - credibleSetParam = credibleSetParam, - verbose = verbose, - methodArgs = methodArgs, - mrmashPrior = mrmashPrior, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + tokens, + methodArgs, + list_assign(cfg, data = sumStats) ) if (is.null(ssRes)) { return(out) } - embeddedLd <- ldSketch(ssRes) if (is.null(out)) { - ssRes - } else { - .rbindFineMappingResult(out, ssRes, ldSketch = embeddedLd) + return(ssRes) } + .rbindFineMappingResult(out, ssRes, ldReference = ldReference(ssRes)) } -.fmDispatchJointSpecsMultiStudy <- function( - parsedJointSpec, - data, - methods, - contexts, - traitIds, - cisWindow, - credibleSetParam, - verbose, - methodArgs = list(), - xRegions = list(NULL), - mrmashPrior = NULL, - dataDrivenPriorWeightsCutoff = 1e-10 -) { - qtlDatasets <- qtlDatasets(data) - sumStats <- sumStats(data) - specs <- .fmSplitStudyAxisSpecs(parsedJointSpec) - .fmMultiStudyWarnExcluded(specs$study, qtlDatasets, verbose) - out <- .fmMultiStudyQtlLoop( - specs$nonStudy, - qtlDatasets, - methods = methods, - contexts = contexts, - traitIds = traitIds, - cisWindow = cisWindow, - credibleSetParam = credibleSetParam, - verbose = verbose, - methodArgs = methodArgs, - xRegions = xRegions, - mrmashPrior = mrmashPrior, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff - ) - .fmMultiStudySumStats( - parsedJointSpec, - sumStats, - specs$study, - out, - methods = methods, - contexts = contexts, - traitIds = traitIds, - verbose = verbose, - methodArgs = methodArgs, - mrmashPrior = mrmashPrior, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + +# Merge the per-region joint results by (study, context, trait, method). A +# single block -- cis, or jointRegions = TRUE concatenated -- is returned +# directly rather than merged with itself. +# @noRd +.fmCombineRegionResults <- function(perRegion) { + if (length(perRegion) == 0L) { + return(NULL) + } + if (length(perRegion) == 1L) { + return(perRegion[[1L]]) + } + .fmMergeResultsByKey(perRegion) +} + + +# --- .fmDispatchJointSpecsMultiStudy helpers -------------------------------- + +# Partition joint specs into those with a `study` axis and the rest. +.fmSplitStudyAxisSpecs <- function(parsedJointSpec) { + hasStudy <- map_lgl(parsedJointSpec, .jsHasStudyAxis) + list( + study = parsedJointSpec[hasStudy], + nonStudy = parsedJointSpec[!hasStudy] ) } +# Note that individual-level studies are excluded from cross-study fits. +.fmMultiStudyWarnExcluded <- function(studyAxisSpecs, qtlDatasets, verbose) { + if ( + length(studyAxisSpecs) > 0L && length(qtlDatasets) > 0L && verbose >= 1 + ) { + qdNames <- str_flatten(names(qtlDatasets), ", ") + msg <- glue( + "jointCrossStudy: excluding individual-level studies ", + "({qdNames}) from cross-study fits (no LD reference available); ", + "sumstats studies participate." + ) + inform(msg) + } +} + # ============================================================================= # TWAS-weights dispatchers # ============================================================================= -# Top-level joint dispatcher for twasWeightsPipeline(QtlDataset). -# @noRd # Merge per-region TwasWeights collections (same keys across regions) into one # by concatenating each (study, context, trait, method) row's entry via # .twasMergeRegionEntries (stacked weights + flat per-region cvResult). @@ -2338,243 +1887,151 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { exec(TwasWeights, !!!twArgs) } -.twasDispatchJointSpecsQtlDataset <- function( - parsedJointSpec, - data, - methods, - contexts, - traitIds, - cisWindow, - weightsDataType, - verbose, - xRegions = list(NULL), - fitRetention = c("slim", "none", "full"), - seed = NULL -) { - fitRetention <- arg_match(fitRetention) - # Run the joint dispatch once per region block, then merge per - # (study, context, trait, method) across regions. A single block (cis or - # jointRegions=TRUE concatenated) returns its result directly. - allRegions <- map( - xRegions, - .twasDispatchJointSpecRegion, - parsedJointSpec = parsedJointSpec, - data = data, - methods = methods, - contexts = contexts, - traitIds = traitIds, - cisWindow = cisWindow, - weightsDataType = weightsDataType, - verbose = verbose, - fitRetention = fitRetention, - seed = seed - ) - allLabs <- map_chr(xRegions, .twasRegionLabel) - keep <- !map_lgl(allRegions, is.null) - perRegion <- allRegions[keep] - labs <- allLabs[keep] - if (length(perRegion) == 0L) { - return(NULL) - } - if (length(perRegion) == 1L) { - return(perRegion[[1L]]) - } - .twasMergeResultsByKey(perRegion, labs) -} +# ---- TWAS joint dispatch ---------------------------------------------------- +# +# An explicit jointSpecification fits under the same pipeline marker and the +# same engine `args` as the per-tuple multivariate grid (.twasJointSetup() / +# .twasRunJointSpecGrid()), so cross-validation, residualization, +# fitRetention, the per-method options and the mash prior reach an explicit +# joint fit exactly as they reach the rest. The explicit path used to build a +# bare pipeline record of its own -- default cross-validation, no +# fitRetention -- and to hand the engine no residualization and no options. -.twasDispatchJointSpecsQtlDatasetOneRegion <- function( +# Explicit joint specs (mr.mash) on a QtlDataset. +# @noRd +.twasDispatchJointSpecsQtlDataset <- function( parsedJointSpec, - data, - methods, + tokens, + marker, + ctx, contexts, - traitIds, - cisWindow, - weightsDataType, - verbose, - region = NULL, - fitRetention = c("slim", "none", "full"), - seed = NULL + traitIds ) { - fitRetention <- arg_match(fitRetention) - # Engine routing (jointEngine.R); one region block (the caller loops - # regions). .jointRejectStudyOnIndividual(parsedJointSpec) - pipeline <- new( - "TwasJointPipeline", - config = list( - dataType = weightsDataType, - crossValidationArgs = .cvResolve(CrossValidationParam()), - fitFullData = TRUE, - # What the accessor will actually do on this path. No - # residualization bundle reaches the TWAS joint dispatcher, so - # `residualizedGenotypes()` falls back to the dataset's own - # `scaleResiduals` slot -- which is therefore the honest answer - # here, and `NULL` says that explicitly rather than by omission. - standardized = .qtlScaleResiduals(data, NULL), - seed = seed, - ldSketch = NULL - ) - ) - .runJointSpecs( + .twasRunJointSpecGrid( parsedJointSpec, - data, - dataForm = "individual", - pipeline = pipeline, - jointMethods = intersect(methods, "mrmash"), - contexts = contexts, - traitIds = traitIds, - args = list( - methodArgs = list(), - cisWindow = cisWindow, - region = region, - verbose = verbose - ) + intersect(tokens, "mrmash"), + contexts, + traitIds, + marker, + ctx ) } - -# Top-level joint dispatcher for twasWeightsPipeline(QtlSumStats). +# Explicit joint specs (mr.mash RSS) on a QtlSumStats collection. `cfg` is +# the summary-statistics joint record, or a MultiStudy record with the +# collection as its data; `methodArgs` are the summary-statistics path's +# per-method options. # @noRd .twasDispatchJointSpecsQtlSumStats <- function( parsedJointSpec, - data, - methods, - contexts, - traitIds, - weightsDataType, - verbose, - fitRetention = c("slim", "none", "full"), - panelFilterParam = PanelFilterParam() + tokens, + methodArgs, + cfg ) { - fitRetention <- arg_match(fitRetention) - # Engine routing (jointEngine.R). pipeline <- new( "TwasJointPipeline", config = list( - dataType = weightsDataType, - crossValidationArgs = .cvResolve(CrossValidationParam()), - fitFullData = TRUE, + dataType = cfg$weightsDataType, + crossValidationParam = .cvResolve(CrossValidationParam()), + fitRetention = cfg$fitRetention, standardized = TRUE, - ldSketch = ldSketch(data) + verbose = cfg$verbose, + seed = cfg$seed, + ldReference = ldReference(cfg$data) ) ) .runJointSpecs( parsedJointSpec, - data, + cfg$data, dataForm = "sumstats", pipeline = pipeline, - jointMethods = intersect(methods, "mrmash"), - contexts = contexts, - traitIds = traitIds, + jointMethods = intersect(tokens, "mrmash"), + contexts = cfg$contexts, + traitIds = cfg$traitId, args = list( - methodArgs = list(), - verbose = verbose, - cutoffs = .panelCutoffs(panelFilterParam) + methodArgs = methodArgs, + verbose = cfg$verbose, + cutoffs = .panelCutoffs( + cfg$panelFilterParam %||% PanelFilterParam() + ) ) ) } - -# Top-level joint dispatcher for twasWeightsPipeline(MultiStudyQtlDataset). +# Joint dispatch for a MultiStudyQtlDataset. Non-study specs run on every +# individual-level component, each fitting under the setup its own QtlDataset +# run would use (.twasJointSetup() on the component, its genotype-filter +# overrides applied); every spec runs on the summary-statistics component. +# `cfg` is .twasJointCfg()'s record plus the collection, `genotypeFilterParam` +# and `panelFilterParam`; `methods` is the translated methods record. # @noRd -# --- .twasDispatchJointSpecsMultiStudy helpers ------------------------------ - -# Note that individual-level studies are excluded from cross-study TWAS fits. -.twasMultiStudyWarnExcluded <- function(studyAxisSpecs, qtlDatasets, verbose) { - if ( - length(studyAxisSpecs) > 0L && length(qtlDatasets) > 0L && verbose >= 1 - ) { - qdNames <- str_flatten(names(qtlDatasets), ", ") - msg <- glue( - "jointCrossStudy (twas): excluding individual-level ", - "studies ({qdNames}) from cross-study fits; sumstats studies ", - "participate." - ) - inform(msg) - } -} - -# Learn weights for the non-study-axis specs on each individual-level dataset. -.twasMultiStudyQtlLoop <- function( - nonStudyAxisSpecs, - qtlDatasets, +.twasDispatchJointSpecsMultiStudy <- function( + parsedJointSpec, + tokens, methods, - contexts, - traitIds, - cisWindow, - weightsDataType, - verbose, - xRegions, - fitRetention, - seed + cfg ) { - if (length(nonStudyAxisSpecs) == 0L) { - return(NULL) + qtlDatasets <- qtlDatasets(cfg$data) + specs <- .fmSplitStudyAxisSpecs(parsedJointSpec) + .twasMultiStudyWarnExcluded(specs$study, qtlDatasets, cfg$verbose) + out <- if (length(specs$nonStudy) == 0L) { + NULL + } else { + .msFoldStudyResults( + map( + qtlDatasets, + .twasStudyJointResult, + specs = specs$nonStudy, + tokens = tokens, + methods = methods, + cfg = cfg + ), + .rbindTwasWeights + ) } - .msFoldStudyResults( - map( - qtlDatasets, - .twasDispatchForStudy, - nonStudyAxisSpecs = nonStudyAxisSpecs, - methods = methods, - contexts = contexts, - traitIds = traitIds, - cisWindow = cisWindow, - weightsDataType = weightsDataType, - verbose = verbose, - xRegions = xRegions, - fitRetention = fitRetention, - seed = seed - ), - .rbindTwasWeights + .twasMultiStudySumStats( + parsedJointSpec, + specs$study, + out, + tokens, + methods, + cfg ) } -# `map()` hands the dataset first; the dispatcher wants the specs first. +# One individual-level component's joint fits. # @noRd -.twasDispatchForStudy <- function( - qd, - nonStudyAxisSpecs, - methods, - contexts, - traitIds, - cisWindow, - weightsDataType, - verbose, - xRegions, - fitRetention, - seed -) { +.twasStudyJointResult <- function(qd, specs, tokens, methods, cfg) { + setup <- .twasJointSetup( + .qtlApplyFilterOverrides(qd, cfg$genotypeFilterParam), + .twasNormalizeMethods(methods), + cfg + ) .twasDispatchJointSpecsQtlDataset( - nonStudyAxisSpecs, - qd, - methods = methods, - contexts = contexts, - traitIds = traitIds, - cisWindow = cisWindow, - weightsDataType = weightsDataType, - verbose = verbose, - xRegions = xRegions, - fitRetention = fitRetention, - seed = seed + specs, + tokens, + setup$marker, + setup$ctx, + cfg$contexts, + cfg$traitId ) } -# Learn weights for all specs on the sumstats collection; rbind onto `out`. +# Fit every spec on the summary-statistics component and rbind onto the +# individual-level results `out`. +# @noRd .twasMultiStudySumStats <- function( parsedJointSpec, - sumStats, studyAxisSpecs, out, + tokens, methods, - contexts, - traitIds, - weightsDataType, - verbose, - fitRetention + cfg ) { + sumStats <- sumStats(cfg$data) if (is.null(sumStats)) { - if (length(studyAxisSpecs) > 0L && verbose >= 1) { + if (length(studyAxisSpecs) > 0L && cfg$verbose >= 1) { msg <- glue( "jointCrossStudy (twas): no sumStats slot present on this ", "MultiStudyQtlDataset; cross-study specs produce no result." @@ -2585,70 +2042,38 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } ssRes <- .twasDispatchJointSpecsQtlSumStats( parsedJointSpec, - sumStats, - methods = methods, - contexts = contexts, - traitIds = traitIds, - weightsDataType = weightsDataType, - verbose = verbose, - fitRetention = fitRetention + tokens, + .twasSumStatsMethodTokens(methods)$methodArgs, + list_assign(cfg, data = sumStats) ) if (is.null(ssRes)) { return(out) } - embeddedLd <- ldSketch(ssRes) if (is.null(out)) { - ssRes - } else { - .rbindTwasWeights(out, ssRes, ldSketch = embeddedLd) + return(ssRes) } + .rbindTwasWeights(out, ssRes, ldReference = ldReference(ssRes)) } -.twasDispatchJointSpecsMultiStudy <- function( - parsedJointSpec, - data, - methods, - contexts, - traitIds, - cisWindow, - weightsDataType, - verbose, - xRegions = list(NULL), - fitRetention = c("slim", "none", "full"), - seed = NULL -) { - fitRetention <- arg_match(fitRetention) - qtlDatasets <- qtlDatasets(data) - sumStats <- sumStats(data) - specs <- .fmSplitStudyAxisSpecs(parsedJointSpec) - .twasMultiStudyWarnExcluded(specs$study, qtlDatasets, verbose) - out <- .twasMultiStudyQtlLoop( - specs$nonStudy, - qtlDatasets, - methods = methods, - contexts = contexts, - traitIds = traitIds, - cisWindow = cisWindow, - weightsDataType = weightsDataType, - verbose = verbose, - xRegions = xRegions, - fitRetention = fitRetention, - seed = seed - ) - .twasMultiStudySumStats( - parsedJointSpec, - sumStats, - specs$study, - out, - methods = methods, - contexts = contexts, - traitIds = traitIds, - weightsDataType = weightsDataType, - verbose = verbose, - fitRetention = fitRetention - ) + +# --- .twasDispatchJointSpecsMultiStudy helpers ------------------------------ + +# Note that individual-level studies are excluded from cross-study TWAS fits. +.twasMultiStudyWarnExcluded <- function(studyAxisSpecs, qtlDatasets, verbose) { + if ( + length(studyAxisSpecs) > 0L && length(qtlDatasets) > 0L && verbose >= 1 + ) { + qdNames <- str_flatten(names(qtlDatasets), ", ") + msg <- glue( + "jointCrossStudy (twas): excluding individual-level ", + "studies ({qdNames}) from cross-study fits; sumstats studies ", + "participate." + ) + inform(msg) + } } + # ---- map/apply helpers (lambda-free callbacks) --------------------------- # Parse the joint spec at position `i` (element + its index carry to the @@ -2720,77 +2145,3 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { .jsHasStudyAxis <- function(s) { is_in("study", s$axes) } - -# One region's FM joint-spec dispatch; `args` bundles the shared call arguments. -# @noRd -.fmDispatchJointSpecRegion <- function( - rg, - parsedJointSpec, - data, - methods, - contexts, - traitIds, - cisWindow, - credibleSetParam, - verbose, - methodArgs, - mrmashPrior, - dataDrivenPriorWeightsCutoff, - crossValidationArgs, - residualizationArgs, - pipCutoffToSkip, - fineMappingResult, - fitRetention, - seed -) { - .fmDispatchJointSpecsQtlDatasetOneRegion( - parsedJointSpec = parsedJointSpec, - data = data, - methods = methods, - contexts = contexts, - traitIds = traitIds, - cisWindow = cisWindow, - credibleSetParam = credibleSetParam, - verbose = verbose, - methodArgs = methodArgs, - mrmashPrior = mrmashPrior, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, - crossValidationArgs = crossValidationArgs, - residualizationArgs = residualizationArgs, - pipCutoffToSkip = pipCutoffToSkip, - fineMappingResult = fineMappingResult, - fitRetention = fitRetention, - seed = seed, - region = rg - ) -} - -# One region's TWAS joint-spec dispatch over a QtlDataset. -# @noRd -.twasDispatchJointSpecRegion <- function( - rg, - parsedJointSpec, - data, - methods, - contexts, - traitIds, - cisWindow, - weightsDataType, - verbose, - fitRetention, - seed = NULL -) { - .twasDispatchJointSpecsQtlDatasetOneRegion( - parsedJointSpec, - data, - methods, - contexts, - traitIds, - cisWindow, - weightsDataType, - verbose, - region = rg, - fitRetention = fitRetention, - seed = seed - ) -} diff --git a/R/ld.R b/R/ld.R index 7b2c57f10..6e90a446f 100644 --- a/R/ld.R +++ b/R/ld.R @@ -119,20 +119,8 @@ extractFilePaths <- function(genomicData, intersectionRows, columnToExtract) { ) } -#' Find LD blocks overlapping a query region from a metadata TSV file. -#' -#' @param ldReferenceMetaFile TSV with columns chrom, start, end, path. The path -#' column may be comma-separated: "ld_file,bim_file". -#' @param region "chr:start-end" string or data.frame with chrom/start/end. -#' @param completeCoverageRequired If TRUE, error when the region extends beyond -#' available LD blocks. -#' @return A list with: intersections (LD_file_paths, bimFilePaths), ldMetaData, -#' and parsed region. -#' @importFrom stringr str_split -#' @importFrom dplyr select -#' @importFrom vroom vroom -#' @noRd # Split the comma-joined path column into LD (+ optional bim) path columns. +# @noRd .regionalLdParsePaths <- function(genomicData) { parts <- str_split(genomicData$path, ",", simplify = TRUE) pathNames <- if (ncol(parts) == 2) { @@ -183,6 +171,19 @@ extractFilePaths <- function(genomicData, intersectionRows, columnToExtract) { ) } +#' Find LD blocks overlapping a query region from a metadata TSV file. +#' +#' @param ldReferenceMetaFile TSV with columns chrom, start, end, path. The path +#' column may be comma-separated: "ld_file,bim_file". +#' @param region "chr:start-end" string or data.frame with chrom/start/end. +#' @param completeCoverageRequired If TRUE, error when the region extends beyond +#' available LD blocks. +#' @return A list with: intersections (LD_file_paths, bimFilePaths), ldMetaData, +#' and parsed region. +#' @importFrom stringr str_split +#' @importFrom dplyr select +#' @importFrom vroom vroom +#' @noRd regionalLdMeta <- function( ldReferenceMetaFile, region, @@ -231,658 +232,11 @@ regionalLdMeta <- function( ) } -#' Read a pre-computed LD matrix (.cor.xz) and its bim file, returning a -#' symmetric matrix with variants ordered by position. -#' @importFrom dplyr mutate -#' @importFrom utils read.table -#' @importFrom stats setNames -#' @noRd -# Auto-detect the variant-metadata file (.bim / .pvar / .pvar.zst). -.processLdSnpFile <- function(ldFilePath, snpFilePath) { - if (!is.null(snpFilePath)) { - return(snpFilePath) - } - candidates <- str_c(ldFilePath, c(".bim", ".pvar", ".pvar.zst")) - found <- candidates[file.exists(candidates)] - if (length(found) == 0) { - msg <- glue( - "No variant file found for: {ldFilePath} ", - "(tried .bim, .pvar, .pvar.zst)" - ) - abort(msg) - } - found[1] -} - -# Read + normalise the LD variant metadata (canonical chrom / variant id / GD). -.processLdVariants <- function(snpFilePath) { - raw <- readVariantMetadata(snpFilePath) - isPvar <- !is_in("gpos", names(raw)) - ldVariants <- mutate( - raw, - chrom = canonChrom(.data$chrom), - variants = normalizeVariantId(.data$id) - ) - if (!isPvar) { - return(rename(ldVariants, GD = "gpos")) - } - # A .pvar carries no genetic distance, so GD and pos both take the - # position parsed back out of the variant id. - parsedPos <- map_int(ldVariants$variants, .ldVariantPos) - rename(ldVariants, GD = "pos") |> - mutate(GD = parsedPos, pos = parsedPos) -} - -processLdMatrix <- function(ldFilePath, snpFilePath = NULL) { - ldFileCon <- xzfile(ldFilePath) - ldValues <- scan(ldFileCon, quiet = TRUE) - close(ldFileCon) - snpFilePath <- .processLdSnpFile(ldFilePath, snpFilePath) - rawVariants <- .processLdVariants(snpFilePath) - # Label and symmetrize the matrix. - labelled <- `dimnames<-`( - matrix(ldValues, ncol = sqrt(length(ldValues)), byrow = TRUE), - list(rawVariants$variants, rawVariants$variants) - ) - # Only one triangle is stored on disk; mirror whichever one is empty. - lower <- lower.tri(labelled) - upper <- upper.tri(labelled) - ldMatrix <- if (all(labelled[lower] == 0)) { - replace(labelled, lower, t(labelled)[lower]) - } else { - replace(labelled, upper, t(labelled)[upper]) - } - # Order variants by genomic position. - posOrder <- order(map_int(rawVariants$variants, .ldVariantPos)) - ldVariants <- slice(rawVariants, posOrder) - list( - ldMatrix = ldMatrix[ldVariants$variants, ldVariants$variants], - ldVariants = ldVariants - ) -} - -#' Subset an LD matrix and variant info to a genomic region, optionally further -#' restricted to specific coordinates. -#' @importFrom dplyr mutate select inner_join -#' @noRd -extractLdForRegion <- function(ldMatrix, variants, region, extractCoordinates) { - inRegion <- filter( - variants, - .data$chrom == region$chrom & - .data$pos >= region$start & - .data$pos <= region$end - ) - extracted <- if (is.null(extractCoordinates)) { - inRegion - } else { - .ldRestrictToCoordinates(inRegion, extractCoordinates) - } - mat <- ldMatrix[extracted$variants, extracted$variants, drop = FALSE] - list(extractedLdMatrix = mat, extractedLdVariants = extracted) -} - -# The region's variants restricted to an explicit (chrom, pos) list, keeping -# only the variant-info columns the callers read back. -# @noRd -.ldRestrictToCoordinates <- function(inRegion, extractCoordinates) { - wanted <- extractCoordinates |> - mutate(chrom = canonChrom(.data$chrom)) |> - select("chrom", "pos") - joined <- inRegion |> - mutate(chrom = canonChrom(.data$chrom)) |> - inner_join(wanted, by = c("chrom", "pos")) - keepCols <- intersect( - c( - "chrom", - "variants", - "pos", - "GD", - "A1", - "A2", - "variance", - "allele_freq", - "n_nomiss" - ), - names(joined) - ) - select(joined, all_of(keepCols)) -} - -# Concatenate per-block variant-id lists into one deduplicated vector, dropping -# a repeated boundary variant shared between adjacent blocks. -# @noRd -.ldMergeVariants <- function(variantList) { - # Only the running tail decides whether a block's first id is a repeated - # boundary variant, so the merge is a fold. - reduce(variantList, .ldAppendBlockVariants, .init = character(0)) -} - -# @noRd -.ldAppendBlockVariants <- function(merged, v) { - ids <- if (is.list(v) && !is.null(v$variants)) v$variants else v - if (length(ids) == 0) { - return(merged) - } - repeatsBoundary <- length(merged) > 0 && tail(merged, 1) == ids[1] - c(merged, if (repeatsBoundary) ids[-1] else ids) -} - -#' Combine multiple block-level LD matrices into one, handling boundary -#' overlaps. -#' @importFrom utils tail -#' @noRd -createLdMatrix <- function(ldMatrices, variants) { - allVariants <- .ldMergeVariants(variants) - combined <- matrix( - 0, - nrow = length(allVariants), - ncol = length(allVariants), - dimnames = list(allVariants, allVariants) - ) - - # Deliberate preallocate-and-scatter: `combined` is variants x variants, - # so building it by folding full-size copies would multiply the memory - # this function needs by the number of blocks. - for (i in seq_along(ldMatrices)) { - v <- rownames(ldMatrices[[i]]) - idx <- match(v, allVariants) - combined[idx, idx] <- ldMatrices[[i]] - } - combined -} - -# Dispatch to the genotype- or pre-computed-block LD loader for the source. -.loadLdDispatch <- function( - source, - isGeno, - region, - extractCoordinates, - returnGenotype, - nSample -) { - if (isGeno) { - genoPath <- resolveGenotypePathForRegion(source$metaPath, region) - return(loadLdFromGenotype( - genoPath, - region, - returnGenotype = returnGenotype, - nSample = nSample - )) - } - if (returnGenotype) { - msg <- glue( - "returnGenotype=TRUE requires genotype files, not ", - "pre-computed LD matrices." - ) - abort(msg) - } - loadLdFromBlocks( - source$metaPath, - region, - extractCoordinates, - nSample = nSample - ) -} - -# Drop duplicate variant ids (boundary-overlap safety net). -.loadLdDedup <- function(result) { - variantIds <- variantIds(result) - if (is.null(variantIds)) { - return(result) - } - dupIdx <- which(duplicated(variantIds)) - if (length(dupIdx) == 0) { - return(result) - } - full <- ldMatrix(result) - corr <- if (is.null(full)) { - NULL - } else { - full[-dupIdx, -dupIdx, drop = FALSE] - } - LdData( - correlation = corr, - genotypeHandle = genotypeHandle(result), - snpIdx = snpIdx(result), - variants = variantInfo(result)[-dupIdx], - blockMetadata = blockMetadata(result), - nSamples = ldPanelNSamples(result) - ) -} - -#' Load and Process Linkage Disequilibrium (LD) Matrix -#' -#' Unified entry point for loading LD data from a metadata TSV file. -#' -#' The metadata TSV must have columns: chrom, start, end, path. Two formats: -#' \itemize{ -#' \item Pre-computed LD blocks: many rows per chromosome with block -#' boundaries -#' in start/end and path pointing to .cor.xz files (optionally -#' comma-separated -#' with a .bim path). -#' \item PLINK genotype files: one row per chromosome with start=0, end=0, and -#' path pointing to a per-chromosome PLINK prefix (.pgen/.pvar[.zst]/.psam -#' or -#' .bed/.bim/.fam). LD is computed on the fly via \code{computeLd()}. -#' } -#' -#' @param ldMetaFilePath Path to the LD metadata TSV file. -#' @param region Region of interest: "chr:start-end" string or data.frame with -#' chrom/start/end. -#' @param block Integer block index (or vector of them), for sources that -#' carry no coordinates: an \code{ldInfo} table (the cTWAS \code{LD_map} -#' shape -- an \code{LD_file} column and optionally \code{SNP_file}), a -#' correlation or genotype matrix, or a list of either. Supply exactly one -#' of \code{region} and \code{block}. -#' @param dropMonomorphic Logical. Drop variants with no variation, which -#' carry no LD and make a correlation undefined. Needs allele frequencies, -#' so it applies to genotype sources. -#' @param materializeGenotypes Logical. Read the dosages once and keep them on -#' the returned object, so later access does no file I/O. Costs memory and -#' saves repeated reads. -#' @param maxVariants Integer or \code{NULL}. Randomly thin any block larger -#' than this, to bound memory. -#' @param seed Integer or \code{NULL}. Seeds the \code{maxVariants} draw, -#' offset by the block index so blocks are independent yet reproducible, via -#' a scoped \code{withr::local_seed} that leaves the session RNG alone. -#' @param extractCoordinates Optional data.frame with columns "chrom" and "pos" -#' for specific coordinates extraction (only for pre-computed LD blocks). -#' @param returnGenotype Controls what ldMatrix contains in the return value. -#' FALSE (default): always return correlation matrix R. TRUE: return genotype -#' matrix X (only valid for PLINK sources). "auto": return X for PLINK -#' sources, R for pre-computed sources. -#' @param nSample Optional sample size for computing variance (= -#' 2*p*(1-p)*n/(n-1)). If NULL, ref_panel will not include variance or -#' n_nomiss columns. Only used for PLINK genotype sources. -#' -#' @return A list with: -#' \describe{ -#' \item{ldVariants}{Character vector of variant IDs (canonical format).} -#' \item{ldMatrix}{LD correlation matrix R (or genotype matrix X when -#' returnGenotype is TRUE or "auto" with PLINK source).} -#' \item{ref_panel}{Data.frame with variant metadata (chrom, pos, A2, A1, -#' variant_id, -#' and optionally allele_freq, variance, n_nomiss).} -#' \item{is_genotype}{Logical: TRUE if ldMatrix contains genotype X, FALSE if -#' correlation R.} -#' \item{blockMetadata}{Data.frame with region/block info. For pre-computed -#' LD: one row per block. -#' For PLINK: a single row spanning the loaded region.} -#' } -#' @examples -#' meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", -#' package = "pecotmr") -#' loadLdMatrix(ldMetaFilePath = meta, region = "chr22:16000000-18000000") -#' # Several regions at once return one LdData per block. -#' length(loadLdMatrix(meta, region = rep("chr22:16000000-18000000", 2))) -#' @export -loadLdMatrix <- function( - ldMetaFilePath, - region = NULL, - block = NULL, - extractCoordinates = NULL, - returnGenotype = FALSE, - dropMonomorphic = FALSE, - materializeGenotypes = FALSE, - maxVariants = NULL, - seed = NULL, - nSample = NULL -) { - .ldLoadValidateAddress(ldMetaFilePath, region, block) - keys <- if (is.null(region)) block else region - # Only an atomic vector addresses several blocks. `region` also accepts a - # single data.frame / GRanges spec, whose length is its column count -- - # treating that as many keys would map over the columns. - if (is.atomic(keys) && length(keys) > 1L) { - return(map( - keys, - .loadLdOne, - source = ldMetaFilePath, - byRegion = is.null(block), - extractCoordinates = extractCoordinates, - returnGenotype = returnGenotype, - dropMonomorphic = dropMonomorphic, - materializeGenotypes = materializeGenotypes, - maxVariants = maxVariants, - seed = seed, - nSample = nSample - )) - } - .loadLdOne( - keys, - ldMetaFilePath, - byRegion = is.null(block), - extractCoordinates = extractCoordinates, - returnGenotype = returnGenotype, - dropMonomorphic = dropMonomorphic, - materializeGenotypes = materializeGenotypes, - maxVariants = maxVariants, - seed = seed, - nSample = nSample - ) -} - -# A source is addressed either by genomic region (an LD meta file, which -# carries coordinates) or by block index (an `ldInfo` table or in-memory -# matrices, which do not). Exactly one addressing mode applies. -# @noRd -.ldLoadValidateAddress <- function(source, region, block) { - if (is.null(region) && is.null(block)) { - abort("loadLdMatrix: supply either `region` or `block`.") - } - if (!is.null(region) && !is.null(block)) { - abort("loadLdMatrix: supply `region` or `block`, not both.") - } - if (!is.null(region) && !is.character(source)) { - msg <- glue( - "loadLdMatrix: `region` addresses an LD meta file, but ", - "`ldMetaFilePath` is a {class(source)[[1L]]}. Coordinate-free ", - "sources (an `ldInfo` table, a matrix, or a list of matrices) ", - "are addressed with `block`." - ) - abort(msg) - } - invisible(TRUE) -} - -# One block, whatever the source. Everything that is not an LD meta file is -# coordinate-free and indexed by `block`. -# @noRd -.loadLdOne <- function( - key, - source, - byRegion, - extractCoordinates, - returnGenotype, - dropMonomorphic, - materializeGenotypes, - maxVariants, - seed, - nSample -) { - loaded <- if (byRegion) { - .loadLdFromMeta( - source, - key, - extractCoordinates, - returnGenotype, - nSample - ) - } else { - .loadLdFromIndexed(source, key) - } - loaded |> - .loadLdDedup() |> - .ldApplyMonomorphic(dropMonomorphic) |> - .ldApplySubsample(maxVariants, seed, key) |> - .ldApplyMaterialize(materializeGenotypes) -} - -# Coordinate-free sources, addressed by block index: an `ldInfo` table (the -# cTWAS LD_map shape -- LD_file plus optional SNP_file, no coordinates), a -# single in-memory matrix, or a list of them. Every source returns an LdData, -# so callers never have to branch on what they loaded from. -# @noRd -.loadLdFromIndexed <- function(source, block) { - if (is.data.frame(source)) { - return(.ldInfoBlock(source, block)) - } - mat <- if (is.list(source)) source[[block]] else source - if (!is.matrix(mat)) { - msg <- glue( - "loadLdMatrix: cannot address a {class(source)[[1L]]} by block. ", - "Supply an LD meta file path, an `ldInfo` data.frame, a matrix, ", - "or a list of matrices." - ) - abort(msg) - } - .ldDataFromMatrix(mat, isGenotype = nrow(mat) > ncol(mat)) -} - -# One row of an `ldInfo` table. Genotype paths are read and correlated; -# pre-computed .cor.xz blocks are read directly. -# @noRd -.ldInfoBlock <- function(ldInfo, block) { - if (!is_in("LD_file", colnames(ldInfo))) { - abort("loadLdMatrix: an `ldInfo` table needs an `LD_file` column.") - } - ldPath <- as.character(ldInfo$LD_file)[block] - if (isGenotypeSource(ldPath)) { - geno <- loadGenotypeRegion(ldPath) - return(.ldDataFromMatrix(geno, isGenotype = TRUE)) - } - snpFile <- if (is_in("SNP_file", colnames(ldInfo))) { - as.character(ldInfo$SNP_file)[block] - } else { - NULL # processLdMatrix auto-detects the .bim / .pvar companion - } - .ldDataFromProcessed(processLdMatrix(ldPath, snpFile)) -} - -# Wrap processLdMatrix()'s (matrix, variants) pair as an LdData so BOTH -# `ldInfo` sources return one type -- the contract .loadLdFromIndexed states -# and the post-load chain (dedup / monomorphic / subsample) relies on. -# -# Not .ldDataFromMatrix(): that one is for a bare matrix with no metadata and -# substitutes placeholder chrNA:1..n coordinates. A precomputed LD block comes -# with its .bim/.pvar, so the real chrom/pos/alleles are carried through. -# @noRd -.ldDataFromProcessed <- function(proc) { - v <- proc$ldVariants - n <- nrow(v) - gr <- .refPanelToGranges(data.frame( - chrom = as.character(v$chrom), - pos = as.integer(v$pos), - variant_id = as.character(v$variants), - A1 = as.character(v$A1), - A2 = as.character(v$A2), - stringsAsFactors = FALSE - )) - LdData( - correlation = proc$ldMatrix, - variants = gr, - blockMetadata = tibble( - blockId = 1L, - size = n, - startIdx = 1L, - endIdx = n - ), - nSamples = 0L - ) -} - -# Wrap a bare matrix as an LdData so every source returns one type. Variant -# identity comes from the dimnames when present. -# @noRd -.ldDataFromMatrix <- function(mat, isGenotype) { - n <- if (isGenotype) ncol(mat) else nrow(mat) - named <- if (isGenotype) colnames(mat) else rownames(mat) - ids <- named %||% str_c("v", seq_len(n)) - gr <- S4Vectors::`mcols<-`( - GRanges( - seqnames = rep("chrNA", n), - ranges = IRanges::IRanges(start = seq_len(n), width = 1L) - ), - value = S4Vectors::DataFrame(variant_id = ids) - ) - LdData( - correlation = if (isGenotype) NULL else mat, - genotypeHandle = if (isGenotype) mat else NULL, - variants = gr, - blockMetadata = tibble(blockId = 1L, size = n), - nSamples = if (isGenotype) nrow(mat) else 0L - ) -} - -# Drop variants with no variation. They carry no LD, and a zero-variance -# column makes a correlation undefined. -# @noRd -.ldApplyMonomorphic <- function(ld, dropMonomorphic) { - if (!isTRUE(dropMonomorphic)) { - return(ld) - } - refPanel <- refPanel(ld) - if (is.null(refPanel) || !is_in("allele_freq", colnames(refPanel))) { - return(ld) - } - p <- refPanel$allele_freq - keep <- !is.na(p) & p > 0 & p < 1 - if (all(keep)) { - return(ld) - } - .ldSubsetData(ld, which(keep)) -} - -# Randomly thin an oversized block, seeded per block so a run is reproducible -# without disturbing the session RNG. -# @noRd -.ldApplySubsample <- function(ld, maxVariants, seed, key) { - if (is.null(maxVariants) || length(ld) <= maxVariants) { - return(ld) - } - if (!is.null(seed)) { - offset <- if (is.numeric(key)) as.integer(key) else 0L - withr::local_seed(as.integer(seed) + offset) - } - .ldSubsetData(ld, sort(sample(length(ld), maxVariants))) -} - -# Read the dosages once and keep them on the object, so later access does no -# file I/O. -# @noRd -.ldApplyMaterialize <- function(ld, materializeGenotypes) { - if (!isTRUE(materializeGenotypes) || !hasGenotypes(ld)) { - return(ld) - } - X <- genotypes(ld) - if (!is.matrix(X)) { - return(ld) - } - LdData( - correlation = NULL, - genotypeHandle = X, - snpIdx = NULL, - variants = variantInfo(ld), - blockMetadata = blockMetadata(ld), - nSamples = ldPanelNSamples(ld) - ) -} - -# Narrow an LdData to a subset of its variants, keeping correlation and -# genotypes consistent with the ranges. -# @noRd -.ldSubsetData <- function(ld, idx) { - full <- ld@correlation - R <- if (!is.null(full) && is.matrix(full)) { - full[idx, idx, drop = FALSE] - } else { - full - } - raw <- ld@genotypeHandle - gh <- if (is.matrix(raw)) raw[, idx, drop = FALSE] else raw - snpIdx <- if (is.matrix(raw) || is.null(ld@snpIdx)) { - ld@snpIdx - } else { - ld@snpIdx[idx] - } - LdData( - correlation = R, - genotypeHandle = gh, - snpIdx = if (is.matrix(gh)) NULL else snpIdx, - variants = variantInfo(ld)[idx], - blockMetadata = blockMetadata(ld), - nSamples = ldPanelNSamples(ld) - ) -} - -# @noRd -.loadLdFromMeta <- function( - ldMetaFilePath, - region, - extractCoordinates, - returnGenotype, - nSample -) { - source <- resolveLdSource(ldMetaFilePath) - isGeno <- is_in(source$type, c("plink2", "plink1", "vcf", "gds")) - # "auto": return X for genotype sources, R for pre-computed. - if (identical(returnGenotype, "auto")) { - returnGenotype <- isGeno - } - .loadLdDispatch( - source, - isGeno, - region, - extractCoordinates, - returnGenotype, - nSample - ) -} - # ---------- Internal: resolve LD source type ---------- -#' @noRd -hasPlink2Files <- function(prefix) { - file.exists(str_c(prefix, ".pgen")) && - (file.exists(str_c(prefix, ".pvar")) || - file.exists(str_c(prefix, ".pvar.zst"))) && - file.exists(str_c(prefix, ".psam")) -} - -#' @noRd -hasPlink1Files <- function(prefix) { - file.exists(str_c(prefix, ".bed")) && - file.exists(str_c(prefix, ".bim")) && - file.exists(str_c(prefix, ".fam")) -} - -#' @noRd -isVcfPath <- function(path) { - str_detect(path, "\\.(vcf|vcf\\.gz|bcf)$") && file.exists(path) -} - -#' @noRd -isGdsPath <- function(path) { - str_detect(path, "\\.gds$") && file.exists(path) -} - -#' Check whether a path points to a genotype source (PLINK, VCF, or GDS). -#' @noRd -isGenotypeSource <- function(path) { - hasPlink2Files(path) || - hasPlink1Files(path) || - isVcfPath(path) || - isGdsPath(path) -} - -#' Resolve an LD source metadata TSV to its actual data type. -#' -#' The metadata TSV has columns: chrom, start, end, path. Three categories are -#' supported: -#' \itemize{ -#' \item Pre-computed LD blocks (.cor.xz): many rows per chromosome, each with -#' specific start/end block boundaries and path pointing to .cor.xz files. -#' \item Genotype files (PLINK2, PLINK1, VCF, or GDS): one row per chromosome -#' with start=0, end=0, and path pointing to a per-chromosome genotype file -#' or prefix. The actual region filter is applied by the genotype loader. -#' } -#' -#' This function peeks at the first row to determine the data type. The actual -#' per-chromosome path is resolved later by -#' \code{resolveGenotypePathForRegion()} at load time. -#' -#' @param path Path to a metadata TSV file with columns chrom, start, end, path. -#' @return A list with: -#' \item{type}{"plink2", "plink1", "vcf", "gds", or "precomputed"} -#' \item{dataPath}{Genotype path from first row (for type detection only; -#' actual -#' per-chromosome path is resolved at load time)} -#' \item{metaPath}{The metadata TSV path (always set)} -#' @importFrom vroom vroom -#' @noRd # Read + validate the first row of an LD metadata TSV (>=4 columns). #' @importFrom checkmate checkFileExists +# @noRd .resolveLdReadMeta <- function(path) { res <- checkFileExists(path, access = "r") if (!isTRUE(res)) { @@ -907,24 +261,53 @@ isGenotypeSource <- function(path) { ) } -# Genotype source descriptor for the resolved path, or NULL if pre-computed. +# Genotype source descriptor for the resolved path, or NULL when it is not a +# genotype file or PLINK prefix, its format told as readGenotypes() tells it. +# A PLINK source is described by its stem, which its readers take. .resolveLdGenotypeType <- function(resolved, path) { - if (hasPlink2Files(resolved)) { - return(list(type = "plink2", dataPath = resolved, metaPath = path)) - } - if (hasPlink1Files(resolved)) { - return(list(type = "plink1", dataPath = resolved, metaPath = path)) - } - if (isVcfPath(resolved)) { - return(list(type = "vcf", dataPath = resolved, metaPath = path)) + format <- .genotypePathFormat(resolved) + if (is.null(format)) { + return(NULL) } - if (isGdsPath(resolved)) { - return(list(type = "gds", dataPath = resolved, metaPath = path)) + dataPath <- if (str_starts(format, "plink")) { + .genotypeStem(resolved) + } else { + resolved } - NULL + list(type = format, dataPath = dataPath, metaPath = path) } +#' Resolve an LD source metadata TSV to its genotype file type. +#' +#' The metadata TSV has columns: chrom, start, end, path, with one row per +#' chromosome (start=0, end=0) whose path is a per-chromosome genotype file or +#' prefix (PLINK2, PLINK1, VCF, GDS or BGEN). The actual region filter is +#' applied by the genotype loader. pecotmr does not read pre-computed LD from +#' disk, so a row pointing at anything else is an error. +#' +#' This function peeks at the first row to determine the data type. The actual +#' per-chromosome path is resolved later by +#' \code{resolveGenotypePathForRegion()} at load time. +#' +#' A path that is itself a genotype file or PLINK prefix is that source, with +#' no metadata. +#' +#' @param path Path to a metadata TSV file with columns chrom, start, end, +#' path, or to a genotype file or PLINK prefix. +#' @return A list with: +#' \item{type}{"plink2", "plink1", "vcf", "gds" or "bgen"} +#' \item{dataPath}{Genotype path from first row (for type detection only; +#' actual +#' per-chromosome path is resolved at load time)} +#' \item{metaPath}{The metadata TSV path, or NULL for a genotype source +#' given directly} +#' @importFrom vroom vroom +#' @noRd resolveLdSource <- function(path) { + direct <- .resolveLdGenotypeType(path, NULL) + if (!is.null(direct)) { + return(direct) + } meta <- .resolveLdReadMeta(path) # Strip the comma-separated bim path, then resolve relative to the meta dir. rawPath <- str_remove(meta$path[1], ",.*$") @@ -933,22 +316,17 @@ resolveLdSource <- function(path) { if (!is.null(genoType)) { return(genoType) } - if ( - !is.na(meta$start) && - !is.na(meta$end) && - meta$start == 0 && - meta$end == 0 - ) { - msg <- glue( - "Metadata has start=0, end=0 but path does not resolve to ", - "genotype files: {resolved}", - "\n The 0:0 sentinel is only valid for whole-chromosome ", - "genotype files.", - .trim = FALSE + abort(c( + glue( + "The LD metadata's path does not resolve to genotype files: ", + "{resolved}" + ), + i = str_c( + "pecotmr reads LD only from genotypes (PLINK2, PLINK1, VCF, GDS, ", + "BGEN); ", + "wrap a pre-computed LD matrix in an LdMatrix instead." ) - abort(msg) - } - list(type = "precomputed", metaPath = path) + )) } #' Resolve the correct genotype path for a given region from a metadata TSV. @@ -975,220 +353,181 @@ resolveGenotypePathForRegion <- function(metaPath, region) { file.path(dirname(metaPath), rawPath) } -# ---------- Internal: load LD from genotype files ---------- - -#' Load genotype data and compute LD or return genotype matrix. -#' @noRd -# --- loadLdFromGenotype helpers --------------------------------------------- - -# Reference panel from variant ids + allele frequency (.afreq or dosage-derived) -# + variance when a sample size is supplied. -.loadLdGtRefPanel <- function( - X, - variantInfo, - variantIds, - genotypePath, - nSample -) { - afreq <- readAfreq(genotypePath) - alleleFreq <- if (is.null(afreq)) { - colMeans(X, na.rm = TRUE) / 2 - } else { - freqMatch <- match(variantInfo$id, afreq$id) - nUnmatched <- sum(is.na(freqMatch)) - if (nUnmatched > 0) { - nFreq <- length(freqMatch) - msg <- glue( - "{nUnmatched} out of {nFreq} variants have no allele ", - "frequency in .afreq file." - ) - warn(msg) - } - afreq$alt_freq[freqMatch] +# ---------- LD reference: what it is and how it is held ---------- +# +# An LD reference is one of these, and every helper below answers for each: +# +# a genotype panel a RangedSummarizedExperiment over a GenotypeHandle, +# read lazily from disk -- the same shape as QtlDataset's +# genotype experiment. A bare GenotypeHandle, which objects +# serialised before the slot became an RSE still carry, is +# treated as one. +# a GenotypeMixture several genotype panels whose LD is averaged, still +# lazy: each panel is read only for the variants asked +# about, and answers for its own samples. +# an LdMatrix a correlation matrix the caller built, held in memory. + +# Normalise an LD-reference input to the shape the slot holds: a panel or an +# LdMatrix as given, a bare GenotypeHandle wrapped into a panel -- so a sketch +# and QtlDataset's genotype experiment end up being the same object with +# different provenance rather than two spellings of one idea. +# @noRd +.asLdRef <- function(x) { + if (is.null(x) || .ldIsMatrixRef(x) || .ldIsMixtureRef(x)) { + return(x) } - mutate( - parseVariantId(variantIds), - variant_id = variantIds, - allele_freq = alleleFreq, - !!!.ldPanelSampleCols(alleleFreq, nSample) - ) + if (methods::is(x, "RangedSummarizedExperiment")) { + return(x) + } + if (methods::is(x, "GenotypeHandle")) { + return(.genotypeExperiment(x)) + } + abort(glue( + "`ldReference` must be a genotype panel (see readGenotypes()), a ", + "GenotypeMixture or an LdMatrix (got {class(x)[[1L]]})." + )) } -# The panel's per-variant variance / non-missing count, which are only -# derivable once the caller declares the sample size behind the frequencies. +# TRUE for an LD reference held as a matrix rather than as genotypes. # @noRd -.ldPanelSampleCols <- function(p, nSample) { - if (is.null(nSample)) { - return(list()) - } - list( - variance = 2 * p * (1 - p) * nSample / (nSample - 1), - n_nomiss = nSample - ) +.ldIsMatrixRef <- function(x) { + methods::is(x, "LdMatrix") } -# Single-block metadata spanning the loaded region. -.loadLdGtBlockMeta <- function(variantInfo, variantIds) { - positions <- variantInfo$pos - tibble( - blockId = 1L, - chrom = as.character(variantInfo$chrom[1]), - blockStart = min(positions), - blockEnd = max(positions), - size = length(variantIds), - startIdx = 1L, - endIdx = length(variantIds) - ) +# TRUE for a mixture of genotype panels. +# @noRd +.ldIsMixtureRef <- function(x) { + methods::is(x, "GenotypeMixture") } -# Lazy-genotype LdData result (handle + region snp index, no correlation). -.loadLdGtGenotypeResult <- function( - genotypePath, - region, - variantsGr, - blockMetadata, - X -) { - handle <- .readGenotypeHandle(genotypePath) - snpIdx <- .regionToSnpIdx(snpInfo(handle), region) - LdData( - correlation = NULL, - genotypeHandle = handle, - snpIdx = snpIdx, - variants = variantsGr, - blockMetadata = blockMetadata, - nSamples = as.integer(nrow(X)) - ) +# TRUE for an LD reference backed by genotypes: a panel or a mixture of them. +# @noRd +.ldIsGenotypeRef <- function(x) { + .ldIsPanel(x) || .ldIsMixtureRef(x) } -loadLdFromGenotype <- function( - genotypePath, - region, - returnGenotype = FALSE, - nSample = NULL -) { - result <- loadGenotypeRegion( - genotypePath, - region = region, - returnVariantInfo = TRUE - ) - variantInfo <- result$variant_info - variantIds <- normalizeVariantId(formatVariantId( - variantInfo$chrom, - variantInfo$pos, - variantInfo$A2, - variantInfo$A1 - )) - X <- `colnames<-`(result$X, variantIds) - refPanel <- .loadLdGtRefPanel( - X, - variantInfo, - variantIds, - genotypePath, - nSample - ) - blockMetadata <- .loadLdGtBlockMeta(variantInfo, variantIds) - variantsGr <- .refPanelToGranges(refPanel) - if (returnGenotype) { - return(.loadLdGtGenotypeResult( - genotypePath, - region, - variantsGr, - blockMetadata, - X - )) - } - R <- computeLd(X, method = "sample") - LdData( - correlation = R, - genotypeHandle = NULL, - snpIdx = NULL, - variants = variantsGr, - blockMetadata = blockMetadata, - nSamples = as.integer(nrow(X)) - ) +# TRUE for anything that can serve as an LD reference. +# @noRd +.ldIsReference <- function(x) { + .ldIsGenotypeRef(x) || .ldIsMatrixRef(x) } -# ---------- LD sketch: per-variant LD matrix ---------- - -# Internal: build a sample-correlation LD matrix for a specified variant -# subset of an `ldSketch` `GenotypeHandle`. Called directly by -# twasWeightsPipeline, fineMappingPipeline, jointEngine, -# causalInferencePipeline, colocboostPipeline and the coloc / summaryStatsQc -# paths, which differ only in their error message prefix and in whether -# variants absent from the panel raise an error or get silently dropped -- -# both of which are arguments here rather than a per-pipeline wrapper. -# -# Arguments: -# ldSketch A GenotypeHandle. -# variantIds Character vector of SNP IDs to extract. -# label Error-message prefix, e.g. "twasWeightsPipeline". -# onMissing "error" (default) -> any unmatched id stops the call; -# "drop" -> unmatched ids are silently filtered. -# When "drop" leaves no surviving variants the function -# returns NULL. -# -# Returns: -# A `length(variantIds) x length(variantIds)` symmetric LD matrix with -# rows/cols named by the (possibly filtered) `variantIds`. -# With `onMissing = "drop"` the returned matrix carries an attribute -# `"keptVariantIds"` so callers can recover which ids survived. -# Require a non-NULL GenotypeHandle ldSketch. -# Normalise an LD-sketch input to the RangedSummarizedExperiment the slot -# holds. Accepts a bare GenotypeHandle, which is what every caller has passed -# until now, and wraps it -- so a sketch and QtlDataset's genotype experiment -# end up being the same object with different provenance rather than two -# spellings of one idea. -# @noRd -.asLdSketch <- function(x) { - if (is.null(x)) { +# The GenotypeHandle a panel reads through, or NULL when it reads through +# none: an LdMatrix, a mixture, or a panel whose dosages come from another +# backend (a VCF, GDS or PLINK1 seed, or a matrix held in memory). The handle +# is the DelayedArray seed of the dosage assay, so it stays reachable after +# the panel is subset. Tolerates a bare handle, which is what objects +# serialised before the slot became an RSE still carry. +# @noRd +.ldRefHandle <- function(x) { + if (is.null(x) || .ldIsMatrixRef(x) || .ldIsMixtureRef(x)) { return(NULL) } - if (methods::is(x, "RangedSummarizedExperiment")) { + if (methods::is(x, "GenotypeHandle")) { return(x) } - if (methods::is(x, "GenotypeHandle")) { - return(.genotypeExperiment(x)) + seed <- .panelSeed(x) + if (!methods::is(seed, "GhSeed")) { + return(NULL) } - abort(glue( - "`ldSketch` must be a genotype panel -- a ", - "RangedSummarizedExperiment or a GenotypeHandle (got ", - "{class(x)[[1L]]})." - )) + .ghSeedHandle(seed) } -# The GenotypeHandle a sketch reads through. The handle is the DelayedArray -# seed of the dosage assay, so it stays reachable after the sketch is subset. -# Tolerates a bare handle, which is what objects serialised before the slot -# became an RSE still carry. +# The DelayedArray seed under a panel's dosage assay -- a GhSeed, or a +# GenotypeDosageSeed for a VCF, GDS or PLINK1 panel -- or NULL for an assay +# held in memory or combined from several seeds (a per-chromosome set of +# those). # @noRd -.ldSketchHandle <- function(x) { - if (is.null(x)) { +#' @importFrom rlang try_fetch +.panelSeed <- function(panel) { + dosage <- SummarizedExperiment::assay( + panel, + "dosage", + withDimnames = FALSE + ) + if (!methods::is(dosage, "DelayedArray")) { return(NULL) } - if (methods::is(x, "GenotypeHandle")) { - return(x) - } - .ghSeedHandle( - DelayedArray::seed(SummarizedExperiment::assay(x, "dosage")) + try_fetch(DelayedArray::seed(dosage), error = function(cnd) NULL) +} + +# ---------- LD reference: where its genotypes come from ---------- +# +# A panel records when it is built where its genotypes come from -- +# list(format, path, chromPaths) -- as metadata(panel)$genotypeSource. What +# needs the file reads it there: a sketch's .afreq sidecar, a label, ctwas's +# check that the payload exists, a per-chromosome manifest's shards. So a +# panel need not read through a GenotypeHandle: a VCF, GDS or PLINK1 panel +# reads through its own backend, and any RSE with a dosage assay can serve. + +# The record of a handle's genotype source. +# @noRd +.genotypeSourceRecord <- function(handle) { + list( + format = genotypeFormat(handle), + path = path(handle), + chromPaths = .genotypeChromPaths(handle) ) } -# Narrow a sketch to a variant subset. On an RSE this is ordinary subsetting, -# which brings the DelayedArray's index bookkeeping with it; a legacy bare -# handle falls back to the handle-level trim, which needs fileIdx to stay -# read-safe. +# An LD reference's genotype source: the record its panel carries -- or, for +# a panel built before panels carried one and for a bare handle, its +# handle's -- or NULL for a panel held in memory, an LdMatrix or a mixture. +# @noRd +.ldRefSource <- function(x) { + if (is.null(x) || .ldIsMatrixRef(x) || .ldIsMixtureRef(x)) { + return(NULL) + } + if (methods::is(x, "RangedSummarizedExperiment")) { + recorded <- S4Vectors::metadata(x)$genotypeSource + if (!is.null(recorded)) { + return(recorded) + } + } + handle <- .ldRefHandle(x) + if (is.null(handle)) NULL else .genotypeSourceRecord(handle) +} + +# @noRd +.ldRefFormat <- function(x) { + .ldRefSource(x)$format +} + +# The file an LD reference reads, resolved to a real path (a bundled +# example's portable reference resolves under the installed package), or +# NULL when it reads none. +# @noRd +.ldRefReadPath <- function(x) { + p <- .ldRefSource(x)$path + if (is.null(p)) NULL else .resolveGenotypeResourcePath(p) +} + +# The per-chromosome files of a panel read from a manifest, named by +# chromosome; empty for a panel read from one file. +# @noRd +.ldRefChromPaths <- function(x) { + .ldRefSource(x)$chromPaths %||% character(0) +} + +# Narrow an LD reference to a variant subset. A panel is cut so that, where it +# can, its seed sheds the dropped variants too (.panelSubsetRows()); an +# LdMatrix subsets its matrix along with its variants; a legacy bare handle +# falls back to the handle-level trim, which needs fileIdx to stay read-safe. # @noRd -.ldSketchSubset <- function(x, keep) { +.ldRefSubset <- function(x, keep) { if (is.null(x)) { return(NULL) } + if (.ldIsMatrixRef(x)) { + return(x[keep]) + } + if (.ldIsMixtureRef(x)) { + return(.gmRowsAt(x, keep)) + } if (methods::is(x, "GenotypeHandle")) { return(.subsetGenotypeHandle(x, keep)) } - # `drop = FALSE`: the fallback shape is the matrix sketch, which a - # one-variant `keep` would otherwise collapse to a vector. - x[keep, , drop = FALSE] + .panelSubsetRows(x, keep) } # A sketch trimmed to zero variants, every other property preserved. Used when @@ -1197,26 +536,135 @@ loadLdFromGenotype <- function( # which on a real panel is ~135 MB of serialized dead weight per such entry. # NULL-safe and idempotent. # @noRd -.emptySketch <- function(x) { +.emptyLdRef <- function(x) { if (is.null(x)) { return(NULL) } + if (.ldIsMatrixRef(x)) { + return(x[integer(0)]) + } + if (.ldIsMixtureRef(x)) { + return(.gmRowsAt(x, integer(0))) + } if (methods::is(x, "GenotypeHandle")) { return(.emptyGenotypeHandle(x)) } - # A panel holds its handle TWICE -- as rowRanges and inside the dosage - # assay's DelayedArray seed. `x[integer(0), ]` drops the rows but leaves - # the seed carrying the whole panel's snpInfo, which is precisely the - # weight this exists to shed. Rebuild from an emptied handle so both go. - .genotypeExperiment(.emptyGenotypeHandle(.ldSketchHandle(x))) + .emptyPanel(x, keepSamples = FALSE) +} + +# A panel cut to the variants `keep` marks (a mask or positions). A panel +# whose rows are exactly its seed's, cut to an ordered subset, has the seed +# cut too -- a GenotypeHandle trimmed, a VCF, GDS or PLINK1 seed cut to the +# records the kept rows read -- so the cut panel's seed does not carry the +# dropped variants' metadata (see .emptyPanel()); its rowRanges, samples, +# colData and recorded metadata are its own, cut alike, so no sidecar is read +# again. Any other cut -- of a panel that is itself a row subset, of one held +# in memory or whose handle predates fileIdx, or one that reorders or repeats +# rows -- is taken from its assay, which then reads only those rows. +# @noRd +.panelSubsetRows <- function(panel, keep) { + keepIdx <- if (is.logical(keep)) which(keep) else as.integer(keep) + dosage <- .panelCutDosage(panel, keepIdx) + if (is.null(dosage)) { + # `drop = FALSE`: a one-variant `keep` would otherwise collapse the + # assay to a vector. + return(panel[keep, , drop = FALSE]) + } + SummarizedExperiment::SummarizedExperiment( + assays = list(dosage = dosage[, colnames(panel), drop = FALSE]), + rowRanges = SummarizedExperiment::rowRanges(panel)[keepIdx], + colData = SummarizedExperiment::colData(panel), + metadata = S4Vectors::metadata(panel) + ) +} + +# The dosage assay of a panel cut to rows `keepIdx`, over a seed cut alike, +# or NULL when the seed cannot be cut so (see .panelSubsetRows()). +# @noRd +.panelCutDosage <- function(panel, keepIdx) { + if ( + length(keepIdx) >= nrow(panel) || + is.unsorted(keepIdx, strictly = TRUE) + ) { + return(NULL) + } + seed <- .panelSeed(panel) + if ( + methods::is(seed, "GenotypeDosageSeed") && + identical(rownames(panel), dimnames(seed)[[1L]]) + ) { + return(DelayedArray::DelayedArray(.gdSeedRows(seed, keepIdx))) + } + handle <- .ldRefHandle(panel) + if (is.null(handle) || !.panelRowsAreHandle(panel, handle)) { + return(NULL) + } + genotypeDelayedArray(.subsetGenotypeHandle(handle, keepIdx)) +} + +# A panel's dimensions before any subsetting: its dosage seed's, or its own +# when it holds its dosages in memory. +# @noRd +.panelFullDims <- function(panel) { + seed <- .panelSeed(panel) + if (is.null(seed)) dim(panel) else dim(seed) +} + +# TRUE when a panel's rows are its handle's own, in order, and the handle can +# be trimmed (it records each variant's file position). +# @noRd +.panelRowsAreHandle <- function(panel, handle) { + si <- snpInfo(handle) + is_in("fileIdx", names(si)) && + identical(rownames(panel), normalizeVariantId(as.character(si$SNP))) +} + +# A panel with no variants, held in memory. `x[integer(0), ]` would drop the +# rows but keep the dosage seed -- a handle carrying every variant's +# metadata, or a backend over the whole file -- which is precisely the +# weight an empty panel exists to shed, so no seed is kept. Where it came +# from stays recorded (.ldRefSource()). `keepSamples` keeps its samples and +# their colData, as a mixture's sampleMap needs; otherwise they go too. +# @noRd +.emptyPanel <- function(panel, keepSamples) { + cols <- if (keepSamples) seq_len(ncol(panel)) else integer(0) + SummarizedExperiment::SummarizedExperiment( + assays = list( + dosage = matrix( + numeric(0), + 0L, + length(cols), + dimnames = list(NULL, colnames(panel)[cols]) + ) + ), + rowRanges = SummarizedExperiment::rowRanges(panel)[integer(0)], + colData = SummarizedExperiment::colData(panel)[cols, , drop = FALSE], + metadata = list_assign( + S4Vectors::metadata(panel), + genotypeSource = .ldRefSource(panel) + ) + ) } # "format @ path" for show methods, which describe where a panel came from -# rather than what is in it. +# rather than what is in it. An LdMatrix came from no file, so it is +# described by its size instead. # @noRd -.ldSketchLabel <- function(x) { - handle <- .ldSketchHandle(x) - glue("{genotypeFormat(handle)} @ {path(handle)}") +.ldRefLabel <- function(x) { + if (.ldIsMatrixRef(x)) { + return(glue("LdMatrix of {length(x)} variants")) + } + if (.ldIsMixtureRef(x)) { + return(glue( + "GenotypeMixture of {length(.gmComponents(x))} panels: ", + "{str_flatten(map_chr(.gmComponents(x), .ldRefLabel), '; ')}" + )) + } + source <- .ldRefSource(x) + if (is.null(source)) { + return(glue("genotype panel of {ncol(x)} samples held in memory")) + } + glue("{source$format} @ {source$path}") } # TRUE for anything that can serve as an LD panel. A bare GenotypeHandle @@ -1228,97 +676,301 @@ loadLdFromGenotype <- function( methods::is(x, "GenotypeHandle") } -# The handle behind an already-open genotype source, or NULL when the value is -# not one. Callers that accept "a panel, a bare handle, or a spec to resolve" -# use this to separate the first two -- which are ready to use -- from the -# third. A panel is the public shape (readGenotypes()); a bare handle is what -# internal callers and objects serialised before the change still carry. +# An already-open genotype source -- a panel, or a bare handle -- as given, +# or NULL when the value is not one. Callers that accept "a panel, a bare +# handle, or a spec to resolve" use this to separate the first two, which are +# ready to use, from the third. A panel is the public shape (readGenotypes()); +# a bare handle is what internal callers and objects serialised before the +# change still carry. # @noRd -.openGenotypeHandle <- function(x) { - if (!.ldIsPanel(x)) { - return(NULL) - } - .ldSketchHandle(x) +.openGenotypeSource <- function(x) { + if (.ldIsPanel(x)) x else NULL } -# ---------- LD sketch: the panel's own view of itself ---------- +# ---------- LD reference: its own view of itself ---------- # -# These read the panel through the SummarizedExperiment interface rather than +# These read a panel through the SummarizedExperiment interface rather than # reaching past it to the GenotypeHandle. The handle is the DelayedArray's # seed -- the READ PATH -- and unwrapping it for metadata leaks that seed into # callers that only ever wanted chrom/pos/alleles or a sample count, which the -# RSE already answers. Reaching for `.ldSketchHandle()` is now reserved for +# RSE already answers. Reaching for `.ldRefHandle()` is now reserved for # what genuinely lives on the handle: file format/path, chromosome shard # routing, the `.afreq` sidecar, and building or pruning the seed itself. # # A bare GenotypeHandle -- what objects serialised before the slot became an # RSE carry -- is projected exactly the way `.genotypeExperiment()` projects -# one, so both shapes answer identically. +# one, so both shapes answer identically. An LdMatrix is itself the GRanges +# of its variants, with the same SNP / A1 / A2 columns. -# The panel's variant ranges: seqnames = chromosome (chr-prefixed), start = -# position, mcols = SNP / A1 / A2. +# The reference's variant ranges: seqnames = chromosome (chr-prefixed), start = +# position, mcols = SNP / A1 / A2 (and AF on an LdMatrix that records it). # @noRd -.ldSketchRanges <- function(x, label = "LD sketch") { +.ldRefRanges <- function(x, label = "LD reference") { # The chokepoint every panel accessor funnels through, so the guard lives # here rather than being repeated at each entry point. Without it a NULL # or non-panel sketch surfaces as "unable to find an inherited method for # 'snpInfo'" from whichever accessor happened to touch it first, which # says nothing about the LD reference being the problem. Callers that - # validate with their own label (`.ldFromSketch`, the ctwas assembler) do + # validate with their own label (`.ldFromRef`, the ctwas assembler) do # so first, so their message wins. - .ldFromSketchValidate(x, label) + .ldFromRefValidate(x, label) + if (.ldIsMatrixRef(x)) { + return(as(x, "GRanges")) + } + if (.ldIsMixtureRef(x)) { + return(.gmRanges(x)) + } if (methods::is(x, "RangedSummarizedExperiment")) { return(SummarizedExperiment::rowRanges(x)) } .genotypeSnpRanges(x, normalizeVariantId(as.character(snpInfo(x)$SNP))) } +# How many variants an LD reference covers. +# @noRd +.ldRefNVariants <- function(x) { + length(.ldRefRanges(x)) +} + # The panel's variant ids in the panel's OWN labelling. This is the mcols # column, not `names()`: the names are normalized ids, while anything keyed on # the panel FILE -- the `.afreq` sidecar, the ctwas snp_map -- has to see the # panel's raw labels. # @noRd -.ldSketchVariantIds <- function(x) { - as.character(S4Vectors::mcols(.ldSketchRanges(x))$SNP) +.ldRefVariantIds <- function(x) { + as.character(S4Vectors::mcols(.ldRefRanges(x))$SNP) } # The panel's variant ids as MATCHING keys: the raw labels, with any id whose # allele slot holds a tag rather than an allele (chr21:13988152:INS:T) re- # rendered from the panel's own A1 / A2 columns, which are correct. Use this # wherever a panel id is matched against summary statistics or another id set, -# and `.ldSketchVariantIds()` only where the file's literal label is wanted. +# and `.ldRefVariantIds()` only where the file's literal label is wanted. # # The repair is what lets an untidily-named panel entry be MATCHED rather than # discarded: harmonization re-keys a surviving variant to the reference-allele # id, so the panel side has to speak the same form or every later id lookup # misses the variant it just harmonized. # @noRd -.ldSketchMatchIds <- function(x) { - mc <- S4Vectors::mcols(.ldSketchRanges(x)) - ids <- as.character(mc$SNP) - if (is.null(mc$A1) || is.null(mc$A2)) { - return(ids) +.ldRefMatchIds <- function(x) { + mc <- S4Vectors::mcols(.ldRefRanges(x)) + ids <- as.character(mc$SNP) + if (is.null(mc$A1) || is.null(mc$A2)) { + return(ids) + } + .repairVariantIds(ids, as.character(mc$A2), as.character(mc$A1)) +} + +# Per-variant chromosome, canonical (no chr prefix). +# @noRd +.ldRefChrom <- function(x) { + canonChrom(as.character(GenomicRanges::seqnames(.ldRefRanges(x)))) +} + +# A panel's sample ids. An LdMatrix has no samples, so asking is a bug in the +# caller rather than something to answer with an empty vector. +# @noRd +.ldRefSampleIds <- function(x) { + if (.ldIsMatrixRef(x) || .ldIsMixtureRef(x)) { + abort( + "Only a single genotype panel has one sample set.", + .internal = TRUE + ) + } + if (methods::is(x, "RangedSummarizedExperiment")) { + return(as.character(colnames(x))) + } + as.character(sampleIds(x)) +} + +# A panel's column count -- its samples, or a sketch's pseudo-samples -- or +# the size an LdMatrix records (NA when it records none). +# @noRd +.ldRefNSamples <- function(x) { + if (.ldIsMatrixRef(x)) { + return(nSamples(x)) + } + if (.ldIsMixtureRef(x)) { + return(.gmPooledN(x, .ldRefNSamples)) + } + length(.ldRefSampleIds(x)) +} + +# The number of real people behind an LD reference, for statistics that count +# them -- a MAC cutoff's allele counts, DENTIST's truncation rank. A genotype +# panel's columns are its samples. A stochastic sketch's columns are B +# pseudo-samples projected from n real ones (the projection cannot raise the +# rank of their LD above n), so its n is the one its projection record holds. +# An LdMatrix records its size, or NA. +# @noRd +.ldRefRealNSamples <- function(x) { + if (.ldIsMatrixRef(x)) { + return(nSamples(x)) + } + if (.ldIsMixtureRef(x)) { + return(sum(map_int(.gmComponents(x), .ldRefRealNSamples))) + } + .ldRefProjection(x)$nSamples %||% .ldRefNSamples(x) +} + +# The number of independent samples a reference's LD is worth, for the +# estimators that correct for LD-estimation noise (ldsc's unbiased r^2, HDL's +# finite reference). A stochastic sketch's LD carries the noise of its n real +# samples and of its B pseudo-samples, so it is worth 1 / (1/n + 1/B). An +# LdMatrix records this directly. +# @noRd +.ldRefNoiseN <- function(x) { + if (.ldIsMatrixRef(x)) { + return(nSamples(x)) + } + if (.ldIsMixtureRef(x)) { + return(.gmPooledN(x, .ldRefNoiseN)) + } + nCols <- .ldRefNSamples(x) + n <- .ldRefProjection(x)$nSamples + if (is.null(n)) { + return(nCols) + } + as.integer(round(1 / (1 / n + 1 / nCols))) +} + +# Each of the reference's variants' A1 frequency, or NULL when it records +# none. An LdMatrix and a stochastic sketch carry an `AF` column; a bare +# sketch handle (an object serialised before the slot became an RSE) answers +# from its sidecar. A panel of real genotypes measures frequencies from its +# dosages instead, so it answers NULL here. +# @noRd +.ldRefAf <- function(x) { + if (.ldIsMixtureRef(x)) { + return(.gmAf(x)) + } + af <- S4Vectors::mcols(.ldRefRanges(x))$AF + if (!is.null(af) || !methods::is(x, "GenotypeHandle")) { + return(af) + } + record <- .ldRefProjection(x) + if (is.null(record)) { + return(NULL) + } + as.numeric(record$af$alt_freq)[match(.ldRefVariantIds(x), record$af$id)] +} + +# The real sample size a step needs, or an error naming the step when the +# reference cannot say -- an LdMatrix built without `nSamples`. +# @noRd +.ldRefRequireNSamples <- function(x, step) { + n <- .ldRefRealNSamples(x) + if (is.na(n)) { + abort(c( + glue("{step} needs the LD reference's sample size."), + i = "Record it with LdMatrix(nSamples = )." + )) + } + n +} + +# A stochastic sketch's projection record -- list(nSamples, af) -- or NULL for +# a panel of real genotypes and for an LdMatrix. A panel built by +# .genotypeExperiment() carries it from construction (see .withLdProjection); +# a bare handle, which only objects serialised before the slot became an RSE +# carry, is read from its sidecar on demand. +# @noRd +.ldRefProjection <- function(x) { + if (is.null(x) || .ldIsMatrixRef(x) || .ldIsMixtureRef(x)) { + return(NULL) + } + if (methods::is(x, "RangedSummarizedExperiment")) { + return(S4Vectors::metadata(x)$ldProjection) + } + .sketchProjectionRecord(.ldRefHandle(x)) +} + +# TRUE for a stochastic sketch: a panel whose columns are pseudo-samples +# projected from real ones, so its dosages are not genotypes and say nothing +# about allele frequency or missingness. +# @noRd +.ldRefIsProjection <- function(x) { + !is.null(.ldRefProjection(x)) +} + +# Read a stochastic sketch's sidecar: its real sample count -- the largest +# OBS_CT, halved (OBS_CT counts alleles, two per diploid sample; variants with +# missing calls count fewer) -- and each variant's real A1 frequency. NULL +# when the handle is not a sketch, i.e. carries no PLINK2-style .afreq beside +# it (in any genotype format) with U_MIN / U_MAX and OBS_CT. +# @noRd +.sketchProjectionRecord <- function(handle) { + if (is.null(handle)) { + return(NULL) } - .repairVariantIds(ids, as.character(mc$A2), as.character(mc$A1)) + .afreqProjectionRecord(.genotypeSourceRecord(handle), snpInfo(handle)$CHR) } -# Per-variant chromosome, canonical (no chr prefix). +# .sketchProjectionRecord() for a genotype source and the chromosomes its +# panel spans, for a panel that reads through no handle. # @noRd -.ldSketchChrom <- function(x) { - canonChrom(as.character(GenomicRanges::seqnames(.ldSketchRanges(x)))) +.afreqProjectionRecord <- function(source, chroms) { + tbls <- compact(map(.afreqPrefixes(source, chroms), .afreqIfStochastic)) + if (length(tbls) == 0L) { + return(NULL) + } + af <- list_rbind(tbls) + list( + nSamples = as.integer(max(as.numeric(af$obs_ct), na.rm = TRUE) %/% 2), + af = select(af, all_of(c("id", "alt_freq"))) + ) } +# Record a stochastic sketch's real sample count and allele frequencies on the +# panel built over it: the count in metadata, the frequencies as an `AF` +# column of rowRanges (the frequency of A1, which PLINK2 writes as ALT). Done +# once, at construction, so nothing downstream re-reads the sidecar -- or, +# worse, measures frequencies off the projected dosages. # @noRd -.ldSketchSampleIds <- function(x) { - if (methods::is(x, "RangedSummarizedExperiment")) { - return(as.character(colnames(x))) +.withLdProjection <- function(panel, record) { + if (is.null(record)) { + return(panel) } - as.character(sampleIds(x)) + rr <- SummarizedExperiment::rowRanges(panel) + mc <- S4Vectors::mcols(rr) + mc$AF <- as.numeric(record$af$alt_freq)[ + match(as.character(mc$SNP), record$af$id) + ] + withAf <- SummarizedExperiment::`rowRanges<-`( + panel, + value = S4Vectors::`mcols<-`(rr, value = mc) + ) + S4Vectors::`metadata<-`( + withAf, + value = c( + S4Vectors::metadata(withAf), + list(ldProjection = list(nSamples = record$nSamples)) + ) + ) +} + +# .withLdProjection() for a panel that reads through no handle -- a VCF or +# GDS panel, or a per-chromosome set of them -- its sidecar found from the +# genotype source the panel records. +# @noRd +.withSourceProjection <- function(panel) { + .withLdProjection( + panel, + .afreqProjectionRecord(.ldRefSource(panel), .ldRefChrom(panel)) + ) } +# The .afreq at `prefix` when it is a stochastic sketch's (it carries U_MIN / +# U_MAX) and records OBS_CT, else NULL. A malformed sidecar reads as absent, +# as it does for the panel filter. # @noRd -.ldSketchNSamples <- function(x) { - length(.ldSketchSampleIds(x)) +#' @importFrom rlang try_fetch +.afreqIfStochastic <- function(prefix) { + af <- try_fetch(readAfreq(prefix), error = function(cnd) NULL) + if (is.null(af) || !all(is_in(c("u_min", "obs_ct"), colnames(af)))) { + return(NULL) + } + af } # Dosage for a variant subset, samples x variants. @@ -1329,9 +981,15 @@ loadLdFromGenotype <- function( # delegates to that same function with `meanImpute = FALSE`, so imputation is # layered on here rather than pushed down. # @noRd -.ldSketchDosage <- function(x, snpIdx, meanImpute = TRUE) { - # The other primitive that does not pass through `.ldSketchRanges()`. - .ldFromSketchValidate(x, "LD sketch") +.ldRefDosage <- function(x, snpIdx, meanImpute = TRUE) { + # The other primitive that does not pass through `.ldRefRanges()`. + .ldFromRefValidate(x, "LD reference") + if (.ldIsMatrixRef(x) || .ldIsMixtureRef(x)) { + abort( + "Only a single genotype panel has dosages to read.", + .internal = TRUE + ) + } if (!methods::is(x, "RangedSummarizedExperiment")) { return(.dosageMatrix(x, snpIdx, meanImpute = meanImpute)) } @@ -1341,39 +999,43 @@ loadLdFromGenotype <- function( if (meanImpute) .qtlMeanImpute(dosage) else dosage } -.ldFromSketchValidate <- function(ldSketch, label) { - if (is.null(ldSketch)) { +# Require a non-NULL LD reference: a genotype panel (a +# RangedSummarizedExperiment, or a bare GenotypeHandle) or an LdMatrix. +# @noRd +.ldFromRefValidate <- function(ldReference, label) { + if (is.null(ldReference)) { msg <- glue( - "{label}: the SumStats/collection carries no ldSketch ", - "(ldSketch = NULL); this step needs an LD reference." + "{label}: the SumStats/collection carries no ldReference ", + "(ldReference = NULL); this step needs an LD reference." ) abort(msg) } # A bare GenotypeHandle is still accepted: that is what objects # serialised before the slot became an RSE carry. - if (!.ldIsPanel(ldSketch)) { + if (!.ldIsReference(ldReference)) { msg <- glue( - "{label}: ldSketch must be a genotype panel ", - "(RangedSummarizedExperiment or GenotypeHandle)." + "{label}: ldReference must be a genotype panel ", + "(RangedSummarizedExperiment or GenotypeHandle), a ", + "GenotypeMixture or an LdMatrix." ) abort(msg) } } # Match requested ids to the panel; NULL if none match. Returns kept ids/order. -.ldFromSketchMatch <- function(ldSketch, variantIds, label, onMissing) { +.ldFromRefMatch <- function(ldReference, variantIds, label, onMissing) { # Match by (chrom, pos, allele) tuple with an exact id-string fallback for # rsID panels; the caller's original ids and order are preserved. m <- matchVariants( variantIds, - .ldSketchMatchIds(ldSketch), + .ldRefMatchIds(ldReference), removeStrandAmbiguous = FALSE ) nMissing <- length(variantIds) - length(m$idxA) if (nMissing > 0L && onMissing == "error") { msg <- glue( "{label}: {nMissing} variant id(s) not present in the LD ", - "sketch panel." + "reference." ) abort(msg) } @@ -1388,23 +1050,44 @@ loadLdFromGenotype <- function( ) } -.ldFromSketch <- function( - ldSketch, +# The LD matrix over a specified variant subset of an LD reference: computed +# from a genotype panel's dosages, or read out of an LdMatrix. Called directly +# by +# twasWeightsPipeline, fineMappingPipeline, jointEngine, +# causalInferencePipeline, colocboostPipeline and the coloc / summaryStatsQc +# paths, which differ only in their error message prefix and in whether +# variants absent from the panel raise an error or get silently dropped -- +# both of which are arguments here rather than a per-pipeline wrapper. +# +# Arguments: +# ldReference A genotype panel (RangedSummarizedExperiment, or a bare +# GenotypeHandle) or an LdMatrix. +# variantIds Character vector of SNP IDs to extract. +# label Error-message prefix, e.g. "twasWeightsPipeline". +# onMissing "error" (default) -> any unmatched id stops the call; +# "drop" -> unmatched ids are silently filtered. +# When "drop" leaves no surviving variants the function +# returns NULL. +# +# Returns: +# A `length(variantIds) x length(variantIds)` symmetric LD matrix with +# rows/cols named by the (possibly filtered) `variantIds`. +# With `onMissing = "drop"` the returned matrix carries an attribute +# `"keptVariantIds"` so callers can recover which ids survived. +# @noRd +.ldFromRef <- function( + ldReference, variantIds, - label = ".ldFromSketch", + label = ".ldFromRef", onMissing = c("error", "drop") ) { - .ldFromSketchValidate(ldSketch, label) + .ldFromRefValidate(ldReference, label) onMissing <- arg_match(onMissing) - matched <- .ldFromSketchMatch(ldSketch, variantIds, label, onMissing) + matched <- .ldFromRefMatch(ldReference, variantIds, label, onMissing) if (is.null(matched)) { return(NULL) } - ldMat <- computeLd( - ldSketch, - method = "sample", - snpIdx = matched$idx - ) + ldMat <- .ldRefLdAt(ldReference, matched$idx) # The match above is allele-aware, so a panel entry whose alleles are # swapped relative to the caller's id still matches -- but the dosage it # returns counts the OTHER allele, which negates every correlation that @@ -1424,7 +1107,238 @@ loadLdFromGenotype <- function( named } -# ---------- LD sketch: per-variant panel statistics and filtering ---------- +# The factor of a genotype reference's LD over `variantIds` (see +# .ldRefFactor()), matched and allele-aligned exactly as .ldFromRef() does: +# columns follow the caller's ids and are named by them, and a column whose +# panel alleles are swapped is negated, so crossprod(F) / (nrow(F) - 1) is +# .ldFromRef()'s matrix. An LdMatrix has no factor, so callers send it down +# the matrix path instead. +# @noRd +.ldFactorFromRef <- function( + ldReference, + variantIds, + label = ".ldFactorFromRef", + onMissing = c("error", "drop") +) { + .ldFromRefValidate(ldReference, label) + onMissing <- arg_match(onMissing) + matched <- .ldFromRefMatch(ldReference, variantIds, label, onMissing) + if (is.null(matched)) { + return(NULL) + } + factor <- .ldRefFactor(ldReference, matched$idx) + signed <- if (any(matched$sign < 0)) { + sweep(factor, 2L, matched$sign, `*`) + } else { + factor + } + named <- `dimnames<-`(signed, list(NULL, matched$keptIds)) + if (onMissing == "drop") { + return(`attr<-`(named, "keptVariantIds", matched$keptIds)) + } + named +} + +# The LD among the reference's variants at `idx`, in the reference's own +# allele coding: the sample correlation of a panel's dosages, or the +# corresponding block of an LdMatrix. +# @noRd +.ldRefLdAt <- function(ldReference, idx) { + if (.ldIsMatrixRef(ldReference)) { + return(unname(ldMatrix(ldReference)[idx, idx, drop = FALSE])) + } + if (.ldIsMixtureRef(ldReference)) { + return(.gmLdAt(ldReference, idx)) + } + computeLd(ldReference, method = "sample", snpIdx = idx) +} + +# A factor F of a genotype reference's LD over `idx`: a matrix with +# zero-mean columns whose crossprod(F) / (nrow(F) - 1) is exactly the LD +# .ldRefLdAt() returns, so every computation on that LD -- quadratic forms, +# products, columns, eigenvectors -- can run on F without forming the p x p +# matrix. Its rows behave as samples, so an engine that correlates them +# itself recovers the same LD. A panel's factor is its standardized dosages; +# a mixture's stacks its panels' (.gmFactor()). +# @noRd +.ldRefFactor <- function(ldReference, idx) { + if (.ldIsMixtureRef(ldReference)) { + return(.gmFactor(ldReference, idx)) + } + .ldFactorFromDosage(.ldRefDosage(ldReference, idx, meanImpute = TRUE)) +} + +# A panel's mean-imputed, standardized dosages over `idx`, with a monomorphic +# column left at zero: the blocks a mixture's factor is stacked from. +# @noRd +.ldRefStandardized <- function(ldReference, idx) { + .ldStandardize(.ldRefDosage(ldReference, idx, meanImpute = TRUE)) +} + +# The factor of a dosage matrix's (samples x variants) LD, under +# .ldRefFactor()'s contract. A monomorphic variant is independent of every +# other with unit variance in computeLd()'s LD, while its standardized +# column is all zero; two padding rows of +/- sqrt((m - 1) / 2) restore its +# variance without correlating it with anything or moving any column's mean, +# and the other rows are rescaled for the m rows the factor then has. +# @noRd +.ldFactorFromDosage <- function(X) { + standardized <- .ldStandardize(X) + dead <- which(colSums(standardized^2) == 0) + if (length(dead) == 0L) { + return(standardized) + } + n <- nrow(standardized) + m <- n + 2L * length(dead) + rbind( + standardized * sqrt((m - 1) / (n - 1)), + .ldPaddingRows(dead, ncol(standardized), sqrt((m - 1) / 2)) + ) +} + +# Mean-imputed columns, centred and scaled to unit variance (n - 1 +# denominator), as scale() would make them, except that a constant column +# stays zero rather than turning into NaN. +# @noRd +.ldStandardize <- function(X) { + imputed <- if (anyNA(X)) .ldMeanImputeColumns(X) else X + centred <- sweep(imputed, 2L, colMeans(imputed)) + sds <- sqrt(colSums(centred^2) / (nrow(centred) - 1)) + sweep(centred, 2L, replace(sds, sds == 0, 1), `/`) +} + +# Two rows per column in `cols`, holding +value and -value in that column +# and zero elsewhere. They add 2 value^2 to the column's sum of squares and +# nothing to its mean or to any crossproduct. +# @noRd +.ldPaddingRows <- function(cols, p, value) { + rows <- matrix(0, 2L * length(cols), p) + i <- seq_along(cols) + rows[cbind(2L * i - 1L, cols)] <- value + rows[cbind(2L * i, cols)] <- -value + rows +} + +# The eigendecomposition of the LD R = crossprod(F) / (m - 1), from the thin +# SVD of its factor F (m x p) rather than from R: the eigenvalues d^2 / (m - 1) +# and the right singular vectors, for the min(m, p) directions the SVD +# returns, largest first. R's other p - min(m, p) eigenvalues are exactly +# zero; `nNull` counts them, for an estimator that counts every direction. +# @noRd +.ldFactorEigen <- function(F) { + s <- svd(F, nu = 0L) + list( + values = s$d^2 / (nrow(F) - 1), + vectors = s$v, + nNull = ncol(F) - length(s$d) + ) +} + +# ---------- LD rows a stripe at a time ---------- +# +# An LD source is one block's LD in any of three forms: the matrix itself, +# list(R = ); a factor of it, list(F = ) with R = crossprod(F) / (m - 1); or +# an eigendecomposition, list(vectors = , values = ) with R = V diag(values) +# V'. The helpers below read R's rows from any of them, so a computation over +# R's rows never needs the matrix whole. + +# How many of R's rows a stripe holds. +# @noRd +.ldStripeSize <- function() 256L + +# The number of variants an LD source covers. +# @noRd +.ldSourceSize <- function(ld) { + if (!is.null(ld$R)) { + return(nrow(ld$R)) + } + if (!is.null(ld$F)) { + return(ncol(ld$F)) + } + nrow(ld$vectors) +} + +# Rows `rows` of an LD source's R, without forming the rest. +# @noRd +.ldSourceRows <- function(ld, rows) { + if (!is.null(ld$R)) { + return(ld$R[rows, , drop = FALSE]) + } + if (!is.null(ld$F)) { + return( + crossprod(ld$F[, rows, drop = FALSE], ld$F) / (nrow(ld$F) - 1) + ) + } + scaled <- sweep(ld$vectors[rows, , drop = FALSE], 2L, ld$values, "*") + tcrossprod(scaled, ld$vectors) +} + +# (R o R) A -- R squared element-wise, times A -- for an LD source: column a +# of the result is the LD score sum_k r^2_jk a_k. The element-wise square +# does not inherit a factor's low rank (R has rank below m, R o R is in +# general full rank), so no product through the factor serves every column +# of A at once: one Gram matrix F diag(a) F' per column would cost m^2 p for +# each. Instead R's rows are formed a stripe at a time, squared, and +# multiplied by all of A, which costs p^2 (m + ncol(A)) and holds one stripe. +# A stored matrix is used as it is. +# @noRd +.ldSquaredProduct <- function(ld, A) { + if (!is.null(ld$R)) { + return((ld$R^2) %*% A) + } + p <- .ldSourceSize(ld) + starts <- seq.int(1L, p, by = .ldStripeSize()) + stripes <- map(starts, .ldSquaredProductStripe, ld = ld, A = A, p = p) + exec(rbind, !!!stripes) +} + +# @noRd +.ldSquaredProductStripe <- function(start, ld, A, p) { + rows <- seq.int(start, min(start + .ldStripeSize() - 1L, p)) + .ldSourceRows(ld, rows)^2 %*% A +} + +# `ldReference` cut to the variants `variantIds` names (matched as +# .ldFromRef() matches them), for a caller that reads the same block's LD +# several times: a panel's dosage is read from its files once, here, and held +# in memory, rather than read again by every reader. An LdMatrix is cut to +# those variants, and a GenotypeMixture is cut with its panels left to read +# as they are needed. +# @noRd +.ldRefInMemory <- function(ldReference, variantIds, label) { + .ldFromRefValidate(ldReference, label) + matched <- .ldFromRefMatch(ldReference, variantIds, label, "error") + rows <- sort(unique(matched$idx)) + if (!methods::is(ldReference, "RangedSummarizedExperiment")) { + if (methods::is(ldReference, "GenotypeHandle")) { + return(ldReference) + } + return(ldReference[rows]) + } + block <- ldReference[rows, ] + SummarizedExperiment::`assay<-`( + block, + "dosage", + withDimnames = FALSE, + value = as.matrix(SummarizedExperiment::assay( + block, + "dosage", + withDimnames = FALSE + )) + ) +} + +# b' R b for each column b of B, from an LD matrix or a factor of it: +# ||F b||^2 / (m - 1), never forming R. +# @noRd +.ldQuadForms <- function(ld, B) { + if (!is.null(ld$R)) { + return(colSums(B * (ld$R %*% B))) + } + colSums((ld$F %*% B)^2) / (nrow(ld$F) - 1) +} + +# ---------- LD reference: per-variant statistics and filtering ---------- # Per-variant minor allele frequency and missingness rate from panel dosage. # @@ -1459,19 +1373,23 @@ loadLdFromGenotype <- function( max(mafCutoff, macAsMaf) } -# The .afreq stems to read for a panel: the handle's own stem, or one per -# chromosome the panel actually spans. A sharded handle lists every -# chromosome in its manifest, and reading the shards the summary statistics -# never touch is the cost per-chromosome sketch trimming exists to avoid. +# The .afreq stems to read for a genotype source: its file's, or one per +# chromosome of `chroms` (those its panel spans) for a per-chromosome +# manifest. A manifest lists every chromosome, and reading the shards the +# summary statistics never touch is the cost per-chromosome sketch trimming +# exists to avoid. None for a panel that reads no file. # @noRd -.panelAfreqPrefixes <- function(handle) { - chromPaths <- .genotypeChromPaths(handle) +.afreqPrefixes <- function(source, chroms) { + if (is.null(source)) { + return(character(0)) + } + chromPaths <- source$chromPaths %||% character(0) if (length(chromPaths) == 0L) { - return(.genotypeReadPath(handle)) + return(.genotypeStem(.resolveGenotypeResourcePath(source$path))) } - spanned <- unique(canonChrom(as.character(snpInfo(handle)$CHR))) + spanned <- unique(canonChrom(as.character(chroms))) paths <- unname(chromPaths[is_in(names(chromPaths), spanned)]) - map_chr(paths, .resolveGenotypeResourcePath) + .genotypeStem(map_chr(paths, .resolveGenotypeResourcePath)) } # One shard's id/alt_freq pairs, or NULL when the sidecar is missing or does @@ -1487,18 +1405,16 @@ loadLdFromGenotype <- function( select(af, all_of(c("id", "alt_freq"))) } -# Panel minor allele frequency for `variantIds` read from the PLINK2 .afreq -# sidecar, or NULL when the sidecar cannot answer for every id. +# Panel minor allele frequency for `variantIds` read from the PLINK2-style +# .afreq sidecar beside the panel's file, in any genotype format, or NULL +# when the sidecar cannot answer for every id. # # Refusing a PARTIAL sidecar is deliberate: the dosage path treats a variant # it cannot measure as a drop, so a fast path that quietly kept the ids # .afreq happens to omit would disagree with it about the same variant. # @noRd -.panelAfreqMaf <- function(handle, variantIds) { - if (genotypeFormat(handle) != "plink2") { - return(NULL) - } - tbls <- compact(map(.panelAfreqPrefixes(handle), .panelAfreqTable)) +.panelAfreqMaf <- function(source, chroms, variantIds) { + tbls <- compact(map(.afreqPrefixes(source, chroms), .panelAfreqTable)) if (length(tbls) == 0L) { return(NULL) } @@ -1511,54 +1427,160 @@ loadLdFromGenotype <- function( pmin(altFreq, 1 - altFreq) } -# TRUE for each matched panel variant that fails the cutoffs. -# -# Allele frequency alone answers MAF and MAC, so with no missingness cutoff -# set the .afreq sidecar decides the whole mask without materializing panel -# dosage -- which is what makes the filter affordable on a panel far larger -# than the analysed variant set. Missingness is not derivable from the -# sidecar (its observation count is an ALLELE count, whose ploidy the mask -# would have to guess), so an imissCutoff always takes the dosage path. -# @noRd -.panelDropMask <- function(ldSketch, matched, panelFilterParam) { +# TRUE for each matched variant of the LD reference that fails the cutoffs. +# The statistics come from `.ldRefVariantStats()`, which knows where each +# kind of reference keeps them truthfully; missingness is only asked for when +# a missingness cutoff is set. +# @noRd +.panelDropMask <- function(ldReference, matched, panelFilterParam) { imissCutoff <- panelFilterParam$imissCutoff - if (imissCutoff >= 1) { - # Keyed on the PANEL's own variant labels, not the caller's: .afreq - # carries the .pvar ids, while `keptIds` is whatever id form the - # caller asked in (normalized, most often). - panelIds <- .ldSketchVariantIds(ldSketch)[matched$idx] - # The handle stays for this one read: the sidecar is a file beside - # the genotypes, which only the seed knows how to find. - maf <- .panelAfreqMaf(.ldSketchHandle(ldSketch), panelIds) - if (!is.null(maf)) { - effMaf <- .panelEffectiveMaf( - panelFilterParam$mafCutoff, - panelFilterParam$macCutoff, - .ldSketchNSamples(ldSketch) - ) - return(is.na(maf) | maf < effMaf) - } - } - dosage <- .ldSketchDosage(ldSketch, matched$idx, meanImpute = FALSE) - stats <- .panelVariantStats(dosage) + stats <- .ldRefVariantStats( + ldReference, + matched$idx, + needMissing = imissCutoff < 1, + step = "The LD-panel filter" + ) effMaf <- .panelEffectiveMaf( panelFilterParam$mafCutoff, panelFilterParam$macCutoff, - nrow(dosage) + .ldRefMacSamples(ldReference, panelFilterParam$macCutoff) ) - is.na(stats$maf) | stats$maf < effMaf | stats$missRate > imissCutoff + fails <- is.na(stats$maf) | stats$maf < effMaf + if (is.null(stats$missRate)) { + return(fails) + } + fails | stats$missRate > imissCutoff +} + +# Per-variant MAF -- and missingness, when `needMissing` -- for the +# reference's variants at `idx`, from wherever the reference records them +# truthfully: +# +# genotype panel the .afreq sidecar when it answers for every variant and +# no missingness is wanted (no dosage need be read, which is +# what keeps the filter affordable on a panel far larger +# than the analysed variant set); the dosages otherwise +# sketch the real frequencies its projection record holds. Its +# dosages are projections taken after mean-filling, so they +# carry neither frequencies nor missingness +# LdMatrix its AF column; it has no genotypes to be missing +# +# `step` names the caller in the error when the reference cannot answer. +# @noRd +.ldRefVariantStats <- function(ldReference, idx, needMissing, step) { + if (.ldIsMixtureRef(ldReference)) { + return(.gmVariantStats(ldReference, idx, needMissing, step)) + } + if (.ldIsMatrixRef(ldReference) || .ldRefIsProjection(ldReference)) { + return(.ldRefRecordedStats(ldReference, idx, needMissing, step)) + } + if (!needMissing) { + # Keyed on the PANEL's own variant labels: .afreq carries the .pvar + # ids. The handle stays for this one read, since the sidecar is a + # file beside the genotypes, which only the seed knows how to find. + panelIds <- .ldRefVariantIds(ldReference)[idx] + maf <- .panelAfreqMaf( + .ldRefSource(ldReference), + .ldRefChrom(ldReference), + panelIds + ) + if (!is.null(maf)) { + return(list(maf = maf, missRate = NULL)) + } + } + .panelVariantStats(.ldRefDosage(ldReference, idx, meanImpute = FALSE)) +} + +# Frequencies from a reference that records them rather than measuring them: +# an LdMatrix or a stochastic sketch. Neither can say how often a genotype is +# missing, so a missingness cutoff is refused rather than silently skipped. +# @noRd +.ldRefRecordedStats <- function(ldReference, idx, needMissing, step) { + what <- if (.ldIsMatrixRef(ldReference)) { + "an LdMatrix, which has no genotypes" + } else { + "a stochastic sketch, whose dosages are projections" + } + if (needMissing) { + abort(c( + glue( + "{step} needs genotype missingness, and the LD reference is ", + "{what}." + ), + i = "Leave its missingness cutoff unset." + )) + } + af <- .ldRefAf(ldReference) + if (is.null(af)) { + abort(c( + glue( + "{step} needs allele frequencies, and the LD reference ", + "records none." + ), + i = "Give the LdMatrix's variants an `AF` column." + )) + } + af <- as.numeric(af)[idx] + list(maf = pmin(af, 1 - af), missRate = NULL) +} + +# Per-variant genotype variance at `idx`, for scaling non-standardized weights +# to the correlation scale. A panel of real genotypes measures it on its +# (mean-imputed) dosages. A sketch or an LdMatrix has no genotypes to measure, +# so it gives 2p(1 - p) from its recorded A1 frequency -- the dosage variance +# under Hardy-Weinberg -- or NA when it records none. +# @noRd +.ldRefVariance <- function(ldReference, idx) { + if (.ldIsMixtureRef(ldReference)) { + return(.gmVariance(ldReference, idx)) + } + if (.ldIsMatrixRef(ldReference) || .ldRefIsProjection(ldReference)) { + af <- .ldRefAf(ldReference) + if (is.null(af)) { + return(rep(NA_real_, length(idx))) + } + af <- as.numeric(af)[idx] + return(2 * af * (1 - af)) + } + geno <- .ldRefDosage(ldReference, idx, meanImpute = TRUE) + apply(geno, 2, stats::var, na.rm = TRUE) +} + +# The real sample count a MAC cutoff divides by, or 0 when no MAC cutoff is +# set (which .panelEffectiveMaf() reads as "no MAC term"). A mixture of +# panels has no single count, so a MAC cutoff on one is refused. +# @noRd +.ldRefMacSamples <- function(ldReference, macCutoff) { + if (macCutoff <= 0) { + return(0L) + } + # A mixture's statistics are its panels' worst (see .gmVariantStats()), so + # its counts are judged against its smallest panel. + if (.ldIsMixtureRef(ldReference)) { + return(min(map_int(.gmComponents(ldReference), .ldRefRealNSamples))) + } + if (.ldIsMatrixRef(ldReference) && !is.null(mixtureWeights(ldReference))) { + abort(c( + str_c( + "A MAC cutoff counts one panel's alleles, and the LdMatrix ", + "is a mixture." + ), + i = "Use `mafCutoff` instead." + )) + } + .ldRefRequireNSamples(ldReference, "A MAC cutoff") } # The subset of `variantIds` whose LD-panel genotypes clear the cutoffs, # returned in the caller's order. # # Variants absent from the panel are passed through untouched. Whether a -# missing variant is an error or is silently dropped belongs to `.ldFromSketch` +# missing variant is an error or is silently dropped belongs to `.ldFromRef` # (its `onMissing`), and deciding it a second time here would let the two # disagree about the same variant. # @noRd .panelVariantFilter <- function( - ldSketch, + ldReference, variantIds, panelFilterParam = PanelFilterParam(), label = ".panelVariantFilter" @@ -1569,25 +1591,25 @@ loadLdFromGenotype <- function( if (is.null(cutoffs)) { return(variantIds) } - if (is.null(ldSketch) || length(variantIds) == 0L) { + if (is.null(ldReference) || length(variantIds) == 0L) { return(variantIds) } - matched <- .ldFromSketchMatch(ldSketch, variantIds, label, "drop") + matched <- .ldFromRefMatch(ldReference, variantIds, label, "drop") if (is.null(matched)) { return(variantIds) } - drop <- .panelDropMask(ldSketch, matched, cutoffs) + drop <- .panelDropMask(ldReference, matched, cutoffs) variantIds[!is_in(variantIds, matched$keptIds[drop])] } # Row mask for the variants clearing the LD-panel cutoffs, reporting how many # were dropped. A no-op when no cutoff is set. # @noRd -.panelKeepMask <- function(variantIds, ldSketch, cutoffs, label) { - if (is.null(ldSketch) || is.null(cutoffs)) { +.panelKeepMask <- function(variantIds, ldReference, cutoffs, label) { + if (is.null(ldReference) || is.null(cutoffs)) { return(rep(TRUE, length(variantIds))) } - kept <- .panelVariantFilter(ldSketch, variantIds, cutoffs, label = label) + kept <- .panelVariantFilter(ldReference, variantIds, cutoffs, label = label) keep <- is_in(variantIds, kept) nDropped <- sum(!keep) if (nDropped > 0L) { @@ -1615,11 +1637,12 @@ loadLdFromGenotype <- function( } list(mafCutoff = maf, macCutoff = mac, imissCutoff = imiss) } -# ---------- LD sketch: cross-pipeline LD-panel compatibility check ---------- +# ---------- LD reference: cross-pipeline compatibility check ---------- -# Internal: assert that two LD sketches describe the same reference panel -- -# the same samples, and the same allele coding (A1/A2 in the same orientation) -# on the variants they share. The SNP label is not compared, so a pure +# Internal: assert that two LD references describe the same reference panel -- +# the same samples (for genotype panels) or the same LD (for LdMatrix +# objects), and the same allele coding (A1/A2 in the same orientation) on the +# variants they share. The SNP label is not compared, so a pure # chr-prefix difference does not fail; an allele swap still does, since it # means the two panels code their LD in opposite directions. # @@ -1642,11 +1665,11 @@ loadLdFromGenotype <- function( # "twasWeights" or "fineMappingResult"); it is woven into the error # messages when provided. `pipelineName` prefixes every error so the # failure source remains discoverable. -# --- .requireMatchingLdSketches helpers ------------------------------------- +# --- .requireMatchingLdRefs helpers ------------------------------------- # Null handling: TRUE if the caller should return early (qtl NULL, or gwas NULL # under a lenient policy); errors when a non-NULL qtl faces a NULL gwas sketch. -.ldSketchNullGuard <- function(qtlLd, gwasLd, pipelineName, label, nullPolicy) { +.ldRefNullGuard <- function(qtlLd, gwasLd, pipelineName, label, nullPolicy) { if (is.null(qtlLd)) { return(TRUE) } @@ -1655,12 +1678,12 @@ loadLdFromGenotype <- function( return(TRUE) } labelPart <- if (!is.null(label)) { - glue("ldSketch on `{label}` is non-NULL ") + glue("ldReference on `{label}` is non-NULL ") } else { - "qtl ldSketch is non-NULL " + "qtl ldReference is non-NULL " } msg <- glue( - "{pipelineName}: {labelPart}but the GWAS ldSketch is NULL." + "{pipelineName}: {labelPart}but the GWAS ldReference is NULL." ) abort(msg) } @@ -1670,32 +1693,54 @@ loadLdFromGenotype <- function( # Both must be genotype panels. Panel SIZE is deliberately NOT compared: two # objects that share one LD sketch stop carrying identical variant sets as soon # as they are QC'd separately, because each object's sketch is trimmed to its -# own position span at load (`.subsetSketchToRange`) and to its own surviving -# variants at the end of QC (`.subsetSketchToIds`). A QTL and a GWAS collection +# own position span at load (`.subsetLdRefToRange`) and to its own surviving +# variants at the end of QC (`.subsetLdRefToIds`). A QTL and a GWAS collection # put through `summaryStatsQc` independently therefore diverge by construction, # which is the normal case rather than a mistake. Every downstream LD lookup -# matches by variant id (`.ldFromSketch`), never by position in the panel, so +# matches by variant id (`.ldFromRef`), never by position in the panel, so # divergent variant sets cost only the variants one side lacks. What would not # be harmless -- two genuinely different reference panels -- is what -# `.ldSketchCheckContent` catches, by sample set and by allele coding. -.ldSketchCheckShape <- function(qtlLd, gwasLd, pipelineName, between) { - if (!.ldIsPanel(qtlLd) || !.ldIsPanel(gwasLd)) { +# `.ldRefCheckContent` catches, by sample set and by allele coding. +.ldRefCheckShape <- function(qtlLd, gwasLd, pipelineName, between) { + if (!.ldIsReference(qtlLd) || !.ldIsReference(gwasLd)) { + msg <- glue( + "{pipelineName}: ldReference slots{between} must both be genotype ", + "panels or LdMatrix objects for the cross-pipeline LD reference ", + "check." + ) + abort(msg) + } + kinds <- c(.ldRefKind(qtlLd), .ldRefKind(gwasLd)) + if (kinds[[1L]] != kinds[[2L]]) { msg <- glue( - "{pipelineName}: ldSketch slots{between} must both be genotype ", - "panels for the cross-pipeline LD reference check." + "{pipelineName}: one side's ldReference is {kinds[[1L]]} and ", + "the other's {kinds[[2L]]}{between}; use the same LD reference ", + "on both." ) abort(msg) } } +# What kind of LD reference `x` is, in words, for messages that compare two. +# @noRd +.ldRefKind <- function(x) { + if (.ldIsMatrixRef(x)) { + return("an LdMatrix") + } + if (.ldIsMixtureRef(x)) { + return("a GenotypeMixture") + } + "a genotype panel" +} + # The (chrom, position, allele-pair) key the two panels are compared on. The # allele pair is order-insensitive, so an A1/A2 swap keys to the SAME variant # and is then reported as an allele-coding difference rather than looking like # two unrelated variants that happen not to overlap. A panel carrying no allele # columns falls back to chrom:position, which is all it can be keyed on. # @noRd -.ldSketchVariantKeys <- function(x) { - gr <- .ldSketchRanges(x) +.ldRefVariantKeys <- function(x) { + gr <- .ldRefRanges(x) mc <- S4Vectors::mcols(gr) stem <- str_c( canonChrom(as.character(GenomicRanges::seqnames(gr))), @@ -1717,8 +1762,8 @@ loadLdFromGenotype <- function( # The panel's A1 (effect / counted) allele, which fixes the sign of every # correlation the variant takes part in. # @noRd -.ldSketchA1 <- function(x) { - as.character(S4Vectors::mcols(.ldSketchRanges(x))$A1) +.ldRefA1 <- function(x) { + as.character(S4Vectors::mcols(.ldRefRanges(x))$A1) } # A shared variant whose A1/A2 are swapped between the panels is the same @@ -1726,7 +1771,7 @@ loadLdFromGenotype <- function( # in sign wherever it appears. That is a different reference, not a trimming # difference, and it is an error. # @noRd -.ldSketchCheckAlleleCoding <- function( +.ldRefCheckAlleleCoding <- function( qtlLd, gwasLd, qIdx, @@ -1734,18 +1779,18 @@ loadLdFromGenotype <- function( pipelineName, between ) { - qA1 <- .ldSketchA1(qtlLd)[qIdx] - gA1 <- .ldSketchA1(gwasLd)[gIdx] + qA1 <- .ldRefA1(qtlLd)[qIdx] + gA1 <- .ldRefA1(gwasLd)[gIdx] if (length(qA1) == 0L || length(gA1) == 0L) { return(invisible(NULL)) } nSwapped <- sum(qA1 != gA1, na.rm = TRUE) if (nSwapped > 0L) { msg <- glue( - "{pipelineName}: {nSwapped} variant(s) present in both ldSketch ", - "panels carry swapped A1/A2 alleles{between}, so the two panels ", - "code their LD in opposite directions; use the same ldSketch on ", - "both." + "{pipelineName}: {nSwapped} variant(s) present in both ", + "ldReference panels carry swapped A1/A2 alleles{between}, so the ", + "two panels code their LD in opposite directions; use the same ", + "ldReference on both." ) abort(msg) } @@ -1756,20 +1801,21 @@ loadLdFromGenotype <- function( # so it is reported once per session rather than on every call: ctwasPipeline # and colocboostPipeline run this check once per region / per bundle. # @noRd -.ldSketchReportOverlap <- function(nQ, nG, nShared, pipelineName, between) { +.ldRefReportOverlap <- function(nQ, nG, nShared, pipelineName, between) { if (nShared == nQ && nShared == nG) { return(invisible(NULL)) } msg <- glue( - "{pipelineName}: the two ldSketch panels share {nShared} variant(s) ", - "of {nQ} (QTL side) and {nG} (GWAS side){between}. LD is looked up ", - "per variant, so only the shared ones contribute. Differing variant ", - "sets are expected when the two sides were QC'd separately." + "{pipelineName}: the two ldReference panels share {nShared} ", + "variant(s) of {nQ} (QTL side) and {nG} (GWAS side){between}. LD is ", + "looked up per variant, so only the shared ones contribute. ", + "Differing variant sets are expected when the two sides were QC'd ", + "separately." ) warn( msg, .frequency = "once", - .frequency_id = str_c("pecotmrLdSketchOverlap-", pipelineName) + .frequency_id = str_c("pecotmrLdReferenceOverlap-", pipelineName) ) invisible(NULL) } @@ -1778,9 +1824,9 @@ loadLdFromGenotype <- function( # fails is no overlap at all (two unrelated panels) or a shared variant whose # alleles are swapped. # @noRd -.ldSketchCheckOverlap <- function(qtlLd, gwasLd, pipelineName, between) { - qKey <- .ldSketchVariantKeys(qtlLd) - gKey <- .ldSketchVariantKeys(gwasLd) +.ldRefCheckOverlap <- function(qtlLd, gwasLd, pipelineName, between) { + qKey <- .ldRefVariantKeys(qtlLd) + gKey <- .ldRefVariantKeys(gwasLd) # An emptied panel -- what a zero-variant object carries, since it # references no LD -- contradicts nothing, so there is nothing to compare. if (length(qKey) == 0L || length(gKey) == 0L) { @@ -1790,13 +1836,13 @@ loadLdFromGenotype <- function( shared <- which(!is.na(idx)) if (length(shared) == 0L) { msg <- glue( - "{pipelineName}: the two ldSketch panels share no variant", + "{pipelineName}: the two ldReference panels share no variant", "{between} ({length(qKey)} vs {length(gKey)} variants); they ", "describe different LD references." ) abort(msg) } - .ldSketchCheckAlleleCoding( + .ldRefCheckAlleleCoding( qtlLd, gwasLd, shared, @@ -1804,248 +1850,118 @@ loadLdFromGenotype <- function( pipelineName, between ) - .ldSketchReportOverlap( + .ldRefReportOverlap( length(qKey), length(gKey), length(shared), pipelineName, between ) + invisible(list(qIdx = shared, gIdx = idx[shared])) } -# Panels must describe the same reference panel: the same samples, and the same -# allele coding on the variants they share. Their variant SETS need not agree -# -- see `.ldSketchCheckShape` for why. -.ldSketchCheckContent <- function(qtlLd, gwasLd, pipelineName, between) { - qIds <- .ldSketchSampleIds(qtlLd) - gIds <- .ldSketchSampleIds(gwasLd) - if (!identical(qIds, gIds)) { +# Two LdMatrix objects describe the same LD reference when they agree on the +# LD among the variants they share -- what two QC'd subsets of one matrix do, +# and two unrelated matrices do not. Checked on an evenly spaced subset of the +# shared variants, as validity checks symmetry, so the cost does not grow with +# the overlap. +# @noRd +.ldRefCheckSameLd <- function(qtlLd, gwasLd, shared, pipelineName, between) { + if (is.null(shared)) { + return(invisible(NULL)) + } + if (!.ldmAgreesOn(qtlLd, gwasLd, shared$qIdx, shared$gIdx)) { msg <- glue( - "{pipelineName}: ldSketch panels have different sample sets", - "{between}; use the same ldSketch on both." + "{pipelineName}: the two LdMatrix references disagree on the LD ", + "among the variants they share{between}; they describe different ", + "LD references." ) abort(msg) } - .ldSketchCheckOverlap(qtlLd, gwasLd, pipelineName, between) -} - -.requireMatchingLdSketches <- function( - qtlLd, - gwasLd, - pipelineName, - label = NULL, - nullPolicy = c("qtl-required", "lenient") -) { - nullPolicy <- arg_match(nullPolicy) - if (.ldSketchNullGuard(qtlLd, gwasLd, pipelineName, label, nullPolicy)) { - return(invisible(NULL)) - } - between <- if (!is.null(label)) { - glue(" between `{label}` and gwas inputs", .trim = FALSE) - } else { - "" - } - .ldSketchCheckShape(qtlLd, gwasLd, pipelineName, between) - .ldSketchCheckContent(qtlLd, gwasLd, pipelineName, between) invisible(NULL) } -# ---------- LD sketch: genotype loading ---------- - -#' HWE-based standardization of a genotype matrix -#' -#' Centers by 2*alleleFreq, scales by sqrt(2*alleleFreq*(1-alleleFreq)). Assumes -#' monomorphic variants have already been removed. -#' -#' @param X Numeric genotype matrix (n x p). -#' @param alleleFreq Numeric vector of allele frequencies (length p). -#' @return Standardized matrix (n x p). -#' @noRd -standardizeGenotypeHwe <- function(X, alleleFreq) { - Xstd <- sweep(X, 2, 2 * alleleFreq) - sweep(Xstd, 2, sqrt(2 * alleleFreq * (1 - alleleFreq)), "/") -} - - -# ---------- Internal: load LD from pre-computed blocks ---------- - -#' Load pre-computed LD from block-based metadata files. -#' @importFrom purrr map_chr map_int map_dbl -#' @noRd -# --- loadLdFromBlocks helpers ----------------------------------------------- - -# One block's record: the region-extracted matrix, its variants, and the -# chromosome it sits on (falling back to the requested region's when the -# block contributed nothing). -# -# A RECORD rather than a position in three parallel lists: the filter and the -# metadata builder below would otherwise have to keep four sequences in the -# same order by hand, and a slip there would silently attach one block's -# chromosome to another block's variants. -# @noRd -.loadLdOneBlock <- function( - j, - ldFilePaths, - bimFilePaths, - intersectedLdFiles, - extractCoordinates -) { - proc <- processLdMatrix(ldFilePaths[[j]], bimFilePaths[[j]]) - extracted <- extractLdForRegion( - ldMatrix = proc$ldMatrix, - variants = proc$ldVariants, - region = intersectedLdFiles$region, - extractCoordinates = extractCoordinates - ) - blockVariants <- extracted$extractedLdVariants - list( - matrix = extracted$extractedLdMatrix, - variants = blockVariants, - chrom = if (nrow(blockVariants) > 0) { - as.character(blockVariants$chrom[[1L]]) - } else { - as.character(intersectedLdFiles$region$chrom) - } - ) -} - -# Load + region-extract each LD block, one record per block. -.loadLdBlocksLoop <- function( - ldFilePaths, - bimFilePaths, - intersectedLdFiles, - extractCoordinates -) { - map( - seq_along(ldFilePaths), - .loadLdOneBlock, - ldFilePaths = ldFilePaths, - bimFilePaths = bimFilePaths, - intersectedLdFiles = intersectedLdFiles, - extractCoordinates = extractCoordinates - ) -} - -# Drop blocks with no variants in the region (error if none remain). -.loadLdFilterEmpty <- function(blocks) { - nonEmpty <- map_lgl(map(blocks, "variants"), .ldBlockHasVariants) - if (!any(nonEmpty)) { - abort("No variants found in any LD block for the specified region.") - } - if (any(!nonEmpty)) { - nEmpty <- sum(!nonEmpty) +# Two mixtures describe the same LD reference when they average the same +# panels (by their samples) with the same weights. +# @noRd +.ldRefCheckSameMixture <- function(qtlLd, gwasLd, pipelineName, between) { + if (!.gmSameMixture(qtlLd, gwasLd)) { msg <- glue( - "Removing {nEmpty} empty LD block(s) with no variants in ", - "the region." + "{pipelineName}: the two GenotypeMixture references{between} ", + "average different panels or weight them differently; use the ", + "same LD reference on both." ) - inform(msg) + abort(msg) } - blocks[nonEmpty] -} - -# Per-block metadata (id, chrom, span, size, index range in the merged matrix). -.loadLdBlockMetadata <- function(blocks, ldVariants) { - variants <- map(blocks, "variants") - blockVariants <- map(variants, "variants") - blockPositions <- map(variants, "pos") - tibble( - blockId = seq_along(blocks), - chrom = map_chr(blocks, "chrom"), - blockStart = map_dbl(blockPositions, min), - blockEnd = map_dbl(blockPositions, max), - size = map_int(blockVariants, length), - startIdx = map_int( - blockVariants, - .ldBlockStartIdx, - ldVariants = ldVariants - ), - endIdx = map_int( - blockVariants, - .ldBlockEndIdx, - ldVariants = ldVariants - ) - ) + invisible(NULL) } -# Build the reference panel: variant ids + merged per-variant annotations, -# deriving variance from nSample + allele_freq when it is otherwise absent. -# One annotation column aligned to the panel's variant order. +# TRUE when two LdMatrix objects hold the same LD among the variants at +# `xIdx` in one and `yIdx` in the other (matched pairs, same allele coding). +# Compared on an evenly spaced subset, so the cost does not grow with the +# overlap. # @noRd -.ldAnnotationColumn <- function(col, mergedVariantList, ids) { - mergedVariantList[[col]][match(ids, mergedVariantList$variants)] +.ldmAgreesOn <- function(x, y, xIdx, yIdx, tol = 1e-6) { + n <- length(xIdx) + if (n == 0L) { + return(TRUE) + } + probe <- unique(round(seq(1, n, length.out = min(n, 200L)))) + xR <- ldMatrix(x)[xIdx[probe], xIdx[probe], drop = FALSE] + yR <- ldMatrix(y)[yIdx[probe], yIdx[probe], drop = FALSE] + max(abs(xR - yR)) <= tol } -.loadLdRefPanel <- function(ldMatrix, extractedLdVariantsList, nSample) { - ids <- rownames(ldMatrix) - mergedVariantList <- bind_rows(extractedLdVariantsList) - annotations <- intersect( - c("allele_freq", "variance", "n_nomiss"), - colnames(mergedVariantList) - ) - panel <- mutate( - parseVariantId(ids), - variant_id = ids, - !!!set_names( - map( - annotations, - .ldAnnotationColumn, - mergedVariantList = mergedVariantList, - ids = ids - ), - annotations +# Panels must describe the same reference panel: the same samples, and the same +# allele coding on the variants they share. Two LdMatrix objects must agree on +# the LD they share instead, having no samples to compare. Their variant SETS +# need not agree -- see `.ldRefCheckShape` for why. +.ldRefCheckContent <- function(qtlLd, gwasLd, pipelineName, between) { + if (.ldIsMatrixRef(qtlLd)) { + shared <- .ldRefCheckOverlap(qtlLd, gwasLd, pipelineName, between) + return( + .ldRefCheckSameLd(qtlLd, gwasLd, shared, pipelineName, between) ) - ) - needVar <- !is_in("variance", colnames(panel)) || all(is.na(panel$variance)) - if ( - is.null(nSample) || - !needVar || - !is_in("allele_freq", colnames(panel)) - ) { - return(panel) } - p <- panel$allele_freq - mutate( - panel, - variance = 2 * p * (1 - p) * nSample / (nSample - 1), - n_nomiss = nSample - ) + if (.ldIsMixtureRef(qtlLd)) { + .ldRefCheckSameMixture(qtlLd, gwasLd, pipelineName, between) + return(.ldRefCheckOverlap(qtlLd, gwasLd, pipelineName, between)) + } + qIds <- .ldRefSampleIds(qtlLd) + gIds <- .ldRefSampleIds(gwasLd) + if (!identical(qIds, gIds)) { + msg <- glue( + "{pipelineName}: ldReference panels have different sample sets", + "{between}; use the same ldReference on both." + ) + abort(msg) + } + .ldRefCheckOverlap(qtlLd, gwasLd, pipelineName, between) } -loadLdFromBlocks <- function( - ldMetaFilePath, - region, - extractCoordinates = NULL, - nSample = NULL +.requireMatchingLdRefs <- function( + qtlLd, + gwasLd, + pipelineName, + label = NULL, + nullPolicy = c("qtl-required", "lenient") ) { - intersectedLdFiles <- regionalLdMeta(ldMetaFilePath, region) - ldFilePaths <- intersectedLdFiles$intersections$LD_file_paths - bimFilePaths <- intersectedLdFiles$intersections$bimFilePaths - blocks <- .loadLdBlocksLoop( - ldFilePaths, - bimFilePaths, - intersectedLdFiles, - extractCoordinates - ) - kept <- .loadLdFilterEmpty(blocks) - keptVariants <- map(kept, "variants") - ldMatrix <- createLdMatrix( - ldMatrices = map(kept, "matrix"), - variants = keptVariants - ) - ldVariants <- rownames(ldMatrix) - blockMetadata <- .loadLdBlockMetadata(kept, ldVariants) - refPanel <- .loadLdRefPanel(ldMatrix, keptVariants, nSample) - variantsGr <- .refPanelToGranges(refPanel) - LdData( - correlation = ldMatrix, - genotypeHandle = NULL, - snpIdx = NULL, - variants = variantsGr, - blockMetadata = blockMetadata, - nSamples = if (is.null(nSample)) 0L else as.integer(nSample) - ) + nullPolicy <- arg_match(nullPolicy) + if (.ldRefNullGuard(qtlLd, gwasLd, pipelineName, label, nullPolicy)) { + return(invisible(NULL)) + } + between <- if (!is.null(label)) { + glue(" between `{label}` and gwas inputs", .trim = FALSE) + } else { + "" + } + .ldRefCheckShape(qtlLd, gwasLd, pipelineName, between) + .ldRefCheckContent(qtlLd, gwasLd, pipelineName, between) + invisible(NULL) } +# ---------- Variant lookups against an LD reference on disk ---------- + #' Filter variants by LD Reference #' #' Filters a vector of variant IDs to those present in the LD reference panel. @@ -2108,390 +2024,7 @@ filterVariantsByLdReference <- function( list(data = variantIds[keepIndices], idx = keepIndices) } -#' Partition LD Matrix into Block-Specific Matrices -#' -#' This function takes the output from loadLdMatrix and partitions the combined -#' LD matrix into a list of smaller matrices based on the block_indices, making -#' it easier to work with large LD matrices that span multiple blocks. -#' -#' @param ldData An \code{LdData} S4 object as returned by -#' \code{loadLdMatrix()}. -#' @param mergeSmallBlocks Logical, whether to merge blocks smaller than -#' minMergedBlockSize (default: TRUE). -#' @param minMergedBlockSize Integer, minimum number of variants for a block -#' after merging (default: 500). -#' @param maxMergedBlockSize Integer, maximum number of variants in a block -#' after merging (default: 10000). -#' -#' @return returns a list containing: -#' \describe{ -#' \item{ldMatrices}{A list of matrices, each representing LD for a specific -#' block.} -#' \item{variantIndices}{A data frame that maps variant IDs to their -#' corresponding block.} -#' \item{blockMetadata}{Information about each block including size, -#' chromosome, start and end positions.} -#' } -#' @noRd -# --- partitionLdMatrix helpers ---------------------------------------------- - -# Reject empty/NULL matrices; align row/col names to the variant ids. -.partitionValidateMatrix <- function(combinedMatrix, variantIds) { - if ( - is.null(combinedMatrix) || - nrow(combinedMatrix) == 0 || - ncol(combinedMatrix) == 0 - ) { - abort("Empty or NULL LD matrix provided.") - } - wanted <- list(variantIds, variantIds) - if (!identical(dimnames(combinedMatrix), wanted)) { - return(`dimnames<-`(combinedMatrix, wanted)) - } - combinedMatrix -} - -# Drop blocks with invalid/out-of-range indices; renumber the survivors. -.partitionFilterBlocks <- function(blockMetadata, nVariants) { - validBlocks <- map_lgl( - seq_along(blockMetadata), - .ldBlockValid, - blockMetadata = blockMetadata, - nVariants = nVariants - ) - if (!any(validBlocks)) { - msg <- glue( - "No valid LD blocks found. All block indices are out of ", - "range or empty." - ) - abort(msg) - } - if (any(!validBlocks)) { - nInvalid <- sum(!validBlocks) - msg <- glue( - "Removing {nInvalid} LD block(s) with invalid or ", - "out-of-range indices." - ) - inform(msg) - kept <- blockMetadata[validBlocks] - kept$blockId <- seq_along(kept) - return(kept) - } - blockMetadata -} - -#' @importFrom checkmate assertClass -partitionLdMatrix <- function( - ldData, - mergeSmallBlocks = TRUE, - minMergedBlockSize = 500, - maxMergedBlockSize = 10000 -) { - assertClass(ldData, "LdData") - variantIds <- variantIds(ldData) - combinedMatrix <- .partitionValidateMatrix( - ldMatrix(ldData), - variantIds - ) - # The slot is always a GRanges now, so no flattening: every consumer - # below reads it as one (mcols via `$`, blocks via `[` and length()). - blocks <- .partitionFilterBlocks( - blockMetadata(ldData), - length(variantIds) - ) - # Validate the block structure of the matrix (skip if only one block). - if (length(blocks) > 1) { - validateBlockStructure(combinedMatrix, blocks, variantIds) - } - merging <- mergeSmallBlocks && - any(blocks$size < minMergedBlockSize) && - length(blocks) > 1 - blockMetadata <- if (merging) { - mergeBlocks(blocks, minMergedBlockSize, maxMergedBlockSize) - } else { - blocks - } - extractBlockMatrices(combinedMatrix, blockMetadata, variantIds) -} - -# Blocks must not overlap. The merge logic only ever considers i - 1 and -# i + 1, so a block's position in the table has to mean its position on the -# chromosome; that held by convention -- the loaders sort by position -- but -# nothing checked it, and a violation would silently merge non-neighbours. -# As a GRanges it is one call. Width-0 blocks are skipped: they mark an -# out-of-range index range that .partitionFilterBlocks() drops anyway. -# @noRd -.ldBlockOrderAssert <- function(blockMetadata) { - spanned <- blockMetadata[GenomicRanges::width(blockMetadata) > 0L] - if (length(spanned) < 2L || GenomicRanges::isDisjoint(spanned)) { - return(invisible(NULL)) - } - abort( - "LD blocks overlap: each block must cover a span of its own." - ) -} - -# Every (i, j) block pair with i < j. -# @noRd -.ldUpperPairs <- function(nBlocks) { - grid <- expand.grid(i = seq_len(nBlocks), j = seq_len(nBlocks)) - grid[grid$i < grid$j, , drop = FALSE] -} - -# @noRd -.blockPairMessagesAt <- function( - k, - pairs, - blockMetadata, - matrix, - variantIds, - n -) { - .blockPairMessages( - pairs$i[[k]], - pairs$j[[k]], - blockMetadata, - matrix, - variantIds, - n - ) -} - -# Concatenate per-item message vectors, empty-safe. -# @noRd -.ldConcatChr <- function(pieces) { - if (length(pieces) == 0L) { - return(character(0)) - } - as.character(list_c(pieces)) -} - -#' Validate that cross-block entries are zero (excluding boundary variants). -#' @noRd -validateBlockStructure <- function(matrix, blockMetadata, variantIds) { - .ldBlockOrderAssert(blockMetadata) - n <- length(variantIds) - pairs <- .ldUpperPairs(length(blockMetadata)) - msgs <- .ldConcatChr(map( - seq_len(nrow(pairs)), - .blockPairMessagesAt, - pairs = pairs, - blockMetadata = blockMetadata, - matrix = matrix, - variantIds = variantIds, - n = n - )) - if (length(msgs) > 0) { - msgList <- str_flatten(msgs, collapse = "\n") - msg <- glue( - "Matrix lacks expected block structure:\n{msgList}", - .trim = FALSE - ) - abort(msg) - } -} - -# Overlap-consistency messages for one block pair (i, j): out-of-range indices, -# or non-zero cross-block correlation with boundary variants excluded. Returns a -# (possibly empty) character vector. -# @noRd -.blockPairMessages <- function(i, j, blockMetadata, matrix, variantIds, n) { - si <- blockMetadata$startIdx[i] - ei <- blockMetadata$endIdx[i] - sj <- blockMetadata$startIdx[j] - ej <- blockMetadata$endIdx[j] - if (si > n || ei > n || sj > n || ej > n) { - return(str_c( - "Block indices out of range for blocks", - i, - "and", - j, - sep = " " - )) - } - # Exclude boundary variants (potential overlaps) - vi <- variantIds[si:(ei - 1)] - vj <- variantIds[(sj + 1):ej] - maxVal <- max(abs(matrix[vi, vj, drop = FALSE])) - if (maxVal <= 1e-10) { - return(character(0)) - } - str_c( - "Non-zero correlation between blocks", - i, - "and", - j, - "- max:", - maxVal, - sep = " " - ) -} - -#' Can blocks `i` and `j` of `blockMetadata` merge (same chrom, combined size -#' within `maxSize`)? Indexes the columns directly rather than slicing rows. -#' @noRd -canMerge <- function(blockMetadata, i, j, maxSize) { - chrom <- as.character(GenomicRanges::seqnames(blockMetadata)) - chrom[i] == chrom[j] && - (blockMetadata$size[i] + blockMetadata$size[j]) <= maxSize -} - -#' @noRd -mergeTwoBlocks <- function(blockMetadata, idx1, idx2) { - if (idx1 > idx2) { - tmp <- idx1 - idx1 <- idx2 - idx2 <- tmp - } - merged <- blockMetadata - merged$endIdx[idx1] <- blockMetadata$endIdx[idx2] - merged$size[idx1] <- blockMetadata$size[idx1] + - blockMetadata$size[idx2] - # The merged block spans both, so its RANGE has to grow with its index - # range. While this was a data.frame the two could drift apart unnoticed, - # because nothing read blockStart / blockEnd. - GenomicRanges::end(merged)[idx1] <- - GenomicRanges::end(blockMetadata)[idx2] - merged <- merged[-idx2] - merged$blockId <- seq_along(merged) - merged -} - -#' Find blocks below minSize and identify the best neighbor to merge with. -#' @noRd -findMergeCandidates <- function(blockMetadata, minSize, maxSize) { - found <- compact(map( - seq_along(blockMetadata), - .ldMergeCandidateFor, - blockMetadata = blockMetadata, - minSize = minSize, - maxSize = maxSize - )) - if (length(found) == 0L) { - return(tibble(block_idx = integer(), merge_with = integer())) - } - bind_rows(found) -} - -# Which neighbour block `i` should merge into (the smaller one when both -# qualify), or NULL when it is big enough already or neither neighbour can -# take it. -# @noRd -.ldMergeCandidateFor <- function(i, blockMetadata, minSize, maxSize) { - if (blockMetadata$size[i] >= minSize) { - return(NULL) - } - prevOk <- i > 1 && canMerge(blockMetadata, i, i - 1, maxSize) - nextOk <- i < length(blockMetadata) && - canMerge(blockMetadata, i, i + 1, maxSize) - mergeWith <- if (prevOk && nextOk) { - if (blockMetadata$size[i - 1] <= blockMetadata$size[i + 1]) { - i - 1 - } else { - i + 1 - } - } else if (prevOk) { - i - 1 - } else if (nextOk) { - i + 1 - } else { - return(NULL) - } - tibble(block_idx = i, merge_with = mergeWith) -} - -#' Iteratively merge blocks below minSize with their smallest neighbor. -#' @noRd -mergeBlocks <- function(blockMetadata, minSize, maxSize) { - if (length(blockMetadata) <= 1) { - return(blockMetadata) - } - candidates <- findMergeCandidates(blockMetadata, minSize, maxSize) - if (nrow(candidates) == 0) { - return(blockMetadata) - } - # Each merge changes which blocks are still too small, so this is a fixed - # point: recurse on the merged metadata rather than rebinding it. - mergeBlocks( - mergeTwoBlocks( - blockMetadata, - candidates$block_idx[1], - candidates$merge_with[1] - ), - minSize, - maxSize - ) -} - -# Helper function to extract block matrices -# Extract one block's submatrix + mapping (NULL to skip empty/OOB blocks). -.extractOneBlock <- function(matrix, variantIds, startIdx, endIdx, i) { - if (endIdx < startIdx) { - return(NULL) - } - if (startIdx > length(variantIds) || endIdx > length(variantIds)) { - msg <- glue( - "Block {i} has indices outside the range of variantIds. ", - "Skipping." - ) - warn(msg) - return(NULL) - } - blockVariants <- variantIds[startIdx:endIdx] - list( - matrix = matrix[blockVariants, blockVariants, drop = FALSE], - mapping = tibble( - variant_id = blockVariants, - blockId = i - ) - ) -} - -# @noRd -.ldExtractBlockAt <- function(i, matrix, variantIds, blockMetadata) { - .extractOneBlock( - matrix, - variantIds, - blockMetadata$startIdx[i], - blockMetadata$endIdx[i], - i - ) -} - -# `x[[i]] <- v` in a loop never extends past the last assigned position, so -# trailing skipped blocks leave no entry at all. -# @noRd -.ldTrimTrailingNull <- function(xs) { - filled <- which(!map_lgl(xs, is.null)) - if (length(filled) == 0L) { - return(list()) - } - xs[seq_len(max(filled))] -} - -extractBlockMatrices <- function(matrix, blockMetadata, variantIds) { - blocks <- map( - seq_along(blockMetadata), - .ldExtractBlockAt, - matrix = matrix, - variantIds = variantIds, - blockMetadata = blockMetadata - ) - kept <- compact(blocks) - mappings <- map(kept, "mapping") - list( - # A skipped block leaves a hole, as `ldMatrices[[i]] <- ...` did: - # positions stay aligned with blockMetadata rows. - ldMatrices = .ldTrimTrailingNull(map(blocks, "matrix")), - variantIndices = if (length(mappings) == 0L) { - tibble(variant_id = character(), blockId = integer()) - } else { - bind_rows(mappings) - }, - blockMetadata = blockMetadata - ) -} - +# ---------- LD matrix checks and repair ---------- # The PSD repair `method` asks for, or the matrix unchanged when it is # already positive definite. Returns list(R, methodApplied). @@ -2610,19 +2143,18 @@ checkLd <- function( ) } -# hclust (single-linkage) LD pruning: keep one representative per |cor| cluster. +# Single-linkage LD pruning: keep one representative per |cor| cluster. +# Single-linkage clusters cut at 1 - corThres are the connected components +# of the graph joining columns with |cor| >= corThres, so they are found from +# the columns' correlations a stripe of rows at a time +# (ldThresholdComponents()), never the full matrix. .ldPruneHclust <- function(X, corThres, verbose) { - # Engine-call exception: Rfast::cora is a fast drop-in for base cor(), a - # numeric primitive rather than an analysis engine. p <- ncol(X) - if (requireNamespace("Rfast", quietly = TRUE)) { - cor.X <- Rfast::cora(X, large = TRUE) - } else { - cor.X <- cor(X) - } - Sigma.distance <- as.dist(1 - abs(cor.X)) - fit <- hclust(Sigma.distance, method = "single") - clusters <- cutree(fit, h = 1 - corThres) + clusters <- ldThresholdComponents( + .ldStandardize(X), + corThres, + .ldStripeSize() + ) # Keep the first member of each cluster and drop the rest -- which is # exactly the entries that repeat a cluster already seen. ind.delete <- which(duplicated(clusters)) @@ -2695,9 +2227,12 @@ LdPruningOptions <- function(...) { #' Prune columns by pairwise correlation (LD-style prune) #' #' Performs LD pruning using one of two backends. The default \code{"hclust"} -#' backend computes the full correlation matrix, builds a single-linkage -#' hierarchical clustering on the distance (1 - |cor|), and keeps one -#' representative column per cluster. The \code{"snprelate"} backend delegates +#' backend groups the columns as single-linkage hierarchical clustering on the +#' distance (1 - |cor|), cut at 1 - \code{corThres}, would, and keeps the +#' first column of each group. Those groups are the connected components +#' of the graph joining columns with |cor| >= \code{corThres}, found from the +#' correlations a stripe of rows at a time, so the full correlation matrix is +#' never formed. The \code{"snprelate"} backend delegates #' to \code{SNPRelate::snpgdsLDpruning}, which performs a sliding-window greedy #' prune directly on a temporary GDS file. #' @@ -2709,11 +2244,13 @@ LdPruningOptions <- function(...) { #' @param backend Character, one of \code{"hclust"} (default) or #' \code{"snprelate"}. Controls the pruning algorithm: #' \describe{ -#' \item{\code{"hclust"}}{Uses the internal hierarchical-clustering approach -#' with \code{Rfast::cora} (if available) or base \code{cor()}.} +#' \item{\code{"hclust"}}{Single-linkage groups, found as the connected +#' components of the |cor| >= \code{corThres} graph.} #' \item{\code{"snprelate"}}{Requires \pkg{SNPRelate} and \pkg{gdsfmt}. #' Creates a temporary GDS file and runs -#' \code{SNPRelate::snpgdsLDpruning(method = "corr")}.} +#' \code{SNPRelate::snpgdsLDpruning(method = "corr")}. GDS stores +#' genotypes as the integer codes 0, 1 and 2, so fractional dosages are +#' refused rather than rounded.} #' } #' @param verbose Logical. If TRUE, print progress messages. Default FALSE. #' @param methodArgs Extra arguments for @@ -2737,7 +2274,7 @@ LdPruningOptions <- function(...) { #' res <- ldPruneByCorrelation(X, corThres = 0.9) #' ncol(res$X.new) #' -#' @importFrom stats as.dist hclust cutree cor +#' @importFrom stats cor #' @export ldPruneByCorrelation <- function( X, @@ -2782,9 +2319,9 @@ ldPruneByCorrelation <- function( } } -# Write X (rounded to integer genotype codes) to a temporary GDS for SNPRelate. +# Write X, integer genotype codes, to a temporary GDS for SNPRelate. .ldPruneSnprelateCreateGds <- function(tmpGds, X, snpNames, p) { - genoInt <- `storage.mode<-`(round(X), "integer") + genoInt <- `storage.mode<-`(X, "integer") SNPRelate::snpgdsCreateGeno( gds.fn = tmpGds, genmat = t(genoInt), @@ -2799,6 +2336,7 @@ ldPruneByCorrelation <- function( .ldPruneSnprelate <- function(X, corThres, verbose, methodArgs) { .ldPruneSnprelateDeps() + .ldRequireIntegerGenotypes(X, "snprelate", "hclust") p <- ncol(X) snpNames <- colnames(X) %||% str_c("snp", seq_len(p)) tmpGds <- tempfile(fileext = ".gds") @@ -2827,43 +2365,8 @@ ldPruneByCorrelation <- function( list(X.new = X.new, filter.id = keepIds) } -#' Drop collinear columns from a design matrix by a chosen strategy -#' -#' Given a numeric matrix \code{X} and a set of column names known to be -#' involved in linear dependencies, remove one column using one of three -#' strategies. Designed to be called iteratively by -#' \code{\link{enforceDesignFullRank}}, but can be used standalone. -#' -#' @param X Numeric matrix. Must have column names covering -#' \code{problematicCols}. -#' @param problematicCols Character vector of column names in \code{X} that are -#' candidates for removal. If empty, \code{X} is returned unchanged. -#' @param strategy One of \code{"correlation"} (remove the column with the -#' largest sum of absolute pairwise correlations among the candidates; when -#' only two candidates, one is picked at random), \code{"variance"} (remove -#' the lowest-variance candidate), or \code{"responseCorrelation"} (remove -#' the candidate whose correlation with \code{response} has the smallest -#' magnitude). -#' @param response Numeric vector required when \code{strategy = -#' "responseCorrelation"}; the outcome to correlate against. -#' @param verbose Logical. If TRUE, print which column was removed. Default -#' FALSE. -#' -#' @return \code{X} with exactly one column removed (or unchanged if -#' \code{problematicCols} is empty). -#' -#' @examples -#' set.seed(1) -#' X <- matrix(rnorm(100 * 3), 100, 3) -#' X[, 3] <- X[, 1] + X[, 2] -#' colnames(X) <- c("a", "b", "c") -#' dropCollinearColumns(X, problematicCols = c("a", "b", "c"), -#' strategy = "variance") -#' -#' @importFrom stats var cor -#' @keywords internal -#' @noRd # Correlation strategy: drop the most-connected column (random tie-break at 2). +# @noRd .dropCollinearPickCor <- function(X, problematicCols, verbose, seed = NULL) { corMatrix <- `diag<-`( abs(cor(X[, problematicCols, drop = FALSE])), @@ -2937,6 +2440,42 @@ ldPruneByCorrelation <- function( colToRemove } +#' Drop collinear columns from a design matrix by a chosen strategy +#' +#' Given a numeric matrix \code{X} and a set of column names known to be +#' involved in linear dependencies, remove one column using one of three +#' strategies. Designed to be called iteratively by +#' \code{\link{enforceDesignFullRank}}, but can be used standalone. +#' +#' @param X Numeric matrix. Must have column names covering +#' \code{problematicCols}. +#' @param problematicCols Character vector of column names in \code{X} that are +#' candidates for removal. If empty, \code{X} is returned unchanged. +#' @param strategy One of \code{"correlation"} (remove the column with the +#' largest sum of absolute pairwise correlations among the candidates; when +#' only two candidates, one is picked at random), \code{"variance"} (remove +#' the lowest-variance candidate), or \code{"responseCorrelation"} (remove +#' the candidate whose correlation with \code{response} has the smallest +#' magnitude). +#' @param response Numeric vector required when \code{strategy = +#' "responseCorrelation"}; the outcome to correlate against. +#' @param verbose Logical. If TRUE, print which column was removed. Default +#' FALSE. +#' +#' @return \code{X} with exactly one column removed (or unchanged if +#' \code{problematicCols} is empty). +#' +#' @examples +#' set.seed(1) +#' X <- matrix(rnorm(100 * 3), 100, 3) +#' X[, 3] <- X[, 1] + X[, 2] +#' colnames(X) <- c("a", "b", "c") +#' dropCollinearColumns(X, problematicCols = c("a", "b", "c"), +#' strategy = "variance") +#' +#' @importFrom stats var cor +#' @keywords internal +#' @noRd dropCollinearColumns <- function( X, problematicCols, @@ -3314,34 +2853,6 @@ ldClumpByScore <- function( keep } - -# ============================================================================= -# Block-wise LD loaders -# ----------------------------------------------------------------------------- -# High-level helpers that sit on top of `loadLdMatrix` / `processLdMatrix` -# to retrieve per-block LD or genotype matrices on demand. Used by -# downstream pipelines (cTWAS, etc.) that need to walk many LD blocks -# without materializing them all in memory at once. -# ============================================================================= - -#' Extract the LD or genotype matrix from an LdData S4 object. -#' @param ld An LdData object. -#' @param wantGenotype Logical; if TRUE, extract the genotype matrix (via -#' \code{genotypes()}). -#' @return A matrix. -#' @importFrom checkmate assertClass -#' @noRd -extractLdMatrix <- function(ld, wantGenotype = FALSE) { - assertClass(ld, "LdData") - if (wantGenotype && hasGenotypes(ld)) { - return(genotypes(ld)) - } - ldMatrix(ld) -} - - -# ---- Per-block helpers ------------------------------------------------------ - # ============================================================================= # LD correlation matrix from a dosage matrix # ----------------------------------------------------------------------------- @@ -3354,10 +2865,10 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { # LD for a block of a genotype panel: read the dosages, then correlate them. # -# The guards are the reason this is a function rather than two lines at the -# call site. A backend that cannot read the block returns NULL, and a -# single-variant block has no correlation structure; both mean "identity", -# and open-coding that in every caller is how one of them ends up omitting it. +# The guard is the reason this is a function rather than two lines at the +# call site: a single-variant block has no correlation structure, so its LD +# is the identity, and open-coding that in every caller is how one of them +# ends up omitting it. # @noRd .computeLdFromPanel <- function( panel, @@ -3368,14 +2879,11 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { shrinkage ) { idx <- if (is.null(snpIdx)) { - seq_along(.ldSketchRanges(panel)) + seq_along(.ldRefRanges(panel)) } else { snpIdx } - geno <- .ldSketchDosage(panel, idx) - if (is.null(geno)) { - return(diag(length(idx))) - } + geno <- .ldRefDosage(panel, idx) if (ncol(geno) < 2L) { return(diag(length(idx))) } @@ -3425,21 +2933,30 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { "already in memory, which is what onDisk exists to avoid." )) } - fmt <- genotypeFormat(.ldSketchHandle(X)) + fmt <- .ldRefFormat(X) %||% "held in memory" if (fmt != "gds") { abort(glue( "computeLd(onDisk = TRUE) needs a GDS-backed panel; this one is ", "'{fmt}'. Only GDS exposes an on-disk LD routine." )) } + if (.withGdsFile(.ldRefReadPath(X), .gdsFileFormat) != "SNP_ARRAY") { + abort(glue( + "computeLd(onDisk = TRUE) reads SNPRelate's SNP GDS files; ", + "{.ldRefReadPath(X)} is a SeqArray GDS file. Use ", + "computeLd(onDisk = FALSE), which reads its dosages." + )) + } idx <- if (is.null(snpIdx)) { - seq_along(.ldSketchRanges(X)) + seq_along(.ldRefRanges(X)) } else { snpIdx } - # The handle stays here on purpose: the GDS on-disk LD routine reads the - # file directly, which is a seed-level operation with no assay equivalent. - R <- .ldCleanCorrelation(.computeBlockLdGds(.ldSketchHandle(X), idx)) + # The GDS on-disk LD routine reads the file directly, which has no assay + # equivalent: it is handed the file and the variants' own ids. + R <- .ldCleanCorrelation( + .computeBlockLdGds(.ldRefReadPath(X), .ldRefVariantIds(X)[idx]) + ) .ldShrinkToIdentity(R, shrinkage) } @@ -3581,7 +3098,10 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { #' \code{cor()} without it) and is both the fastest and the default; #' \code{"snprelate"} and \code{"snpstats"} exist to cross-check it and do #' strictly more work, since each converts the same matrix into its own -#' representation first. +#' representation first. Both store genotypes as the integer codes 0, 1 and +#' 2, so they refuse fractional dosages (imputed, or a stochastic sketch's) +#' rather than round them; \code{"internal"} correlates dosages as they +#' are. #' @param X A numeric dosage matrix (samples x variants), or a genotype panel #' -- a \code{RangedSummarizedExperiment} whose dosage assay reads through #' a genotype handle. @@ -3611,7 +3131,7 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { #' \code{dimnames} taken from the block where available. #' @examples #' data(qtlSumStatsExample) -#' panel <- ldSketch(qtlSumStatsExample) +#' panel <- ldReference(qtlSumStatsExample) #' R <- computeLd(panel, snpIdx = 1:5) #' dim(R) #' # A dosage matrix already in memory is correlated directly. @@ -3673,6 +3193,28 @@ computeLd <- function( `dimnames<-`(R, list(nms, nms)) } +# SNPRelate (GDS) and snpStats (SnpMatrix) hold a genotype as a 2-bit code, +# so a dosage outside 0, 1 and 2 -- an imputed or projected one -- would be +# rounded, and its LD changed, without a word. They take genotype codes only; +# dosages go to the backend that correlates them as they are. +# @noRd +.ldRequireIntegerGenotypes <- function(X, backend, instead) { + bad <- !is.na(X) & !is_in(X, c(0, 1, 2)) + if (!any(bad)) { + return(invisible(TRUE)) + } + abort(c( + glue( + "backend = \"{backend}\" stores genotypes as the codes 0, 1 and ", + "2, and {sum(bad)} value(s) here are not one of them." + ), + i = glue( + "Rounding them would change their LD. Use backend = ", + "\"{instead}\", which takes dosages as they are." + ) + )) +} + #' Compute LD via SNPRelate (creates a temporary GDS file from the dosage #' matrix). #' @param X Numeric genotype matrix (samples x SNPs). @@ -3686,12 +3228,12 @@ computeLd <- function( abort("Package 'gdsfmt' is required for backend='snprelate'") } + .ldRequireIntegerGenotypes(X, "snprelate", "internal") tmpGds <- tempfile(fileext = ".gds") on.exit(unlink(tmpGds), add = TRUE) - # Round to integer dosage for GDS (0/1/2) - # 3L is the GDS missing code. - X_int <- replace(`storage.mode<-`(round(X), "integer"), is.na(X), 3L) + # Integer genotype codes 0/1/2, with 3L, the GDS missing code, for NA. + X_int <- replace(`storage.mode<-`(X, "integer"), is.na(X), 3L) snpIds <- colnames(X) %||% seq_len(ncol(X)) sampleIds <- rownames(X) %||% seq_len(nrow(X)) @@ -3726,11 +3268,11 @@ computeLd <- function( if (!requireNamespace("snpStats", quietly = TRUE)) { abort("Package 'snpStats' is required for backend='snpstats'") } + .ldRequireIntegerGenotypes(X, "snpstats", "internal") # snpStats expects counts of the B allele as raw codes: 1=AA, 2=AB, 3=BB, # 0=NA pecotmr dosage is ALT count (0/1/2), so map: 0->1, 1->2, 2->3, NA->0 - shifted <- round(X) + 1L - coded <- pmin(replace(shifted, is.na(X) | shifted < 1L, 0L), 3L) + coded <- replace(X + 1L, is.na(X), 0L) sm <- new("SnpMatrix", `storage.mode<-`(coded, "raw")) raw <- as.matrix(snpStats::ld(sm, stats = "R", depth = ncol(X) - 1L)) @@ -3738,49 +3280,6 @@ computeLd <- function( .ldCleanCorrelation(raw) } -# ---- map/apply helpers (lambda-free callbacks) --------------------------- - -# The integer BP position parsed from a "chrom:pos:a1:a2" variant id. -# @noRd -.ldVariantPos <- function(v) { - as.integer(str_split(v, ":")[[1L]][2]) -} - -# TRUE when a per-block variant table has at least one row. -# @noRd -.ldBlockHasVariants <- function(v) { - nrow(v) > 0 -} - -# The first index of a block's variants in the merged variant order. -# @noRd -.ldBlockStartIdx <- function(v, ldVariants) { - min(match(v, ldVariants)) -} - -# The last index of a block's variants in the merged variant order. -# @noRd -.ldBlockEndIdx <- function(v, ldVariants) { - max(match(v, ldVariants)) -} - -# TRUE when block `i`'s index range is present, finite, and within -# [1, nVariants]. -# @noRd -.ldBlockValid <- function(i, blockMetadata, nVariants) { - s <- blockMetadata$startIdx[i] - e <- blockMetadata$endIdx[i] - sz <- blockMetadata$size[i] - !is.na(s) && - !is.na(e) && - is.finite(s) && - is.finite(e) && - sz > 0 && - s >= 1 && - e >= s && - e <= nVariants -} - #' @rdname PanelFilterParam #' @aliases PanelFilterParam-class #' @exportClass PanelFilterParam @@ -3802,8 +3301,9 @@ setClass( #' missingness default is \code{1} (no filter) rather than \code{0}. #' @param mafCutoff Minor-allele-frequency floor. Default \code{0}. #' @param macCutoff Minor-allele-count floor; the stricter of this and -#' \code{mafCutoff} applies, using the panel's own sample count. Default -#' \code{0}. +#' \code{mafCutoff} applies, using the panel's real sample count -- for a +#' stochastic LD sketch, the one its \code{.afreq} records, not its +#' pseudo-samples. Default \code{0}. #' @param imissCutoff Per-variant missingness ceiling. Default \code{1}, which #' filters nothing and lets the allele-frequency sidecar be read instead of #' materializing dosage. diff --git a/R/manifestLoaders.R b/R/manifestLoaders.R index f3f909f74..a2f009024 100644 --- a/R/manifestLoaders.R +++ b/R/manifestLoaders.R @@ -70,10 +70,6 @@ NULL file.path(base, p) } -# Rename accepted aliases to the canonical camelCase name and validate that all -# `required` canonical columns are present. `aliases` is a named list keyed by -# canonical name; each value is the character vector of accepted source names -# (including the canonical name itself). The first alias present wins. # The QtlDataset pass-through arguments, asserted at the loader so a bad value # is reported against the argument the caller passed rather than surfacing from # QtlDataset's validity several hundred lines later. Types match @@ -84,8 +80,7 @@ NULL assertLogical(scaleResiduals, len = 1L) .assertMethodParam( genotypeFilterParam, - "GenotypeFilterParam", - "genotypeFilter" + "GenotypeFilterParam" ) # Only what the caller actually set: an unset field defers to QtlDataset's # own default and has nothing to check here. @@ -138,6 +133,11 @@ NULL hit[[1L]] } +# Rename accepted aliases to the canonical camelCase name and validate that all +# `required` canonical columns are present. `aliases` is a named list keyed by +# canonical name; each value is the character vector of accepted source names +# (including the canonical name itself). The first alias present wins. +# @noRd .canonManifestCols <- function(df, aliases, required, label) { # Each alias resolves against the ORIGINAL names, so renaming one cannot # change what another matches. @@ -204,149 +204,124 @@ NULL # Genotype-format detection + LD-sketch resolution # ============================================================================= -# Build a single-file / prefix GenotypeHandle, detecting the backend from the -# path. Recognised: .vcf[.gz|.bgz]/.bcf/.gds single files, .bed/.pgen single -# files, and bare PLINK1/PLINK2 prefixes (probed by sidecar existence). -.detectGenotypeFormat <- function(path) { - lower <- str_to_lower(path) - if ( - str_detect(lower, "\\.vcf(\\.b?gz)?$") || - str_ends(lower, "\\.bcf") || - str_ends(lower, "\\.gds") - ) { - return(GenotypeHandle(path = path)) - } - if (str_ends(lower, "\\.bed")) { - return(GenotypeHandle( - plink1Prefix = str_remove( - path, - regex("\\.bed$", ignore_case = TRUE) - ) - )) - } - if (str_ends(lower, "\\.pgen")) { - return(GenotypeHandle( - plink2Prefix = str_remove( - path, - regex("\\.pgen$", ignore_case = TRUE) - ) - )) - } - if (file.exists(str_c(path, ".bed"))) { - return(GenotypeHandle(plink1Prefix = path)) - } - if (file.exists(str_c(path, ".pgen"))) { - return(GenotypeHandle(plink2Prefix = path)) - } - msg <- glue( - "Could not determine genotype format for '{path}' ", - "(expected .bed/.pgen/.vcf[.gz]/.bcf/.gds or a PLINK prefix)." +# The genotype panel of a single file or PLINK prefix, its format told as +# readGenotypes() tells it (.genotypePathFormat()). +.readGenotypePath <- function(path) { + .readGenotypePanel( + path, + format = .requireGenotypeFormat(path, "manifest") ) - abort(msg) } -# Turn an ldSketch specification into a GenotypeHandle. Accepts a prebuilt -# handle, a named chrom -> path vector (genoMeta), or a single string that is -# either a genotype file/prefix or a chrom-sharded genoMeta meta file. -# `chroms` (optional) restricts a chrom-sharded panel to those chromosomes so -# the other per-chromosome shards are never read; it is ignored for a single -# genotype file (which has no shards to skip). -.resolveLdSketch <- function(spec, chroms = NULL) { +# Turn an ldReference specification into a genotype panel, or pass an LdMatrix +# or a mixture through. Accepts a panel (or a bare handle), a named chrom -> +# path vector (genoMeta), or a single string that is either a genotype +# file/prefix or a chrom-sharded genoMeta meta file. `chroms` (optional) +# restricts a chrom-sharded panel to those chromosomes so the other +# per-chromosome shards are never read; it is ignored for a single genotype +# file (which has no shards to skip). +.resolveLdRef <- function(spec, chroms = NULL) { if (is.null(spec)) { return(NULL) } - open <- .openGenotypeHandle(spec) + open <- .openLdRef(spec) if (!is.null(open)) { return(open) } if (is.character(spec) && !is.null(names(spec))) { - return(GenotypeHandle(genoMeta = spec, chroms = chroms)) + return(.chromMetaPanel(spec, chroms)) } if (is.character(spec) && length(spec) == 1L) { - lower <- str_to_lower(spec) - looksLikeGenotype <- str_detect(lower, "\\.vcf(\\.b?gz)?$") || - str_ends(lower, "\\.bcf") || - str_ends(lower, "\\.gds") || - str_ends(lower, "\\.bed") || - str_ends(lower, "\\.pgen") || - file.exists(str_c(spec, ".bed")) || - file.exists(str_c(spec, ".pgen")) - if (looksLikeGenotype) { - return(.detectGenotypeFormat(spec)) + if (!is.null(.genotypePathFormat(spec))) { + return(.readGenotypePath(spec)) } # Otherwise treat it as a chrom-sharded genoMeta meta file. - return(GenotypeHandle(genoMeta = spec, chroms = chroms)) + return(.chromMetaPanel(spec, chroms)) } msg <- glue( - "`ldSketch` must be a genotype panel, a genotype path/prefix, or a ", - "genoMeta spec (named chrom->path vector or meta-file path)." + "`ldReference` must be a genotype panel, a genotype path/prefix, a ", + "genoMeta spec (named chrom->path vector or meta-file path), or an ", + "LdMatrix." ) abort(msg) } -# Resolve the LD sketch SPEC from the (argument, ldSketchPath column) pair, -# without reading any genotype metadata yet. Returns the handle behind an -# already-open panel (when the caller passed one), or the reconciled spec +# An LD reference that is already open -- a genotype panel or a bare handle, +# an LdMatrix or a mixture, as it stands -- or NULL for a spec still to be +# resolved. +# @noRd +.openLdRef <- function(x) { + if (.ldIsMatrixRef(x) || .ldIsMixtureRef(x)) { + return(x) + } + .openGenotypeSource(x) +} + +# Resolve the LD sketch SPEC from the (argument, ldReferencePath column) pair, +# without reading any genotype metadata yet. Returns an already-open panel +# (when the caller passed one) as it is, or the reconciled spec # (a path/prefix or a # genoMeta path/named-vector) for later materialisation. Deferring the read to -# `.materializeLdSketch` lets the loader first learn which chromosomes the +# `.materializeLdRef` lets the loader first learn which chromosomes the # summary statistics cover and skip the panel's other per-chromosome shards. -.resolveLdSketchInput <- function(df, ldSketch, base) { - open <- .openGenotypeHandle(ldSketch) +.resolveLdRefInput <- function(df, ldReference, base) { + open <- .openLdRef(ldReference) if (!is.null(open)) { return(open) } - # is_in guard, not `!is.null(df$ldSketchPath)`: on a tibble `$` for an + # is_in guard, not `!is.null(df$ldReferencePath)`: on a tibble `$` for an # absent column NULLs but WARNS ("Unknown or uninitialised column"), where a - # data.frame was silent. ldSketchPath is optional (LD may come via - # `ldSketch`). - colSpec <- if (!is_in("ldSketchPath", names(df))) { + # data.frame was silent. ldReferencePath is optional (LD may come via + # `ldReference`). + colSpec <- if (!is_in("ldReferencePath", names(df))) { NULL } else { - v <- unique(as.character(df$ldSketchPath[ - !is.na(df$ldSketchPath) & - str_length(as.character(df$ldSketchPath)) > 0L + v <- unique(as.character(df$ldReferencePath[ + !is.na(df$ldReferencePath) & + str_length(as.character(df$ldReferencePath)) > 0L ])) if (length(v) > 1L) { - abort("`ldSketchPath` column must be constant across the manifest.") + abort( + "`ldReferencePath` column must be constant across the manifest." + ) } if (length(v) == 1L) .resolveRel(v, base) else NULL } - spec <- ldSketch %||% colSpec + spec <- ldReference %||% colSpec if ( - !is.null(ldSketch) && + !is.null(ldReference) && !is.null(colSpec) && - !identical(as.character(ldSketch), as.character(colSpec)) + !identical(as.character(ldReference), as.character(colSpec)) ) { msg <- glue( - "`ldSketch` argument disagrees with the manifest ", - "`ldSketchPath` column." + "`ldReference` argument disagrees with the manifest ", + "`ldReferencePath` column." ) abort(msg) } if (is.null(spec)) { msg <- glue( - "`ldSketch` must be provided as an argument or an ", - "`ldSketchPath` column." + "`ldReference` must be provided as an argument or an ", + "`ldReferencePath` column." ) abort(msg) } spec } -# Materialise a resolved ldSketch spec into a GenotypeHandle, reading only the -# shards for `chroms` when the spec is a chrom-sharded panel. A spec that is -# already a GenotypeHandle (the caller passed a prebuilt handle) is returned -# unchanged: its snpInfo is already in memory, so there is no read to restrict. -.materializeLdSketch <- function(spec, chroms) { +# Materialise a resolved ldReference spec into a genotype panel, reading only +# the shards for `chroms` when the spec is a chrom-sharded panel. A spec that is +# already open (the caller passed a panel) is returned unchanged: its variants +# are already in memory, so there is no read to restrict. +.materializeLdRef <- function(spec, chroms) { if (is.null(spec)) { return(NULL) } - open <- .openGenotypeHandle(spec) + open <- .openLdRef(spec) if (!is.null(open)) { return(open) } - .resolveLdSketch(spec, chroms = chroms) + .resolveLdRef(spec, chroms = chroms) } # Canonical chromosomes present across a list of sumstats entry GRanges. NULL / @@ -363,15 +338,15 @@ NULL # LD-sketch containment check (validation only; no filtering) # ============================================================================= -# Canonical chromosomes present in an LD sketch: for a sharded handle these are -# the chromPaths names; for a single-file handle the unique snpInfo chromosomes. -.ldSketchChroms <- function(ldSketch) { - handle <- .ldSketchHandle(ldSketch) - if (length(chromPaths(handle)) > 0L) { - canonChrom(names(chromPaths(handle))) - } else { - unique(.ldSketchChrom(ldSketch)) +# Canonical chromosomes present in an LD reference: for a panel read from a +# per-chromosome manifest these are the manifest's chromosomes; otherwise the +# chromosomes of its variants. +.ldRefChroms <- function(ldReference) { + chromPaths <- .ldRefChromPaths(ldReference) + if (length(chromPaths) > 0L) { + return(canonChrom(names(chromPaths))) } + unique(.ldRefChrom(ldReference)) } # Two-tier containment check for one entry GRanges against the LD sketch: @@ -379,15 +354,15 @@ NULL # * variant tier: match entry variants against the sketch's variants on the # shared chromosomes. Zero overlap -> error; overlap fraction below # `minLdOverlapWarn` -> warning. Never filters. -.checkLdContainment <- function(ldSketch, entryGr, minLdOverlapWarn, label) { +.checkLdContainment <- function(ldReference, entryGr, minLdOverlapWarn, label) { if (length(entryGr) == 0L) { return(invisible(NULL)) } - reqChrom <- .ldContainmentCheckChroms(entryGr, ldSketch, label) - sketchGr <- .ldSketchRanges(ldSketch) + reqChrom <- .ldContainmentCheckChroms(entryGr, ldReference, label) + sketchGr <- .ldRefRanges(ldReference) if (length(sketchGr) == 0L) { msg <- glue( - "{label}: LD sketch carries no variant metadata; ", + "{label}: the LD reference carries no variant metadata; ", "skipping the variant-overlap check." ) warn(msg) @@ -404,16 +379,16 @@ NULL # The entry's chromosomes must all be present in the LD sketch; returns them. # @noRd -.ldContainmentCheckChroms <- function(entryGr, ldSketch, label) { +.ldContainmentCheckChroms <- function(entryGr, ldReference, label) { reqChrom <- unique(canonChrom( as.character(GenomicRanges::seqnames(entryGr)) )) - availChrom <- .ldSketchChroms(ldSketch) + availChrom <- .ldRefChroms(ldReference) missingChrom <- setdiff(reqChrom, availChrom) if (length(missingChrom) > 0L) { msg <- glue( "{label}: chromosome(s) {str_flatten(missingChrom, ', ')} ", - "are absent from the LD sketch ", + "are absent from the LD reference ", "(available: {str_flatten(availChrom, ', ')})." ) abort(msg) @@ -434,7 +409,7 @@ NULL canonChrom(as.character(GenomicRanges::seqnames(sketchGr))), reqChrom ) - # Same matching relation `.ldFromSketch()` will use when the LD is + # Same matching relation `.ldFromRef()` will use when the LD is # actually loaded, palindromes included -- otherwise this counts an A/T # variant as absent, under-reports the overlap and warns about a panel # that will in fact match. @@ -448,7 +423,7 @@ NULL if (nOverlap == 0L) { msg <- glue( "{label}: none of the {length(entryGr)} summary-statistic ", - "variants are present in the LD sketch." + "variants are present in the LD reference." ) abort(msg) } @@ -457,7 +432,7 @@ NULL pct <- sprintf("%.1f", 100 * frac) msg <- glue( "{label}: only {pct}% of summary-statistic variants ", - "({nOverlap}/{length(entryGr)}) are present in the LD sketch." + "({nOverlap}/{length(entryGr)}) are present in the LD reference." ) warn(msg) } @@ -806,9 +781,6 @@ NULL ) } -# Assemble the standardized sumstat data.frame (chrom/pos/SNP/A1/A2/Z, optional -# N / N_CASE / N_CONTROL, and any present BETA/SE/P/MAF/INFO). -# @noRd # The source columns named by explicit mappings, so an auto-detected key never # re-reads a column another key already claimed. # @noRd @@ -866,6 +838,9 @@ NULL keep(sources, .sumstatSourceFound) } +# Assemble the standardized sumstat data.frame (chrom/pos/SNP/A1/A2/Z, optional +# N / N_CASE / N_CONTROL, and any present BETA/SE/P/MAF/INFO). +# @noRd .buildSumstatOut <- function(df, resolved, z, n, mapping, label) { claimed <- .sumstatClaimedCols(mapping) present <- .sumstatOptionalSources(df, mapping, label, claimed) @@ -920,7 +895,8 @@ NULL )) return(invisible(NULL)) } - if (all(is.na(out$AF))) { + # An empty result has no values to be unusable: all() of none is TRUE. + if (length(out$AF) > 0L && all(is.na(out$AF))) { warn(glue( "{label}: effect-allele frequency `af` was declared but its ", "values are all missing/unusable; top_loci$af will be NA." @@ -989,24 +965,25 @@ NULL # Read column `tag` from the GWAS-VCF geno matrix for one sample as numeric, or # NULL when the tag is absent/unmapped. -# @noRd +# # `tag` may name SEVERAL candidate keys in priority order (the spec's key then # the spellings found in the wild), so the first one the file actually carries -# wins. A single string still works -- it is a length-1 candidate list. +# wins. A single string still works -- it is a length-1 candidate list. The +# result is unnamed: geno matrix columns carry variant-id element names that +# the canonical sumstat tibble must not keep (data.frame stripped them). # @noRd .vcfGetField <- function(tag, geno, sample) { hit <- intersect(as.character(tag %||% character(0)), names(geno)) if (length(hit) == 0L) { return(NULL) } - # unname: geno matrix columns carry variant-id element names that the - # canonical sumstat tibble must not keep (data.frame stripped them). unname(as.numeric(geno[[hit[[1L]]]][, sample])) } # Convert a VCF (GWAS-VCF format) into the canonical sumstats data.frame. The # effect allele (A1) is ALT; the other allele (A2) is REF. Stats come from the # per-study FORMAT fields ES/SE/LP/SS/EAF, with Z = ES / SE. +# @noRd .vcfToSumstatDf <- function(vcf, sampleSelect, formatMapping, label) { fmap <- list_modify( .gwasVcfFormatDefaults, @@ -1016,59 +993,66 @@ NULL ) rr <- SummarizedExperiment::rowRanges(vcf) altList <- VariantAnnotation::alt(vcf) - alt <- unname(map_chr(as.list(altList), .mlFirstAlt)) - ref <- unname(as.character(VariantAnnotation::ref(vcf))) - geno <- VariantAnnotation::geno(vcf) sample <- .pickVcfSample(colnames(vcf), sampleSelect, label) - es <- .vcfGetField(fmap$BETA, geno, sample) - se <- .vcfGetField(fmap$SE, geno, sample) - ez <- .vcfGetField(fmap$Z, geno, sample) - lp <- .vcfGetField(fmap$P, geno, sample) - ss <- .vcfGetField(fmap$N, geno, sample) - af <- .vcfGetField(fmap$AF, geno, sample) - eaf <- .vcfGetField(fmap$MAF, geno, sample) - if ((is.null(es) || is.null(se)) && is.null(ez)) { + fld <- map( + fmap[c("BETA", "SE", "Z", "P", "N", "AF", "MAF")], + .vcfGetField, + geno = VariantAnnotation::geno(vcf), + sample = sample + ) + .vcfRequireSumstatFields(fld, label) + z <- .vcfSumstatZ(fld$BETA, fld$SE, fld$Z, length(rr)) + out <- tibble( + chrom = as.character(GenomicRanges::seqnames(rr)), + pos = unname(as.integer(GenomicRanges::start(rr))), + SNP = names(rr), + A1 = unname(map_chr(as.list(altList), .mlFirstAlt)), + A2 = unname(as.character(VariantAnnotation::ref(vcf))), + Z = z$z, + z_supplied = z$supplied, + N = fld$N + ) + mutate(out, !!!.vcfOptionalSumstatCols(fld)) +} + +# A GWAS-VCF must yield a z (supplied, or derivable from ES and SE) and a +# sample size. `fld` is the per-field read of `.vcfToSumstatDf()`. +# @noRd +.vcfRequireSumstatFields <- function(fld, label) { + if ((is.null(fld$BETA) || is.null(fld$SE)) && is.null(fld$Z)) { msg <- glue( "{label}: GWAS-VCF must carry either a supplied z (EZ) or ES and ", "SE to derive one from (configure via `formatMapping`)." ) abort(msg) } - if (is.null(ss)) { + if (is.null(fld$N)) { msg <- glue( "{label}: GWAS-VCF must carry a sample-size FORMAT field ", "(NS, or SS in older files; configure via `formatMapping`)." ) abort(msg) } - z <- .vcfSumstatZ(es, se, ez, length(rr)) - out <- tibble( - chrom = as.character(GenomicRanges::seqnames(rr)), - pos = unname(as.integer(GenomicRanges::start(rr))), - SNP = names(rr), - A1 = alt, - A2 = ref, - Z = z$z, - z_supplied = z$supplied, - N = ss - ) - mutate( - out, - !!!compact(list( - BETA = es, - SE = se, - P = if (!is.null(lp)) 10^(-lp), - AF = af, - # A directionless MAF of its own when the file has one; else - # folded from AF, which is QC-usable and keeps `AF` intact - # alongside it rather than consuming it. - MAF = if (!is.null(eaf)) { - pmin(eaf, 1 - eaf) - } else if (!is.null(af)) { - pmin(af, 1 - af) - } - )) - ) +} + +# The optional sumstat columns a GWAS-VCF may carry, NULL ones dropped. MAF is +# the file's own directionless MAF when it has one; else folded from AF, which +# is QC-usable and keeps `AF` intact alongside it rather than consuming it. +# @noRd +.vcfOptionalSumstatCols <- function(fld) { + eaf <- fld$MAF + af <- fld$AF + compact(list( + BETA = fld$BETA, + SE = fld$SE, + P = if (!is.null(fld$P)) 10^(-fld$P), + AF = af, + MAF = if (!is.null(eaf)) { + pmin(eaf, 1 - eaf) + } else if (!is.null(af)) { + pmin(af, 1 - af) + } + )) } # The z and its provenance, per variant. A supplied `EZ` wins where it has a @@ -1178,11 +1162,14 @@ NULL if (is.null(order) || identical(order, "none")) { return(df) } - have <- map_lgl( + alleleCols <- map( c("A1", "A2"), - function(k) !.mlIsNaOrNull(.resolveSumstatKey(k, df, mapping, label)) + .resolveSumstatKey, + df = df, + mapping = mapping, + label = label ) - if (any(have)) { + if (!all(map_lgl(alleleCols, .mlIsNaOrNull))) { return(df) # a real allele column always wins } idCol <- .resolveSumstatKey("variant_id", df, mapping, label) @@ -1332,13 +1319,15 @@ NULL # holds row identifiers; `transpose = TRUE` handles QTLtools-format inputs # (covariates as rows, samples as columns). .readCovariateMatrix <- function(path, transpose = FALSE) { - raw <- as.data.frame( - readr::read_tsv(path, show_col_types = FALSE, progress = FALSE), - check.names = FALSE + raw <- readr::read_tsv( + path, + show_col_types = FALSE, + progress = FALSE, + name_repair = "minimal" ) m <- `rownames<-`( - `storage.mode<-`(as.matrix(raw[, -1L, drop = FALSE]), "double"), - as.character(raw[[1L]]) + `storage.mode<-`(as.matrix(select(raw, -1L)), "double"), + as.character(pull(raw, 1L)) ) if (transpose) { return(t(m)) @@ -1359,8 +1348,6 @@ NULL ) } -# Read a phenotype BED into an expression matrix (genes x samples) + rowRanges. -# @noRd # Column names (and their case/alias variants) that are metadata, not # expression samples, in a phenotype BED. # @noRd @@ -1382,15 +1369,15 @@ NULL ) } +# Read a phenotype BED into an expression matrix (genes x samples) + rowRanges. +# @noRd .readPhenotypeBed <- function(bedPath) { - bed <- as.data.frame( - readr::read_tsv( - bedPath, - show_col_types = FALSE, - progress = FALSE, - comment = "" - ), - check.names = FALSE + bed <- readr::read_tsv( + bedPath, + show_col_types = FALSE, + progress = FALSE, + comment = "", + name_repair = "minimal" ) chrCol <- intersect(c("#chr", "#chrom", "chrom", "chr"), names(bed))[1L] startCol <- intersect(c("start", "Start"), names(bed))[1L] @@ -1404,12 +1391,12 @@ NULL abort(msg) } meta <- `names<-`( - bed[, c(chrCol, startCol, endCol, geneCol)], + select(bed, all_of(c(chrCol, startCol, endCol, geneCol))), c("chrom", "start", "end", "gene_id") ) sampleCols <- setdiff(names(bed), .bedReservedCols()) expr <- `rownames<-`( - `storage.mode<-`(as.matrix(bed[, sampleCols, drop = FALSE]), "double"), + `storage.mode<-`(as.matrix(select(bed, all_of(sampleCols))), "double"), meta$gene_id ) rr <- `names<-`( @@ -1501,7 +1488,7 @@ NULL ), contexts ) - genoHandle <- .resolveGenoHandle(rows, studyName, base, genotypesOverride) + genotypes <- .resolveGenotypes(rows, studyName, base, genotypesOverride) genoCov <- .resolveGenoCov( rows, studyName, @@ -1512,7 +1499,7 @@ NULL qtlArgs <- c( list( study = studyName, - genotypes = genoHandle, + genotypes = genotypes, phenotypes = phenotypes, genotypeCovariates = genoCov ), @@ -1561,11 +1548,12 @@ NULL .resolveRel(covs[[1L]], base) } -# The genotype handle: an override panel/path, else the study's single -# genotypePath (auto-detecting the format). +# The genotype panel: an override panel (or bare handle) as given, an +# override path, else the study's single genotypePath (auto-detecting the +# format). # @noRd -.resolveGenoHandle <- function(rows, studyName, base, genotypesOverride) { - open <- .openGenotypeHandle(genotypesOverride) +.resolveGenotypes <- function(rows, studyName, base, genotypesOverride) { + open <- .openGenotypeSource(genotypesOverride) if (!is.null(open)) { return(open) } @@ -1582,7 +1570,7 @@ NULL } v[[1L]] } - .detectGenotypeFormat(.resolveRel(spec, base)) + .readGenotypePath(.resolveRel(spec, base)) } # The genotype covariate matrix: an override matrix/path, else the study's @@ -1715,7 +1703,7 @@ loadQtlDatasetFromManifest <- function( nSample = c("nSample", "n_sample"), varY = c("varY", "var_y"), genome = c("genome"), - ldSketchPath = c("ldSketchPath", "ld_sketch_path", "ld_sketch") + ldReferencePath = c("ldReferencePath", "ld_reference_path", "ld_reference") ) .qtlSumStatsManifestAliases <- list( @@ -1738,7 +1726,7 @@ loadQtlDatasetFromManifest <- function( nSample = c("nSample", "n_sample"), varY = c("varY", "var_y"), genome = c("genome"), - ldSketchPath = c("ldSketchPath", "ld_sketch_path", "ld_sketch") + ldReferencePath = c("ldReferencePath", "ld_reference_path", "ld_reference") ) # TRUE if study `i` has usable case/control counts OR a total-N scalar, so a @@ -1758,18 +1746,18 @@ loadQtlDatasetFromManifest <- function( # range. The checks sit between the two steps because containment is only # answerable once the sketch is read, and trimming would hide a miss. # @noRd -.manifestGwasLdSketch <- function( - ldSketchSpec, +.manifestGwasLdRef <- function( + ldReferenceSpec, entries, df, minLdOverlapWarn ) { - materialized <- .materializeLdSketch( - ldSketchSpec, + materialized <- .materializeLdRef( + ldReferenceSpec, .entriesChroms(entries) ) .checkGwasLdContainment(materialized, entries, df, minLdOverlapWarn) - .subsetSketchToRange(materialized, entries) + .subsetLdRefToRange(materialized, entries) } #' @title Load a GwasSumStats collection from a manifest @@ -1782,27 +1770,29 @@ loadQtlDatasetFromManifest <- function( #' \code{study} (required, unique), \code{sumStatsPath} (required), #' \code{columnMapping} (optional), \code{nCase} / \code{nControl} (optional), #' \code{nSample} (optional study-level total N), \code{varY} (optional), and -#' the single-valued \code{genome} / \code{ldSketchPath}. When a row supplies -#' a study-level scalar (\code{nCase} + \code{nControl}, or \code{nSample}), -#' its sumstats file need not carry a per-variant \code{N} column; +#' the single-valued \code{genome} / \code{ldReferencePath}. When a row +#' supplies a study-level scalar (\code{nCase} + \code{nControl}, or +#' \code{nSample}), its sumstats file need not carry a per-variant \code{N} +#' column; #' \code{\link{summaryStatsQc}} fills \code{N} from the scalar. #' @param genome Genome build; reconciled with a \code{genome} column. -#' @param ldSketch A genotype panel (see \code{\link{readGenotypes}}) or a spec -#' (path/prefix/genoMeta); reconciled with an \code{ldSketchPath} column. +#' @param ldReference A genotype panel (see \code{\link{readGenotypes}}) or a +#' spec (path/prefix/genoMeta); reconciled with an \code{ldReferencePath} +#' column. #' @param region Optional \code{chr:start-end} string, GRanges, or one-row #' data.frame restricting the variants read (honoured only for tabix-indexed #' text and bgzipped+tabixed VCF; ignored with a warning otherwise). #' @param minLdOverlapWarn Warn when the fraction of sumstats variants present -#' in the LD sketch falls below this (default 0.5). +#' in the LD reference falls below this (default 0.5). #' @param columnMapping Optional default column mapping (a named list/vector, or #' a path to a YAML file of \code{standardName: sourceName} entries) applied #' when a row has no \code{columnMapping}. #' @param sampleSelect Optional GWAS-VCF FORMAT sample (study) column to read. #' @param formatMapping Optional GWAS-VCF FORMAT tag mapping (canonical stat -> #' FORMAT field), overriding ES/SE/LP/SS/EAF defaults. -#' @param ldBlocks Optional LD-block specification (an \code{LdBlocks}, a -#' \code{GRanges}, a data.frame with \code{chrom}/\code{start}/\code{end}, -#' or a path to such a table). Without it a genome-wide file splits into one +#' @param ldBlocks Optional LD-block specification (a \code{GRanges}, a +#' data.frame with \code{chrom}/\code{start}/\code{end}, or a path to such +#' a table). Without it a genome-wide file splits into one #' element per chromosome; with it, into one element per LD block, which is #' the granularity \code{\link{assembleCtwasInputs}} needs. #' @return A \code{GwasSumStats} object. @@ -1813,12 +1803,12 @@ loadQtlDatasetFromManifest <- function( #' package = "pecotmr"), "protocol_example.LD.chr22") #' manifest <- data.frame(study = "g1", sumStatsPath = gwasTsv) #' loadGwasSumStatsFromManifest(manifest = manifest, genome = "hg38", -#' ldSketch = ldStem, region = "chr22:10000000-19000000") +#' ldReference = ldStem, region = "chr22:10000000-19000000") #' @export loadGwasSumStatsFromManifest <- function( manifest, genome = NULL, - ldSketch = NULL, + ldReference = NULL, region = NULL, minLdOverlapWarn = 0.5, columnMapping = NULL, @@ -1837,7 +1827,7 @@ loadGwasSumStatsFromManifest <- function( abort("GwasSumStats manifest `study` values must be unique.") } genome <- .reconcileScalar(df[["genome"]], genome, "genome") - ldSketchSpec <- .resolveLdSketchInput(df, ldSketch, base) + ldReferenceSpec <- .resolveLdRefInput(df, ldReference, base) ns <- .gwasStudyScalars(df) entries <- map( seq_len(nrow(df)), @@ -1850,8 +1840,8 @@ loadGwasSumStatsFromManifest <- function( formatMapping = formatMapping, ns = ns ) - ldSketch <- .manifestGwasLdSketch( - ldSketchSpec, + ldReference <- .manifestGwasLdRef( + ldReferenceSpec, entries, df, minLdOverlapWarn @@ -1860,7 +1850,7 @@ loadGwasSumStatsFromManifest <- function( # is too coarse for cTWAS; with one, each study becomes one element per LD # block. The constructor does the splitting either way. gwasArgs <- list_assign( - .gwasSumStatsArgs(df, entries, genome, ldSketch, ns), + .gwasSumStatsArgs(df, entries, genome, ldReference, ns), ldBlocks = ldBlocks ) exec(GwasSumStats, !!!gwasArgs) @@ -1926,10 +1916,15 @@ loadGwasSumStatsFromManifest <- function( # Per-study LD-containment checks (deferred until the sketch is materialised). # @noRd -.checkGwasLdContainment <- function(ldSketch, entries, df, minLdOverlapWarn) { +.checkGwasLdContainment <- function( + ldReference, + entries, + df, + minLdOverlapWarn +) { for (i in seq_len(nrow(df))) { .checkLdContainment( - ldSketch, + ldReference, entries[[i]], minLdOverlapWarn, str_c("GwasSumStats[study=", df$study[[i]], "]") @@ -1939,13 +1934,13 @@ loadGwasSumStatsFromManifest <- function( # GwasSumStats() constructor args, including any present study scalars + varY. # @noRd -.gwasSumStatsArgs <- function(df, entries, genome, ldSketch, ns) { +.gwasSumStatsArgs <- function(df, entries, genome, ldReference, ns) { c( list( study = as.character(df$study), entry = entries, genome = genome, - ldSketch = ldSketch + ldReference = ldReference ), compact(list( nCase = ns$nCase, @@ -1998,14 +1993,14 @@ loadGwasSumStatsFromManifest <- function( #' \code{study}, \code{context}, \code{trait} (required), \code{sumStatsPath} #' (required), \code{columnMapping} (optional), \code{nSample} (optional #' tuple-level total N), \code{varY} (optional), and the single-valued -#' \code{genome} / \code{ldSketchPath}. When a row supplies \code{nSample}, +#' \code{genome} / \code{ldReferencePath}. When a row supplies \code{nSample}, #' its sumstats file need not carry a per-variant \code{N} column; #' \code{\link{summaryStatsQc}} fills \code{N} from the scalar. (Unlike the #' GWAS loader, there are no \code{nCase}/\code{nControl} columns: molecular #' QTL traits are quantitative.) #' @param genome Genome build; reconciled with a \code{genome} column. -#' @param ldSketch A genotype panel (see \code{\link{readGenotypes}}) or spec; -#' reconciled with an \code{ldSketchPath} column. +#' @param ldReference A genotype panel (see \code{\link{readGenotypes}}) or +#' spec; reconciled with an \code{ldReferencePath} column. #' @param region,minLdOverlapWarn,columnMapping,sampleSelect,formatMapping As #' for \code{\link{loadGwasSumStatsFromManifest}}. #' @param traitColumn Optional column of the sumstats file naming the trait of @@ -2033,12 +2028,12 @@ loadGwasSumStatsFromManifest <- function( #' manifest <- data.frame(study = "s1", context = "brain", #' trait = "ENSG1", sumStatsPath = tsv) #' loadQtlSumStatsFromManifest(manifest = manifest, genome = "hg38", -#' ldSketch = ldStem, region = "chr22:10000000-19000000") +#' ldReference = ldStem, region = "chr22:10000000-19000000") #' @export loadQtlSumStatsFromManifest <- function( manifest, genome = NULL, - ldSketch = NULL, + ldReference = NULL, region = NULL, minLdOverlapWarn = 0.5, columnMapping = NULL, @@ -2049,14 +2044,9 @@ loadQtlSumStatsFromManifest <- function( ) { variantIdAlleles <- arg_match(variantIdAlleles) base <- .manifestBase(manifest) - df <- .canonManifestCols( - .readManifest(manifest), - .qtlSumStatsManifestAliases, - required = c("study", "context", "trait", "sumStatsPath"), - label = "QtlSumStats" - ) + df <- .qtlSumStatsManifest(manifest) genome <- .reconcileScalar(df[["genome"]], genome, "genome") - ldSketchSpec <- .resolveLdSketchInput(df, ldSketch, base) + ldReferenceSpec <- .resolveLdRefInput(df, ldReference, base) nSample <- .qtlManifestNSample(df) entries <- .loadQtlSumStatsEntries( df, @@ -2069,21 +2059,53 @@ loadQtlSumStatsFromManifest <- function( traitColumn = traitColumn, variantIdAlleles = variantIdAlleles ) - - # Materialise the LD sketch reading only the chromosomes the summary stats - # cover (skips other shards of a chrom-sharded panel), check containment, - # then trim its snpInfo to the summary stats' per-chromosome position span. - materialized <- .materializeLdSketch( - ldSketchSpec, - .entriesChroms(entries) + ldReference <- .manifestQtlLdRef( + ldReferenceSpec, + entries, + df, + minLdOverlapWarn ) - .qtlSumStatsCheckContainment(materialized, entries, df, minLdOverlapWarn) - ldSketch <- .subsetSketchToRange(materialized, entries) - exec( QtlSumStats, - !!!.qtlSumStatsArgs(df, entries, genome, ldSketch, nSample$nSampleCol) + !!!.qtlSumStatsArgs( + df, + entries, + genome, + ldReference, + nSample$nSampleCol + ) + ) +} + +# A QtlSumStats manifest's rows, its columns under their canonical names and +# the required ones present. +# @noRd +.qtlSumStatsManifest <- function(manifest) { + .canonManifestCols( + .readManifest(manifest), + .qtlSumStatsManifestAliases, + required = c("study", "context", "trait", "sumStatsPath"), + label = "QtlSumStats" + ) +} + +# Materialise the LD sketch reading only the chromosomes the summary stats +# cover (skipping the other shards of a chrom-sharded panel), check +# containment, then trim it to the summary stats' per-chromosome position +# span, as .manifestGwasLdRef() does for a GwasSumStats manifest. +# @noRd +.manifestQtlLdRef <- function( + ldReferenceSpec, + entries, + df, + minLdOverlapWarn +) { + materialized <- .materializeLdRef( + ldReferenceSpec, + .entriesChroms(entries) ) + .qtlSumStatsCheckContainment(materialized, entries, df, minLdOverlapWarn) + .subsetLdRefToRange(materialized, entries) } # The tuple-level total-N scalar a manifest may carry, plus the per-row @@ -2106,17 +2128,17 @@ loadQtlSumStatsFromManifest <- function( # Per-row LD-containment check (no-op when the sketch is NULL). # @noRd .qtlSumStatsCheckContainment <- function( - ldSketch, + ldReference, entries, df, minLdOverlapWarn ) { - if (is.null(ldSketch)) { + if (is.null(ldReference)) { return(invisible(NULL)) } for (i in seq_len(nrow(df))) { .checkLdContainment( - ldSketch, + ldReference, entries[[i]], minLdOverlapWarn, str_c( @@ -2135,14 +2157,14 @@ loadQtlSumStatsFromManifest <- function( # Assemble the QtlSumStats() argument list from a canonicalised manifest. # @noRd -.qtlSumStatsArgs <- function(df, entries, genome, ldSketch, nSampleCol) { +.qtlSumStatsArgs <- function(df, entries, genome, ldReference, nSampleCol) { args <- list( study = as.character(df$study), context = as.character(df$context), trait = as.character(df$trait), entry = entries, genome = genome, - ldSketch = ldSketch + ldReference = ldReference ) c( args, @@ -2162,7 +2184,7 @@ loadQtlSumStatsFromManifest <- function( #' \code{study}); one \code{QtlDataset} is built per study group. #' @param sumStatsManifest Optional QtlSumStats manifest (see #' \code{\link{loadQtlSumStatsFromManifest}}). -#' @param genome,ldSketch,region,minLdOverlapWarn Passed to the QtlSumStats +#' @param genome,ldReference,region,minLdOverlapWarn Passed to the QtlSumStats #' loader for \code{sumStatsManifest}. #' @param columnMapping,sampleSelect,formatMapping Passed to the QtlSumStats #' loader for \code{sumStatsManifest}. @@ -2185,7 +2207,7 @@ loadMultiStudyQtlDatasetFromManifest <- function( qtlDatasetsManifest, sumStatsManifest = NULL, genome = NULL, - ldSketch = NULL, + ldReference = NULL, region = NULL, minLdOverlapWarn = 0.5, columnMapping = NULL, @@ -2207,7 +2229,7 @@ loadMultiStudyQtlDatasetFromManifest <- function( sumStats <- .msqLoadSumStats( sumStatsManifest, genome, - ldSketch, + ldReference, region, minLdOverlapWarn, columnMapping, @@ -2257,7 +2279,7 @@ loadMultiStudyQtlDatasetFromManifest <- function( .msqLoadSumStats <- function( sumStatsManifest, genome, - ldSketch, + ldReference, region, minLdOverlapWarn, columnMapping, @@ -2270,7 +2292,7 @@ loadMultiStudyQtlDatasetFromManifest <- function( loadQtlSumStatsFromManifest( sumStatsManifest, genome = genome, - ldSketch = ldSketch, + ldReference = ldReference, region = region, minLdOverlapWarn = minLdOverlapWarn, columnMapping = columnMapping, diff --git a/R/mashPipeline.R b/R/mashPipeline.R index 9c9301fee..055d4c254 100644 --- a/R/mashPipeline.R +++ b/R/mashPipeline.R @@ -285,7 +285,7 @@ mashPipeline <- function( # Every bundle mashPipeline() takes, checked together. # @noRd .mashPipelineAssert <- function(prior, mashDataArgs, mashArgs) { - .assertMethodParam(prior, "MashPriorParam", "prior") + .assertMethodParam(prior, "MashPriorParam") .assertMethodOptions(mashDataArgs, "MashDataOptions", "mashDataArgs") .assertMethodOptions(mashArgs, "MashOptions", "mashArgs") } @@ -652,9 +652,6 @@ mashCovarianceComponents <- function( .mashComponentList(c(built$canonical, built$dataDriven)) } -# `components` and `engine` each take a name or that choice's own -# constructor, so both resolve to a (name, options) pair the same way. -# @noRd # Both arguments arrive already normalized -- a MashComponentParam and an # Options record or NULL -- so this only splits them into the shapes the # cov_* chain downstream expects. NULL engine is "none": no refinement. @@ -669,6 +666,9 @@ mashCovarianceComponents <- function( ) } +# mashPriorCovariances() is exported with the same convenience arguments as +# MashPriorParam(), so it normalizes through the same helpers rather than +# resolving a second time in its own way. #' @title Estimate mash Prior Covariances and Mixture Weights #' @description Build the mash prior covariance list \code{U} and mixture #' weights \code{w} from a \code{{strong[, random, null]}} SumStats @@ -753,17 +753,10 @@ mashPriorCovariances <- function( .assertMethodOptions(mashDataArgs, "MashDataOptions", "mashDataArgs") .assertMethodOptions(mashArgs, "MashOptions", "mashArgs") inputScale <- arg_match(inputScale) - # Exported with the same convenience arguments as MashPriorParam(), so - # it normalizes through the same helpers rather than resolving a second - # time in its own way. choice <- .mashResolvePriorChoice( .mashNormalizeComponents(components), .mashNormalizeEngine(engine) ) - components <- choice$components - componentArgs <- choice$componentArgs - engine <- choice$engine - engineArgs <- choice$engineArgs .mashRequirePriorPackages() if (methods::is(sumStatsList, "SimpleList")) { sumStatsList <- as.list(sumStatsList) @@ -783,11 +776,11 @@ mashPriorCovariances <- function( mashData, priorCovariances = priorCovariances, priorComponents = priorComponents, - components = components, + components = choice$components, nPcs = nPcs, - engine = engine, - engineArgs = engineArgs, - componentArgs = componentArgs, + engine = choice$engine, + engineArgs = choice$engineArgs, + componentArgs = choice$componentArgs, mashArgs = mashArgs ) } @@ -939,25 +932,6 @@ MashComponentParam <- function( # Reject unknown prior-covariance component names. # @noRd -# `components` may be a character vector or a MashComponentParam() record. -# Naming a component in the record selects it, so the two forms carry the -# same information and the record additionally carries per-component options. -# @noRd -.mashResolveComponentChoice <- function(components) { - if (is(components, "MashComponentParam")) { - entries <- slot(components, "components") %||% list() - return(list(names = names(entries), args = entries)) - } - if (!is.character(components)) { - abort(glue( - "mashPriorCovariances: `components` must be a character vector ", - "or a MashComponentParam() record." - )) - } - .mashValidateComponents(components) - list(names = components, args = NULL) -} - .mashValidateComponents <- function( components, caller = "mashPriorCovariances" @@ -1358,9 +1332,6 @@ fitMashContrast <- function( ) } -# Pairwise (all-pairs) contrasts, with grouped conditions' contributions split -# evenly across the group. -# @noRd # One grouped condition's share of a pairwise column: the group's matched # contribution split evenly across its members. # @noRd @@ -1395,6 +1366,9 @@ fitMashContrast <- function( ) } +# Pairwise (all-pairs) contrasts, with grouped conditions' contributions split +# evenly across the group. +# @noRd .mashPairwiseContrast <- function(tested, grouping, pairwiseVector) { twoCombn <- combn(tested, 2) pwNames <- apply(twoCombn, 2, str_flatten, collapse = "_vs_") @@ -2550,7 +2524,7 @@ mergeMashData <- function(resData, oneData) { } msg <- glue( "mashInput: each element of `objects` must be a QtlSumStats, ", - "GwasSumStats, or FineMappingResult; got ", + "GwasSumStats, QtlFineMappingResult or GwasFineMappingResult; got ", "{str_flatten(class(obj), '/')}." ) abort(msg) @@ -2566,9 +2540,9 @@ mergeMashData <- function(resData, oneData) { list(b = mats$b, s = mats$s, strongRows = strongRows) } -# (Bhat, Shat, strongRows) from a FineMappingResult: pivot the marginal effects -# to a variants x contexts matrix pair; strong = each credible set's lead (max -# PIP) variant. +# (Bhat, Shat, strongRows) from a fine-mapping result: pivot the marginal +# effects to a variants x contexts matrix pair; strong = each credible set's +# lead (max PIP) variant. # @noRd .mashFmrMatrices <- function(obj, coverage) { rawMe <- marginalEffects(obj) @@ -2576,7 +2550,7 @@ mergeMashData <- function(resData, oneData) { if (!all(is_in(c("variant_id", "context", "beta", "se"), names(rawMe)))) { msg <- glue( "mashInput: marginalEffects() must return variant_id/context/", - "beta/se columns; a FineMappingResult with >= 2 contexts is ", + "beta/se columns; a fine-mapping result with >= 2 contexts is ", "required." ) abort(msg) @@ -2601,7 +2575,7 @@ mergeMashData <- function(resData, oneData) { ) } -# A multi-method FineMappingResult would duplicate (variant, context) cells; +# A multi-method fine-mapping result would duplicate (variant, context) cells; # pin the first method so the pivot is unambiguous. # @noRd .mashFmrMethodPin <- function(me, cs) { @@ -2610,7 +2584,7 @@ mergeMashData <- function(resData, oneData) { } m1 <- me$method[[1L]] msg <- glue( - "mashInput: FineMappingResult carries multiple methods; using ", + "mashInput: the fine-mapping result carries multiple methods; using ", "'{m1}'." ) warn(msg) @@ -2746,7 +2720,7 @@ mergeMashData <- function(resData, oneData) { #' \describe{ #' \item{strong}{The high-signal variants (deterministic, class-specific). #' \code{QtlSumStats}: the single most significant variant (\eqn{\max|z|}) -#' per condition, unioned. \code{FineMappingResult}: the lead variant +#' per condition, unioned. A fine-mapping result: the lead variant #' (\eqn{\max} PIP) of each credible set in each condition, unioned #' (conditions with no credible set contribute nothing).} #' \item{random}{\code{nRandom} variants sampled uniformly at random -- @@ -2762,21 +2736,21 @@ mergeMashData <- function(resData, oneData) { #' and the strong \code{XtX} cross-product appended. #' #' @param objects A named \code{list} of \code{\link{QtlSumStats}} and/or -#' \code{FineMappingResult} objects, one per region. Names disambiguate +#' fine-mapping result objects, one per region. Names disambiguate #' rownames across regions (defaults to \code{region1}, \code{region2}, ...). #' For \code{QtlSumStats} inputs \code{\link{summaryStatsQc}} must have been #' run (the matrix builder rejects un-QC'd SumStats). #' @param nRandom,nNull Per-object random / null sample sizes (default 10 each). #' @param excludeCondition Character vector of condition (column) names to drop. -#' @param coverage Credible-set coverage for \code{FineMappingResult} strong -#' selection (default 0.95). +#' @param coverage Credible-set coverage for the strong selection on +#' fine-mapping results (default 0.95). #' @param zOnly When \code{TRUE} the returned partitions carry only \code{.z} #' (the \code{.b}/\code{.s} matrices are dropped after z is derived). #' @param sigPCutoff Significance cutoff applied to the strong partition #' (default 1e-6). #' @param inputScale Matrix scale for \code{QtlSumStats} inputs #' (\code{"auto"}/\code{"beta"}/\code{"z"}); ignored for -#' \code{FineMappingResult} (always effect-size scale). +#' fine-mapping results (always effect-size scale). #' @param independentVariants Optional character vector of variant ids (e.g. an #' LD-pruned independent SNP list). When supplied, the \emph{random} and #' \emph{null} background of every object is restricted to variants that match @@ -2835,7 +2809,7 @@ mashInput <- function( if (!is.list(objects) || length(objects) == 0L) { msg <- glue( "mashInput: `objects` must be a non-empty list of QtlSumStats ", - "and/or FineMappingResult objects." + "and/or fine-mapping result objects." ) abort(msg) } @@ -2974,7 +2948,7 @@ mashInput <- function( #' variant ids (ideally \code{chr:pos:A2:A1}); \code{colnames(z)} label the #' conditions. #' @param studyName Study identifier (recycled across conditions). -#' @param ldSketch A genotype panel (see \code{\link{readGenotypes}}) +#' @param ldReference A genotype panel (see \code{\link{readGenotypes}}) #' embedded in the collection, or \code{NULL} (default) -- mash operates #' across #' conditions per variant and needs no LD reference. @@ -2997,13 +2971,13 @@ mashInput <- function( #' system.file("extdata", "toy_ref.bed", package = "pecotmr")) #' z <- matrix(rnorm(6), 2, 3, dimnames = list( #' c("chr22:1:A:G", "chr22:2:A:G"), c("brain", "blood", "muscle"))) -#' qtlSumStatsFromZMatrix(z = z, studyName = "s1", ldSketch = panel, +#' qtlSumStatsFromZMatrix(z = z, studyName = "s1", ldReference = panel, #' context = colnames(z), trait = "g1", genome = "hg38", n = 100) #' @export qtlSumStatsFromZMatrix <- function( z, studyName, - ldSketch = NULL, + ldReference = NULL, context = colnames(z), trait = "mash", genome = "GRCh38", @@ -3024,7 +2998,7 @@ qtlSumStatsFromZMatrix <- function( vids = vids, nCond = ncol(z), studyName = studyName, - ldSketch = ldSketch, + ldReference = ldReference, context = context, trait = trait, genome = genome, @@ -3050,7 +3024,7 @@ qtlSumStatsFromZMatrix <- function( #' @param shat Numeric matrix of standard errors, aligned with \code{bhat} #' (identical dimensions and row/column order). #' @param studyName Study identifier (recycled across conditions). -#' @param ldSketch A genotype panel (see \code{\link{readGenotypes}}) +#' @param ldReference A genotype panel (see \code{\link{readGenotypes}}) #' embedded in the collection, or \code{NULL} (default) -- mash operates #' across #' conditions per variant and needs no LD reference. @@ -3072,14 +3046,14 @@ qtlSumStatsFromZMatrix <- function( #' c("chr22:1:A:G", "chr22:2:A:G"), c("brain", "blood", "muscle"))) #' shat <- matrix(0.1, 2, 3, dimnames = dimnames(bhat)) #' qtlSumStatsFromBetaMatrix(bhat = bhat, shat = shat, studyName = "s1", -#' ldSketch = panel, context = colnames(bhat), trait = "g1", +#' ldReference = panel, context = colnames(bhat), trait = "g1", #' genome = "hg38", n = 100) #' @export qtlSumStatsFromBetaMatrix <- function( bhat, shat, studyName, - ldSketch = NULL, + ldReference = NULL, context = colnames(bhat), trait = "mash", genome = "GRCh38", @@ -3094,7 +3068,7 @@ qtlSumStatsFromBetaMatrix <- function( vids = vids, nCond = ncol(bhat), studyName = studyName, - ldSketch = ldSketch, + ldReference = ldReference, context = context, trait = trait, genome = genome, @@ -3174,7 +3148,7 @@ qtlSumStatsFromBetaMatrix <- function( vids, nCond, studyName, - ldSketch, + ldReference, context, trait, genome, @@ -3202,7 +3176,7 @@ qtlSumStatsFromBetaMatrix <- function( trait = trait, entry = entries, genome = genome, - ldSketch = ldSketch, + ldReference = ldReference, qcInfo = list(role = role, entryAudit = vector("list", nCond)) ) } diff --git a/R/mashWrapper.R b/R/mashWrapper.R index 4caddc888..a36871167 100644 --- a/R/mashWrapper.R +++ b/R/mashWrapper.R @@ -151,16 +151,16 @@ ) } -# Internal: build the requested data-driven covariance components off a prepared -# mashr data object, in a fixed order (canonical, pca, flash, flashNonneg) so a -# given `components` set reproduces the same ordering everywhere. RNG is -# consumed only by cov_flash / cov_flash(nonneg). Shared by mashPriorCovariances -# and the exported mashCovarianceComponents. -# @noRd # Build the requested components, keeping the two roles apart: `canonical` # are fixed structural hypotheses that go to the mash fit unrefined, while # `dataDriven` are the generator output the engine refines. mashr's own eQTL # vignette draws exactly this line -- cov_ed sees only the data-driven set. +# +# The components are built off a prepared mashr data object in a fixed order +# (canonical, pca, flash, flashNonneg), so a given `components` set +# reproduces the same ordering everywhere. RNG is consumed only by cov_flash +# / cov_flash(nonneg). Shared by mashPriorCovariances and the exported +# mashCovarianceComponents. # @noRd .mashBuildComponents <- function( mashData, @@ -169,26 +169,34 @@ componentArgs = NULL ) { npc <- nPcs %||% (ncol(mashData$Bhat) - 1) - argsFor <- function(key) as.list(componentArgs[[key]] %||% list()) canonical <- if (is_in("canonical", components)) { exec( mashr::cov_canonical, mashData, - !!!compact(argsFor("canonical")) + !!!compact(.mashComponentArgs("canonical", componentArgs)) ) } pca <- if (is_in("pca", components)) { - exec(mashr::cov_pca, mashData, npc = npc, !!!compact(argsFor("pca"))) + exec( + mashr::cov_pca, + mashData, + npc = npc, + !!!compact(.mashComponentArgs("pca", componentArgs)) + ) } flash <- if (is_in("flash", components)) { - exec(mashr::cov_flash, mashData, !!!compact(argsFor("flash"))) + exec( + mashr::cov_flash, + mashData, + !!!compact(.mashComponentArgs("flash", componentArgs)) + ) } flashNonneg <- if (is_in("flashNonneg", components)) { exec( mashr::cov_flash, mashData, factors = "nonneg", - !!!compact(argsFor("flashNonneg")) + !!!compact(.mashComponentArgs("flashNonneg", componentArgs)) ) } list( @@ -197,6 +205,12 @@ ) } +# The caller's extra arguments for one component generator, as a list. +# @noRd +.mashComponentArgs <- function(key, componentArgs) { + as.list(componentArgs[[key]] %||% list()) +} + # The covariance list and its mixture weights. A supplied `priorCovariances` # short-circuits the cov_* chain; either way the weights come from a # weights-only mash() fit unless the covariance step already produced them diff --git a/R/pvalCombineWrappers.R b/R/pvalCombineWrappers.R index 2fe643076..10cfbf118 100644 --- a/R/pvalCombineWrappers.R +++ b/R/pvalCombineWrappers.R @@ -132,7 +132,33 @@ pvalPoolr <- function(pvals, method, R, methodArgs = PoolrOptions()) { invchisq = poolr::invchisq, .abortUnknownMethod("poolr", method) ) - exec(fn, pvals, R = R, !!!as.list(methodArgs))$p + args <- as.list(methodArgs) + exec(fn, pvals, R = .poolrDependence(R, method, args), !!!args)$p +} + +# `R` in the form poolr's adjustment reads it. `R` holds the correlations +# among the test statistics. The generalized adjustment wants the covariances +# among each test's transformed statistic (-2 log p for Fisher, z for +# Stouffer, the 1-df chi-square for invchisq), and the effective-number +# adjustments want the correlations among the p-values; mvnconv() converts to +# both. "empirical" simulates from the statistics' own correlations. +# @noRd +.poolrDependence <- function(R, method, args) { + adjust <- args$adjust %||% "none" + if (is.null(R) || is_in(adjust, c("none", "empirical"))) { + return(R) + } + side <- args$side %||% 2 + if (identical(adjust, "generalized")) { + target <- switch( + method, + fisher = "m2lp", + stouffer = "z", + invchisq = "chisq1" + ) + return(poolr::mvnconv(R, side = side, target = target)) + } + poolr::mvnconv(R, side = side, target = "p", cov2cor = TRUE) } pvalGbj <- function(zScores, R, method, methodArgs = GbjOptions()) { @@ -290,8 +316,14 @@ pvalAspu <- function( # Internal: compute one method's combined p-value. Assumes inputs have # already been validity-filtered (positive, finite, < 1) and aligned with R. -.combinePvalSingle <- function(method, pvals, zScores, R, methodArgs = list()) { - args <- .combinePvalMethodArgs(methodArgs, method) +.combinePvalSingle <- function( + method, + pvals, + zScores, + R, + pvalMethodsParam = list() +) { + args <- .combinePvalMethodArgs(pvalMethodsParam, method) switch( method, acat = pvalAcat(pvals), @@ -327,8 +359,8 @@ pvalAspu <- function( # constructor's result rather than list() keeps each engine's pecotmr # defaults -- poolr's `adjust = "generalized"` -- in force either way. # @noRd -.combinePvalMethodArgs <- function(methodArgs, method) { - entries <- .pvalMethodEntriesOf(methodArgs) +.combinePvalMethodArgs <- function(pvalMethodsParam, method) { + entries <- .pvalMethodEntriesOf(pvalMethodsParam) i <- match(method, names(entries)) if (!is.na(i)) { return(entries[[i]]) @@ -340,11 +372,11 @@ pvalAspu <- function( # The per-method entries, whether they arrived in a PvalMethodsParam or as # the bare list() that still means "no settings". # @noRd -.pvalMethodEntriesOf <- function(methodArgs) { - if (is(methodArgs, "PvalMethodsParam")) { - return(slot(methodArgs, "methods") %||% list()) +.pvalMethodEntriesOf <- function(pvalMethodsParam) { + if (is(pvalMethodsParam, "PvalMethodsParam")) { + return(slot(pvalMethodsParam, "methods") %||% list()) } - methodArgs %||% list() + pvalMethodsParam %||% list() } #' Combine P-values via Any of a Menu of Methods @@ -379,11 +411,12 @@ pvalAspu <- function( #' @param zScores Optional numeric vector of signed z-scores. #' @param methods Character vector of combination method names; see above for #' the menu (lowercase). -#' @param R Optional correlation matrix aligned to \code{pvals} / +#' @param R Optional correlation matrix among the test statistics (for +#' variant-level tests, their LD), aligned to \code{pvals} / #' \code{zScores}. Required for the correlation-adjusted methods. #' @param naRm Logical; if \code{TRUE} (default), drop NA p-values before #' combination. -#' @param methodArgs Per-method engine options, built with +#' @param pvalMethodsParam Per-method engine options, built with #' \code{\link{PvalMethodsParam}} -- for example #' \code{PvalMethodsParam(aspu = AspuOptions(n.perm = 5000))}. Configuring #' a method that \code{methods} does not request is an error rather than a @@ -407,12 +440,12 @@ combinePValues <- function( methods, R = NULL, naRm = TRUE, - methodArgs = PvalMethodsParam() + pvalMethodsParam = PvalMethodsParam() ) { assertFlag(naRm) - .assertMethodParam(methodArgs, "PvalMethodsParam", "methodArgs") + .assertMethodParam(pvalMethodsParam, "PvalMethodsParam") methods <- .combinePvalCheckMethods(methods) - .combinePvalCheckMethodArgs(methodArgs, methods) + .combinePvalCheckMethodArgs(pvalMethodsParam, methods) nPvalsIn <- if (is.null(pvals)) 0L else length(pvals) nZScoresIn <- if (is.null(zScores)) 0L else length(zScores) .combinePvalCheckPrereqs(methods, zScores, R) @@ -435,7 +468,7 @@ combinePValues <- function( filt$pvalsK, filt$zScoresK, Raligned, - methodArgs + pvalMethodsParam ) .combinePvalResult(perMethod, input) } @@ -462,14 +495,14 @@ combinePValues <- function( # Options for a method that was not requested would be dropped in silence -- # exactly the failure the constructors exist to prevent -- so say so instead. # @noRd -.combinePvalCheckMethodArgs <- function(methodArgs, methods) { - configured <- names(.pvalMethodEntriesOf(methodArgs)) +.combinePvalCheckMethodArgs <- function(pvalMethodsParam, methods) { + configured <- names(.pvalMethodEntriesOf(pvalMethodsParam)) unused <- setdiff(configured, methods) if (length(unused) == 0L) { return(invisible(NULL)) } msg <- glue( - "combinePValues: `methodArgs` configures ", + "combinePValues: `pvalMethodsParam` configures ", "{str_flatten(unused, ', ')}, which `methods` does not request ", "({str_flatten(methods, ', ')}), so those options would be ignored." ) @@ -584,7 +617,7 @@ combinePValues <- function( pvalsK, zScoresK, Raligned, - methodArgs + pvalMethodsParam ) { set_names( map( @@ -593,7 +626,7 @@ combinePValues <- function( pvalsK = pvalsK, zScoresK = zScoresK, Raligned = Raligned, - methodArgs = methodArgs + pvalMethodsParam = pvalMethodsParam ), methods ) @@ -601,14 +634,20 @@ combinePValues <- function( # @noRd #' @importFrom rlang try_fetch -.combinePvalRunOne <- function(m, pvalsK, zScoresK, Raligned, methodArgs) { +.combinePvalRunOne <- function( + m, + pvalsK, + zScoresK, + Raligned, + pvalMethodsParam +) { p <- try_fetch( .combinePvalSingle( m, pvals = pvalsK, zScores = zScoresK, R = Raligned, - methodArgs = methodArgs + pvalMethodsParam = pvalMethodsParam ), error = function(cnd) { msg <- glue("combinePValues: method '{m}' failed") @@ -740,7 +779,12 @@ AspuOptions <- function(...) { #' \code{m}, \code{size}, \code{threshold}, \code{side}, \code{batchsize} #' and \code{nearpd}. The \pkg{poolr} signatures end in \code{...}, so #' names cannot be checked here and a misspelling is passed through. -#' \code{p} and \code{R} are supplied by pecotmr and refused. +#' \code{p} and \code{R} are supplied by pecotmr and refused: \code{R} is +#' the caller's correlation among the test statistics, which pecotmr +#' converts with \code{poolr::mvnconv()} into the form the adjustment +#' reads (the covariances of each test's transformed statistic for +#' \code{"generalized"}, the correlations among the p-values for the +#' effective-number adjustments, unchanged for \code{"empirical"}). #' @return A \code{MethodOptions} record for #' \code{\link{PvalMethodsParam}}. #' @seealso \code{\link{combinePValues}} diff --git a/R/qtlAssociationPostprocess.R b/R/qtlAssociationPostprocess.R index 33ff5470c..375fb9d1c 100644 --- a/R/qtlAssociationPostprocess.R +++ b/R/qtlAssociationPostprocess.R @@ -283,9 +283,6 @@ QvalueOptions <- function(...) { keep & !is.na(keep) } -# Q-value significance: per-entry mask of variant q-values below the threshold -# for the FDR-significant genes. -# @noRd # Entry `i`'s q-value mask, or the incoming mask when the gene is not # FDR-significant or carries no per-variant q-values. # @noRd @@ -297,6 +294,9 @@ QvalueOptions <- function(...) { !is.na(mc$qvalue) & mc$qvalue < threshold } +# Q-value significance: per-entry mask of variant q-values below the threshold +# for the FDR-significant genes. +# @noRd .qapMaskQvalue <- function(x, masks, threshold) { qCol <- if (!is.null(x$q_beta)) "q_beta" else "q_bonferroni_min_original" if (is.null(.tupleColumn(x, qCol))) { @@ -381,7 +381,7 @@ setMethod( methods::new( "QtlSumStats", grl, - ldSketch = ldSketch(x), + ldReference = ldReference(x), qcInfo = qcInfo ) } @@ -565,10 +565,6 @@ setMethod( as.numeric(x$n_variants) } -# Per-gene min Bonferroni-adjusted p (original + filtered). The upstream p-value -# pre-filter always retains the global-min variant, so the min over the entry is -# the exact per-gene min. Returns list(orig, filt). -# @noRd # One gene's Bonferroni-adjusted minimum p-value, before and after the # variant filter. NA on either side means the gene had nothing to adjust. # @noRd @@ -606,6 +602,10 @@ setMethod( ) } +# Per-gene min Bonferroni-adjusted p (original + filtered). The upstream p-value +# pre-filter always retains the global-min variant, so the min over the entry is +# the exact per-gene min. Returns list(orig, filt). +# @noRd .qapBonferroniPerGene <- function( x, nVar, diff --git a/R/qtlEnrichmentPipeline.R b/R/qtlEnrichmentPipeline.R index fbf510f16..ff8a69d72 100644 --- a/R/qtlEnrichmentPipeline.R +++ b/R/qtlEnrichmentPipeline.R @@ -80,30 +80,33 @@ QtlEnrichmentParam <- function( #' @section Inputs: #' \itemize{ #' \item \code{gwasFineMappingResult}: the genome-wide outcome collection. -#' Each entry's \code{FineMappingRow$trimmedFit} must carry a \code{pip} +#' Each row's stored fit (\code{\link{susieFit}}) must carry a \code{pip} #' vector. One PIP vector is built per outcome trait -- keyed by #' \code{study} for a GWAS collection (one trait per study) and by #' (\code{study}, \code{context}, \code{trait}) for a QTL one, since a #' variant's PIP differs between molecular traits and pooling them would #' collide. -#' \item \code{qtlFineMappingResult}: the annotation collection. Each entry's -#' \code{trimmedFit} must carry \code{alpha}, \code{pip}, and +#' \item \code{qtlFineMappingResult}: the annotation collection. Each row's +#' stored fit must carry \code{alpha}, \code{pip}, and #' prior-variance fields (\code{V}). Its region fits are pooled per #' (\code{study}, \code{context}) -- per \code{study} alone for a GWAS #' collection, which has no context axis. #' } #' -#' @section LD-sketch compatibility check: A GWAS outcome collection must have -#' a non-NULL \code{ldSketch} (it should be RSS-derived). Where both sides -#' carry one, the two must come from the same reference panel --- same -#' samples, same allele orientation on the variants they share --- but need -#' NOT carry the same variants: QC-ing the two sides separately trims each -#' sketch to its own surviving variants, and a partial overlap only warns. A +#' @section LD reference compatibility check: A GWAS outcome collection +#' must have a non-NULL \code{ldReference} (it should be RSS-derived). Where +#' both sides carry one, the two must be the same LD reference. +#' The two must be the same kind of reference. Two genotype panels must +#' share their samples and allele orientation; two \code{LdMatrix} objects +#' must agree on the LD they share; two \code{GenotypeMixture} objects must +#' average the same panels with the same weights. They need NOT carry the +#' same variants: QC-ing the two sides separately trims each reference to +#' its own surviving variants, and a partial overlap only warns. A #' \code{NULL} on either side (an individual-level fit) skips the check. #' #' @param gwasFineMappingResult The outcome side; see above. #' @param qtlFineMappingResult The annotation side; see above. -#' @param methodArgs The estimator's algorithmic settings, built with +#' @param qtlEnrichmentParam The estimator's algorithmic settings, built with #' \code{\link{QtlEnrichmentParam}}: \code{numGwas}, \code{piQtl}, #' \code{lambda}, \code{impN}, \code{doubleShrinkage} and #' \code{besselCorrection}. A bare list is refused, since it cannot be @@ -147,12 +150,12 @@ QtlEnrichmentParam <- function( qtlEnrichmentPipeline <- function( gwasFineMappingResult, qtlFineMappingResult, - methodArgs = QtlEnrichmentParam(), + qtlEnrichmentParam = QtlEnrichmentParam(), numThreads = 1L, seed = NULL, verbose = TRUE ) { - .assertMethodParam(methodArgs, "QtlEnrichmentParam", "methodArgs") + .assertMethodParam(qtlEnrichmentParam, "QtlEnrichmentParam") .enrValidateInputs(gwasFineMappingResult, qtlFineMappingResult) prep <- .enrPrepare(gwasFineMappingResult, qtlFineMappingResult) gwasTuples <- prep$gwasTuples @@ -164,7 +167,7 @@ qtlEnrichmentPipeline <- function( gwasPipByTuple = prep$gwasPipByTuple, qtlRegionsByTuple = prep$qtlRegionsByTuple, alignedByTuple = alignedByTuple, - methodArgs = methodArgs, + qtlEnrichmentParam = qtlEnrichmentParam, numThreads = numThreads, seed = seed, verbose = verbose, @@ -186,22 +189,22 @@ qtlEnrichmentPipeline <- function( fmrClasses <- c("GwasFineMappingResult", "QtlFineMappingResult") assertMultiClass(gwasFineMappingResult, fmrClasses) assertMultiClass(qtlFineMappingResult, fmrClasses) - outcomeLd <- ldSketch(gwasFineMappingResult) + outcomeLd <- ldReference(gwasFineMappingResult) if ( is.null(outcomeLd) && methods::is(gwasFineMappingResult, "GwasFineMappingResult") ) { msg <- glue( - "qtlEnrichmentPipeline: the GWAS FineMappingResult must have a ", - "non-NULL ldSketch (it should be RSS-derived)." + "qtlEnrichmentPipeline: the GwasFineMappingResult must have a ", + "non-NULL ldReference (it should be RSS-derived)." ) abort(msg) } # Lenient rather than qtl-required: a QTL outcome side may be an # individual-level fit carrying no panel, and the requirement above already # covers the RSS-derived GWAS case. - .requireMatchingLdSketches( - ldSketch(qtlFineMappingResult), + .requireMatchingLdRefs( + ldReference(qtlFineMappingResult), outcomeLd, pipelineName = "qtlEnrichmentPipeline", nullPolicy = "lenient" @@ -343,7 +346,7 @@ qtlEnrichmentPipeline <- function( gwasPipByTuple, qtlRegionsByTuple, alignedByTuple = alignedByTuple, - methodArgs, + qtlEnrichmentParam, numThreads, seed, verbose, @@ -369,7 +372,7 @@ qtlEnrichmentPipeline <- function( gwasPip = gwasPip, qtlRegionsByTuple = qtlRegionsByTuple, alignedByTuple = alignedByTuple, - methodArgs = methodArgs, + qtlEnrichmentParam = qtlEnrichmentParam, numThreads = numThreads, seed = seed, verbose = verbose, @@ -389,7 +392,7 @@ qtlEnrichmentPipeline <- function( gwasPip, qtlRegionsByTuple, alignedByTuple = alignedByTuple, - methodArgs, + qtlEnrichmentParam, numThreads, seed, verbose, @@ -412,7 +415,7 @@ qtlEnrichmentPipeline <- function( gwasPip, k, alignedByTuple = alignedByTuple, - methodArgs = methodArgs, + qtlEnrichmentParam = qtlEnrichmentParam, numThreads = numThreads, seed = seed, verbose = verbose, @@ -457,7 +460,7 @@ qtlEnrichmentPipeline <- function( gwasPip, k, alignedByTuple, - methodArgs, + qtlEnrichmentParam, numThreads, seed, verbose, @@ -473,7 +476,7 @@ qtlEnrichmentPipeline <- function( cnd_signal(aligned) } # alignNames = FALSE reuses the per-tuple alignment; it is the - # pipeline's own invariant, which is why `methodArgs` cannot + # pipeline's own invariant, which is why `qtlEnrichmentParam` cannot # carry it -- QtlEnrichmentParam() has no such formal. exec( qtlEnrichment, @@ -483,7 +486,7 @@ qtlEnrichmentPipeline <- function( seed = seed, verbose = verbose, alignNames = FALSE, - !!!methodArgs + !!!qtlEnrichmentParam ) }, error = function(cnd) { @@ -545,14 +548,6 @@ qtlEnrichmentPipeline <- function( map(regions, .enrAlignRegion, unionGwasNames = unionGwasNames) } -# Build a named outcome PIP vector for one trait. Walks every row of the -# collection carrying that identity, extracts the per-row pip from each -# FineMappingRow, and concatenates with variant-id names. Errors if any single -# variant appears with conflicting PIP values across rows -- which is why the -# identity is the full trait tuple: pooling two molecular traits of one study -# would collide on every variant they share. -#' @importFrom dplyr add_count -#' @noRd # One row's PIP vector keyed by variant id, or NULL when the row carries no # fit, no PIPs, or ids that do not line up with them. # @noRd @@ -570,6 +565,14 @@ qtlEnrichmentPipeline <- function( set_names(pip, as.character(ids)) } +# Build a named outcome PIP vector for one trait. Walks every row of the +# collection carrying that identity, extracts the per-row pip from each +# FineMappingRow, and concatenates with variant-id names. Errors if any single +# variant appears with conflicting PIP values across rows -- which is why the +# identity is the full trait tuple: pooling two molecular traits of one study +# would collide on every variant they share. +#' @importFrom dplyr add_count +#' @noRd .enrBuildGwasPipVector <- function(gwasFmr, ident) { idx <- .enrMatchRows(gwasFmr, ident) if (length(idx) == 0L) { @@ -662,16 +665,16 @@ qtlEnrichmentPipeline <- function( # Project qtlEnrichment()'s output onto the columns this pipeline publishes. # # The field names are the estimator's own, written in src/qtl_enrichment.h and -# shared verbatim with upstream fastenloc's enloc.enrich.out, so they are +# shared verbatim with the original fastenloc's enloc.enrich.out, so they are # matched literally rather than guessed at. The shrinkage estimates are the -# ones reported, matching upstream, which likewise switches to the shrunk a1 -# before deriving the coloc priors. +# ones reported, matching the original fastenloc, which likewise switches to +# the shrunk a1 before deriving the coloc priors. # -# `enrichment` is expm1 of the log-odds a1 rather than a1 itself, because -# colocPipeline consumes it as `p12 * (1 + enrichment)`, which is then exactly -# the enloc-adjusted prior `p12 * exp(a1)` -- and leaves p12 untouched for an -# unenriched annotation (a1 = 0). expm1 is bounded below by -1, so a depleted -# annotation shrinks p12 towards 0 rather than past it. +# `enrichment` is expm1 of the log-odds a1 rather than a1 itself: the +# relative change in an annotated variant's odds of being a QTL, 0 for an +# unenriched annotation and bounded below by -1. colocPipeline reports it +# beside each pair; its priors are the coloc p1 / p2 / p12 the estimator +# derives (colocP1, colocP2, colocP12), not a rescaling of this column. # @noRd .enrFlattenEnrichment <- function(enr) { if (!is.list(enr) || !is_in("Enrichment (w/ shrinkage)", names(enr))) { @@ -728,7 +731,7 @@ qtlEnrichmentPipeline <- function( # ----------------------------------------------------------------------------- # Per-(GWAS, QTL-region-list) enrichment estimator. Called per-(gwasStudy, # qtlContext) pair by qtlEnrichmentPipeline above. Uses the fastenloc-style -# C++ kernel (qtlEnrichmentRcpp) under the hood. +# C++ kernel (qtlEnrichmentCpp) under the hood. # ============================================================================= #' @title Implementation of enrichment analysis described in #' https://doi.org/10.1371/journal.pgen.1006646 @@ -785,7 +788,7 @@ qtlEnrichmentPipeline <- function( #' \code{sd (w/ shrinkage)}, \code{Alternative (coloc) p1} / \code{p2} / #' \code{p12} and \code{Effective MI rounds} -- plus #' \code{unused_xqtl_variants}, the QTL variants of each region that no GWAS -#' variant matched. The names are upstream fastenloc's; +#' variant matched. The names are the original fastenloc's; #' \code{\link{qtlEnrichmentPipeline}} is what renames them to a tidy table. #' #' @examples @@ -848,7 +851,7 @@ qtlEnrichment <- function( unmatchedVariants <- map(aligned, "unmatched_variants") susieQtlRegions <- map(aligned, .enrStripUnmatched) # cpp11 requires exact integer types for int parameters. - en <- qtlEnrichmentRcpp( + en <- qtlEnrichmentCpp( rGwasPip = gwasPip, rQtlSusieFit = susieQtlRegions, piGwas = piGwas, diff --git a/R/qtlSumStats.R b/R/qtlSumStats.R index fabac26a1..ac68c7b93 100644 --- a/R/qtlSumStats.R +++ b/R/qtlSumStats.R @@ -3,7 +3,7 @@ # ----------------------------------------------------------------------------- # DFrame-subclass collection keyed by the identity tuple (study, context, # trait). Each row holds a per-tuple GRanges of summary statistics -# (variant_id + per-variant Z/N/MAF mcols). Class-level slots ldSketch +# (variant_id + per-variant Z/N/MAF mcols). Class-level slots ldReference # (a GenotypeHandle for the LD reference) + genome (the genome build) # apply uniformly across rows. Built-in qcInfo slot tracks which # summaryStatsQc() passes have been run. @@ -19,7 +19,7 @@ NULL #' Z / N / MAF mcols. #' @details Required columns: \code{study}, \code{context} and \code{trait}; #' the 3-tuple is unique. The class-level slots inherited from -#' \code{\linkS4class{SumStatsBase}} -- \code{ldSketch}, \code{genome} and +#' \code{\linkS4class{SumStatsBase}} -- \code{ldReference}, \code{genome} and #' \code{qcInfo} -- apply uniformly to every row, and \code{qcInfo} records #' which \code{\link{summaryStatsQc}} passes have run. #' @seealso \code{\link{QtlSumStats}} for the constructor and @@ -97,7 +97,7 @@ NULL #' @title Create a QtlSumStats Collection Object #' @description Construct a \code{QtlSumStats} S4 DFrame-subclass collection #' from per-tuple vectors and a list of \code{GRanges} entries (one per -#' tuple), plus a single LD sketch handle and a single genome build that apply +#' tuple), plus a single LD reference and a single genome build that apply #' to the whole collection. Each \code{GRanges} entry must carry per-variant #' statistics in its mcols (\code{SNP}, \code{A1}, \code{A2}, \code{Z}, #' \code{N}; plus optional \code{MAF}, \code{INFO}, \code{BETA}, \code{SE}, @@ -109,9 +109,10 @@ NULL #' Same length as \code{study}, \code{context}, and \code{trait}. #' @param genome Single character string giving the genome build (e.g., #' \code{"hg19"}, \code{"hg38"}). Uniform across the collection because all -#' entries share the same LD sketch. -#' @param ldSketch A genotype panel (see \code{\link{readGenotypes}}) -#' carrying the LD reference. +#' entries share the same LD reference. +#' @param ldReference The LD reference: a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +#' \code{\link{LdMatrix}}. #' @param varY Optional numeric vector of per-tuple phenotype variances #' (\code{NA_real_} entries allowed). #' @param nSample Optional per-tuple total sample size (numeric; default @@ -141,7 +142,7 @@ NULL #' S4Vectors::mcols(gr) <- S4Vectors::DataFrame(SNP = paste0("rs", 1:3), #' A1 = "A", A2 = "G", Z = rnorm(3), N = 100L) #' QtlSumStats(studyName = "s1", context = "brain", trait = "g1", entry = -#' list(gr), genome = "hg38", ldSketch = panel) +#' list(gr), genome = "hg38", ldReference = panel) #' @export QtlSumStats <- function( studyName, @@ -149,7 +150,7 @@ QtlSumStats <- function( trait, entry, genome, - ldSketch = NULL, + ldReference = NULL, varY = NA_real_, nSample = NULL, qcInfo = list(), @@ -190,7 +191,7 @@ QtlSumStats <- function( GenomicRanges::GRangesList(split$entry), value = md[split$fromIdx, , drop = FALSE] ) - .sumStatsNewValidated("QtlSumStats", grl, ldSketch, genome, qcInfo) + .sumStatsNewValidated("QtlSumStats", grl, ldReference, genome, qcInfo) } # Validate genome / entry / length consistency and recycle varY. Returns the @@ -200,7 +201,7 @@ QtlSumStats <- function( if (length(genome) != 1L) { msg <- glue( "`genome` must be a single character string (one build per ", - "collection, because all entries share the LD sketch)." + "collection, because all entries share the LD reference)." ) abort(msg) } @@ -523,21 +524,17 @@ setMethod("show", "QtlSumStats", function(object) { .trim = FALSE )) } - ld <- ldSketch(object) + ld <- ldReference(object) ldSrc <- if (is.null(ld)) { "none (LD-free)" } else { - .ldSketchLabel(ld) + .ldRefLabel(ld) } - cat(glue(" LD sketch: {ldSrc}\n", .trim = FALSE)) + cat(glue(" LD reference: {ldSrc}\n", .trim = FALSE)) }) # ---- map/apply helpers (lambda-free callbacks) --------------------------- -# Column `cn` of `object`, via `[[` (preserves the required `entry` column that -# `object[, cn]` would drop). -# @noRd - # Append tss_distance / tes_distance mcols to entry `i` from traitPos[i] (no-op # when the entry is empty or the trait position is unset). Existing distance # mcols are preserved. @@ -573,10 +570,6 @@ setMethod("show", "QtlSumStats", function(object) { ) } -# Entry `i` of a SumStats collection restricted to chromosome `chrName`. Shared -# by the QtlSumStats and GwasSumStats subsetChr methods. -# @noRd - #' Combine QtlSumStats collections #' #' Row-bind two or more \code{\link{QtlSumStats}} collections into one -- e.g. @@ -587,14 +580,14 @@ setMethod("show", "QtlSumStats", function(object) { #' The three collection-level slots are merged rather than taken from the first #' input, on the same rules as \code{\link{combineGwasSumStats}}: \code{genome} #' and the \code{\link{summaryStatsQc}} options must agree, the per-element -#' \code{qcInfo$entryAudit} concatenates in element order, and the LD sketches -#' union over the shared genotype handle (all-\code{NULL} stays \code{NULL}, -#' which is the usual case for individual-level QTL data). +#' \code{qcInfo$entryAudit} concatenates in element order, and the LD +#' references combine the same way (all-\code{NULL} stays \code{NULL}, which +#' is the usual case for individual-level QTL data). #' #' @param ... Two or more \code{QtlSumStats} objects, or a single \code{list} #' of them. -#' @param ldSketch Optional genotype panel (see \code{\link{readGenotypes}}) to -#' attach to the combined collection, overriding the unioned one. Default +#' @param ldReference Optional genotype panel (see \code{\link{readGenotypes}}) +#' to attach to the combined collection, overriding the unioned one. Default #' \code{NULL}. #' @return A single combined \code{QtlSumStats}. #' @seealso \code{\link{combineGwasSumStats}}, @@ -603,7 +596,7 @@ setMethod("show", "QtlSumStats", function(object) { #' data(qtlSumStatsExample) #' combineQtlSumStats(qtlSumStatsExample) #' @export -combineQtlSumStats <- function(..., ldSketch = NULL) { +combineQtlSumStats <- function(..., ldReference = NULL) { parts <- .asCombineList( list(...), "QtlSumStats", @@ -612,5 +605,5 @@ combineQtlSumStats <- function(..., ldSketch = NULL) { if (length(parts) == 1L) { return(parts[[1L]]) } - .rbindSumStats(parts, ldSketch, "combineQtlSumStats") + .rbindSumStats(parts, ldReference, "combineQtlSumStats") } diff --git a/R/regularizedRegressionWrappers.R b/R/regularizedRegressionWrappers.R index 4c880976b..33de5fc23 100644 --- a/R/regularizedRegressionWrappers.R +++ b/R/regularizedRegressionWrappers.R @@ -2,23 +2,35 @@ NULL #' Extract weights from mr.ash.rss (susieR) -#' @param stat A list of summary statistics with elements \code{b} (effect -#' sizes), \code{seb} (standard errors) and \code{n} (per-variant sample -#' sizes). -#' @param LD Numeric LD (correlation) matrix aligned to the variants in -#' \code{stat}. -#' @param varY Numeric. Variance of the phenotype. -#' @param sigma2E Numeric. Residual error variance estimate. -#' @param s0 Numeric vector of prior mixture standard deviations (the sigma0 -#' grid). -#' @param w0 Numeric vector of prior mixture weights (summing to 1). -#' @param z Optional numeric vector of z-scores; defaults to \code{numeric(0)} -#' (derived from \code{stat}). +#' @param stat A list of summary statistics: \code{n} (per-variant sample +#' sizes), \code{variantNames}, and the marginal effects as \code{z}, or as +#' \code{b} with \code{seb}. +#' @param ldReference The LD reference the statistics' variants are matched +#' to by \code{stat$variantNames}: a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +#' \code{\link{LdMatrix}}. \code{mr.ash.rss} takes an LD matrix, which is +#' formed from the reference over these variants. +#' @param varY Variance of the phenotype, or \code{NULL} (default) to fit on +#' the standardized scale. Used only with \code{b} and \code{seb}. +#' @param sigma2E Initial residual variance, or \code{NULL} (default) for +#' \code{mr.ash.rss}'s own. +#' @param s0 Prior variances of the mixture components, relative to the +#' residual variance, or \code{NULL} (default) for the grid +#' \code{susieR::mr.ash} uses by default, built for these statistics. +#' @param w0 Prior mixture weights (summing to 1), or \code{NULL} (default) +#' for equal weights. +#' @param fitRetention How much of the fit is kept as the \code{"fit"} +#' attribute of the returned weights: \code{"none"} (default) attaches +#' nothing, \code{"slim"} and \code{"full"} attach the fitted +#' \code{mr.ash.rss} model. This engine keeps no trimmable intermediates, +#' so the two retaining levels behave alike here. #' @param methodArgs Options forwarded to \code{susieR::mr.ash.rss}, built -#' with \code{\link{MrashOptions}}. A bare list is refused: it cannot be +#' with \code{\link{MrashRssOptions}}. A bare list is refused: it cannot be #' checked against the engine, so a misspelled option would be #' silently ignored. -#' @return A numeric vector of the posterior mean of the coefficients. +#' @return A numeric vector of the posterior mean of the coefficients. Unless +#' \code{fitRetention = "none"}, the fitted model is attached as attribute +#' \code{"fit"}. #' @importFrom susieR mr.ash.rss #' @examples #' data(eqtlRegionExample) @@ -28,41 +40,78 @@ NULL #' coef(summary(lm(y ~ X[, j])))[2, 1:2] #' }) #' stat <- list(b = vapply(ss, `[`, numeric(1), 1L), -#' seb = vapply(ss, `[`, numeric(1), 2L), n = rep(nrow(X), ncol(X))) -#' mrashRssWeights(stat, cor(X), varY = var(y), sigma2E = var(y), -#' s0 = c(0, 0.1, 0.5), w0 = c(0.8, 0.1, 0.1)) -#' @importFrom checkmate assertList assertNumeric +#' seb = vapply(ss, `[`, numeric(1), 2L), n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X)) +#' mrashRssWeights(stat, LdMatrix(cor(X))) +#' @importFrom checkmate assertList #' @export mrashRssWeights <- function( stat, - LD, - varY, - sigma2E, - s0, - w0, - z = numeric(0), + ldReference, + varY = NULL, + sigma2E = NULL, + s0 = NULL, + w0 = NULL, + fitRetention = c("none", "slim", "full"), methodArgs = MrashRssOptions() ) { + fitRetention <- arg_match(fitRetention) .assertMethodOptions(methodArgs, "MrashRssOptions", "methodArgs") assertList(stat) - assertNumeric(z) + R <- .rssLdMatrix(stat, ldReference, "mrashRssWeights") + n <- median(stat$n) + shat <- as.numeric(stat$seb %||% numeric(0)) + z <- .mrashRssZ(stat) + s0 <- s0 %||% .mrashRssDefaultGrid(n, z, shat, varY) callArgs <- list_modify( list( - bhat = stat$b, - shat = stat$seb, + bhat = as.numeric(stat$b %||% numeric(0)), + shat = shat, z = z, - R = LD, + R = R, var_y = varY, - n = median(stat$n), + n = n, sigma2_e = sigma2E, s0 = s0, - w0 = w0 + # A copy: mr.ash.rss() writes its fitted weights over the vector + # it is given, which would otherwise be the caller's. + w0 = (w0 %||% rep(1 / length(s0), length(s0))) + 0 ), !!!methodArgs ) model <- exec(mr.ash.rss, !!!callArgs) + if (identical(fitRetention, "none")) { + return(model$mu1) + } + `attr<-`(model$mu1, "fit", model) +} + +# The z-scores mr.ash.rss() fits: the statistics' own, or b / seb. +# @noRd +.mrashRssZ <- function(stat) { + hasBetaSe <- !is.null(stat$b) && !is.null(stat$seb) + z <- stat$z %||% (if (hasBetaSe) stat$b / stat$seb) + if (is.null(z)) { + abort("mrashRssWeights: `stat` must carry `z`, or `b` with `seb`.") + } + as.numeric(z) +} - return(model$mu1) +# susieR::mr.ash()'s own default prior grid, (2^((k - 1) / 25) - 1)^2 scaled +# by n / median(w) with w the columns' sums of squares, for the sufficient +# statistics mr.ash.rss() builds from these: w = n - 1 on the standardized +# scale it fits without both a finite varY and seb, and otherwise +# varY * adj / seb^2, with adj = (n - 1) / (z^2 + n - 2) the shrinkage it +# applies. +# @noRd +.mrashRssDefaultGrid <- function(n, z, shat, varY) { + unstandardized <- length(shat) > 0L && !is.null(varY) && is.finite(varY) + w <- if (unstandardized) { + varY * (n - 1) / (z^2 + n - 2) / shat^2 + } else { + rep(n - 1, length(z)) + } + (2^((0:24) / 25) - 1)^2 / median(w) * n } #' PRS-CS: a polygenic prediction method that infers posterior SNP effect sizes @@ -73,6 +122,11 @@ mrashRssWeights <- function( #' panel and infers posterior SNP effect sizes using Bayesian regression with #' continuous shrinkage priors. #' +#' Internal: \code{\link{prsCsWeights}} is the public interface. It forwards +#' the arguments below other than \code{bhat}, \code{R} and \code{n} through +#' \code{\link{PrsCsOptions}}, and with \code{fitRetention} returns this +#' function's list as the \code{"fit"} attribute of its weights. +#' #' @param bhat A vector of marginal effect sizes. #' @param R The LD correlation matrix (a single matrix over the analysed #' window), as in \code{susieR::susie_rss()}. @@ -93,48 +147,7 @@ mrashRssWeights <- function( #' estimates of SNP effect sizes. - psiEst: Posterior estimates of psi #' (shrinkage parameters). - sigmaEst: Posterior estimate of the residual #' variance. - phiEst: Posterior estimate of the global shrinkage parameter. -#' @examples -#' # Generate example data -#' set.seed(985115) -#' n <- 350 -#' p <- 16 -#' sigmasq_error <- 0.5 -#' zeroes <- rbinom(p, 1, 0.6) -#' beta.true <- rnorm(p, 1, sd = 4) -#' beta.true[zeroes] <- 0 -#' -#' X <- cbind(matrix(rnorm(n * p), nrow = n)) -#' X <- scale(X, center = TRUE, scale = FALSE) -#' y <- X %*% matrix(beta.true, ncol = 1) + rnorm(n, 0, sqrt(sigmasq_error)) -#' y <- scale(y, center = TRUE, scale = FALSE) -#' -#' # Calculate sufficient statistics -#' XtX <- t(X) %*% X -#' Xty <- t(X) %*% y -#' yty <- t(y) %*% y -#' -#' # Set the prior -#' K <- 9 -#' sigma0 <- c(0.001, .1, .5, 1, 5, 10, 20, 30, .005) -#' omega0 <- rep(1 / K, K) -#' -#' # Calculate summary statistics -#' b.hat <- sapply(1:p, function(j) { -#' summary(lm(y ~ X[, j]))$coefficients[-1, 1] -#' }) -#' s.hat <- sapply(1:p, function(j) { -#' summary(lm(y ~ X[, j]))$coefficients[-1, 2] -#' }) -#' R.hat <- cor(X) -#' var_y <- var(y) -#' sigmasq_init <- 1.5 -#' -#' # Run PRS CS -#' maf <- rep(0.5, length(b.hat)) # fake MAF -#' out <- prsCs(b.hat, R.hat, n, maf = maf) -#' # In sample prediction correlations -#' cor(X %*% out$betaEst, y) # 0.9944553 -#' @export +#' @keywords internal prsCs <- function( bhat, R, @@ -149,29 +162,63 @@ prsCs <- function( verbose = FALSE, seed = NULL ) { - # Shared LD-matrix validation, then the prsCs-specific maf length check. .rssValidateInputs(bhat, R, n) + .prsCsRun( + bhat, + list(R = R), + n, + a, + b, + phi, + maf, + nIter, + nBurnin, + thin, + verbose, + seed + ) +} + +# PRS-CS on an LD source (.ldSourceRows()): the sampler that factors R for a +# matrix, or for a factor the one that never forms R (prscs_mcmc.h), which +# draws differently from the same posterior. +# @noRd +.prsCsRun <- function( + bhat, + ld, + n, + a, + b, + phi, + maf, + nIter, + nBurnin, + thin, + verbose, + seed +) { if (!is.null(maf) && length(bhat) != length(maf)) { abort("The length of 'bhat' must be the same as 'maf'.") } - - # Run PRS-CS # cpp11 requires exact integer types for int parameters - result <- prsCsRcpp( + settings <- list( a = a, b = b, phi = phi, bhat = bhat, maf = maf, n = as.integer(n), - ldBlk = list(blk1 = R), nIter = as.integer(nIter), nBurnin = as.integer(nBurnin), thin = as.integer(thin), verbose = verbose, seed = seed ) - + result <- if (is.null(ld$F)) { + exec(prsCsCpp, !!!settings, ldBlk = list(blk1 = ld$R)) + } else { + exec(prsCsFactorCpp, !!!settings, factorR = ld$F) + } # Return the result as a list (camelCase to match the rest of the package # API). list( @@ -183,15 +230,30 @@ prsCs <- function( } #' Extract weights from prsCs function -#' @param stat A list of summary statistics with elements \code{b} (effect -#' sizes) and \code{n} (per-variant sample sizes). -#' @param LD Numeric LD (correlation) matrix aligned to the variants in -#' \code{stat}. -#' @param methodArgs Options forwarded to \code{prsCs}, built -#' with \code{\link{PrsCsOptions}}. A bare list is refused: it cannot be -#' checked against the engine, so a misspelled option would be +#' @param stat A list of summary statistics: \code{n} (per-variant sample +#' sizes) and the marginal effects as \code{cor} (standardized), \code{z}, +#' \code{b} with \code{seb}, or \code{b} alone, taken as already +#' standardized. The engine receives the standardized effects z / sqrt(n), +#' with n the median of \code{n}. +#' @param ldReference The LD reference the statistics' variants are matched +#' to by \code{stat$variantNames}: a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +#' \code{\link{LdMatrix}}. A genotype reference's LD is used through its +#' standardized genotypes, never formed as a matrix. +#' @param fitRetention How much of the fit is kept as the \code{"fit"} +#' attribute of the returned weights: \code{"none"} (default) attaches +#' nothing, \code{"slim"} and \code{"full"} attach the sampler's posterior +#' estimates: \code{betaEst}, the local shrinkage parameters +#' \code{psiEst}, the residual variance \code{sigmaEst} and the global +#' shrinkage \code{phiEst}. This engine keeps no trimmable intermediates, +#' so the two retaining levels behave alike here. +#' @param methodArgs Options forwarded to the sampler, \code{\link{prsCs}}, +#' built with \code{\link{PrsCsOptions}}. A bare list is refused: it cannot +#' be checked against the engine, so a misspelled option would be #' silently ignored. -#' @return A numeric vector of the posterior SNP coefficients. +#' @return A numeric vector of the posterior SNP coefficients. Unless +#' \code{fitRetention = "none"}, the sampler's estimates are attached as +#' attribute \code{"fit"}. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] @@ -201,20 +263,51 @@ prsCs <- function( #' stat <- list( #' b = vapply(ss, `[`, numeric(1), 1L), #' seb = vapply(ss, `[`, numeric(1), 2L), -#' n = rep(nrow(X), ncol(X)) +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) +#' ) +#' w <- prsCsWeights( +#' stat, +#' LdMatrix(cor(X)), +#' fitRetention = "slim", +#' methodArgs = PrsCsOptions(maf = rep(0.3, ncol(X))) #' ) -#' LD <- cor(X) -#' prsCsWeights(stat, LD, methodArgs = PrsCsOptions(maf = rep(0.3, ncol(X)))) +#' attr(w, "fit")$phiEst #' @export -prsCsWeights <- function(stat, LD, methodArgs = PrsCsOptions()) { +prsCsWeights <- function( + stat, + ldReference, + fitRetention = c("none", "slim", "full"), + methodArgs = PrsCsOptions() +) { + fitRetention <- arg_match(fitRetention) .assertMethodOptions(methodArgs, "PrsCsOptions", "methodArgs") - callArgs <- list_modify( - list(bhat = stat$b, R = LD, n = median(stat$n)), - !!!methodArgs + ld <- .rssLdSource(stat, ldReference, "prsCsWeights") + n <- median(stat$n) + bhat <- .rssMarginalCor(stat, n = n, p = .ldSourceSize(ld)) + .rssValidateSource(bhat, ld, n) + settings <- list_modify( + .formalDefaults( + prsCs, + c( + "a", + "b", + "phi", + "maf", + "nIter", + "nBurnin", + "thin", + "verbose", + "seed" + ) + ), + !!!as.list(methodArgs) ) - model <- exec(prsCs, !!!callArgs) - - return(model$betaEst) + model <- exec(.prsCsRun, bhat = bhat, ld = ld, n = n, !!!settings) + if (identical(fitRetention, "none")) { + return(model$betaEst) + } + `attr<-`(model$betaEst, "fit", model) } #' SDPR (Summary-Statistics-Based Dirichelt Process Regression for Polygenic @@ -224,6 +317,11 @@ prsCsWeights <- function(stat, LD, methodArgs = PrsCsOptions()) { #' Markov Chain Monte Carlo (MCMC) for estimating effect sizes and heritability #' based on summary statistics and reference LD matrices. #' +#' Internal: \code{\link{sdprWeights}} is the public interface. It forwards +#' the arguments below other than \code{bhat}, \code{R} and \code{n} through +#' \code{\link{SdprOptions}}, and with \code{fitRetention} returns this +#' function's list as the \code{"fit"} attribute of its weights. +#' #' @param bhat A vector of marginal beta values for each SNP. #' @param R The LD correlation matrix (a single matrix over the analysed #' window). @@ -251,56 +349,14 @@ prsCsWeights <- function(stat, LD, methodArgs = PrsCsOptions()) { #' @param seed Integer or \code{NULL}. Random seed for the Gibbs sampler; #' \code{NULL} leaves the RNG state unchanged. #' @return A list with \code{betaEst} (the estimated effect sizes) and -#' \code{h2} (the estimated heritability). \code{sdprWeights()} returns -#' only \code{betaEst}; call this directly when you also want \code{h2}. -#' @examples -#' # Generate example data -#' set.seed(985115) -#' n <- 350 -#' p <- 16 -#' sigmasq_error <- 0.5 -#' zeroes <- rbinom(p, 1, 0.6) -#' beta.true <- rnorm(p, 1, sd = 4) -#' beta.true[zeroes] <- 0 -#' -#' X <- cbind(matrix(rnorm(n * p), nrow = n)) -#' X <- scale(X, center = TRUE, scale = FALSE) -#' y <- X %*% matrix(beta.true, ncol = 1) + rnorm(n, 0, sqrt(sigmasq_error)) -#' y <- scale(y, center = TRUE, scale = FALSE) -#' -#' # Calculate sufficient statistics -#' XtX <- t(X) %*% X -#' Xty <- t(X) %*% y -#' yty <- t(y) %*% y -#' -#' # Set the prior -#' K <- 9 -#' sigma0 <- c(0.001, .1, .5, 1, 5, 10, 20, 30, .005) -#' omega0 <- rep(1 / K, K) -#' -#' # Calculate summary statistics -#' b.hat <- sapply(1:p, function(j) { -#' summary(lm(y ~ X[, j]))$coefficients[-1, 1] -#' }) -#' s.hat <- sapply(1:p, function(j) { -#' summary(lm(y ~ X[, j]))$coefficients[-1, 2] -#' }) -#' R.hat <- cor(X) -#' var_y <- var(y) -#' sigmasq_init <- 1.5 -#' -#' # Run SDPR -#' out <- sdpr(b.hat, R.hat, n) -#' # In sample prediction correlations -#' cor(X %*% out$betaEst, y) # -#' +#' \code{h2} (the estimated heritability). #' @note This function wraps a rewritten and adapted version of the SDPR C++ #' implementation. SDPR is described in Zhou G, Zhao H (2021), "A fast and #' robust Bayesian nonparametric method for prediction of complex traits #' using summary statistics", PLoS Genetics 17(7): e1009697. #' \doi{10.1371/journal.pgen.1009697} #' -#' @export +#' @keywords internal sdpr <- function( bhat, R, @@ -320,12 +376,55 @@ sdpr <- function( verbose = TRUE, seed = NULL ) { - .sdprValidate(bhat, R, n, M, perVariantSampleSize, array) - # The C++ backend takes a block list; wrap the single-window matrix R as one - # block. cpp11 requires exact integer types for int params + sexp vectors. - sdprRcpp( + .rssValidateInputs(bhat, R, n) + .sdprRun( + bhat, + list(R = R), + n, + perVariantSampleSize, + array, + a, + c, + M, + a0k, + b0k, + iter, + burn, + thin, + numThreads, + optLlk, + verbose, + seed + ) +} + +# SDPR on an LD source (.ldSourceRows()): the sampler on the matrix, or the +# same sampler on the low-rank form of SDPR's matrices from a factor of it +# (sdpr_mcmc.h), which draws as the matrix route does without forming R. +# @noRd +.sdprRun <- function( + bhat, + ld, + n, + perVariantSampleSize, + array, + a, + c, + M, + a0k, + b0k, + iter, + burn, + thin, + numThreads, + optLlk, + verbose, + seed +) { + .sdprValidate(M, perVariantSampleSize, array) + # cpp11 requires exact integer types for int params + sexp vectors. + settings <- list( bhatR = bhat, - LD = list(blk1 = R), n = as.integer(n), perVariantSampleSize = perVariantSampleSize, array = if (!is.null(array)) as.integer(array) else NULL, @@ -342,13 +441,18 @@ sdpr <- function( verbose = verbose, seed = seed ) + if (is.null(ld$F)) { + # The C++ backend takes a block list; the window is one block. + return(exec(sdprCpp, !!!settings, LD = list(blk1 = ld$R))) + } + exec(sdprFactorCpp, !!!settings, factorR = ld$F) } -# Validate the SDPR inputs: RSS contract, M >= 4 (SDPR uses M-2 indexing in -# sample_V; M < 4 overflows), positive per-variant N, and array in {0, 1, 2}. +# Validate the SDPR settings: M >= 4 (SDPR uses M-2 indexing in sample_V; +# M < 4 overflows), positive per-variant N, and array in {0, 1, 2}. The RSS +# contract (bhat, LD, n) is checked by the callers. # @noRd -.sdprValidate <- function(bhat, R, n, M, perVariantSampleSize, array) { - .rssValidateInputs(bhat, R, n) +.sdprValidate <- function(M, perVariantSampleSize, array) { if (M < 4) { abort("'M' must be at least 4.") } @@ -366,15 +470,31 @@ sdpr <- function( } #' Extract weights from sdpr function -#' @param stat A list of summary statistics with elements \code{b} (effect -#' sizes) and \code{n} (per-variant sample sizes). -#' @param LD Numeric LD (correlation) matrix aligned to the variants in -#' \code{stat}. -#' @param methodArgs Options forwarded to \code{sdpr}, built -#' with \code{\link{SdprOptions}}. A bare list is refused: it cannot be -#' checked against the engine, so a misspelled option would be +#' @param stat A list of summary statistics: \code{n} (per-variant sample +#' sizes) and the marginal effects as \code{cor} (standardized), \code{z}, +#' \code{b} with \code{seb}, or \code{b} alone, taken as already +#' standardized. The engine receives the standardized effects z / sqrt(n), +#' with n the median of \code{n}. +#' @param ldReference The LD reference the statistics' variants are matched +#' to by \code{stat$variantNames}: a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +#' \code{\link{LdMatrix}}. A genotype reference's LD is used through its +#' standardized genotypes and not formed as a matrix, except under +#' \code{optLlk = 2} when the per-variant sample sizes and arrays are +#' too varied for its low-rank form to pay. +#' @param fitRetention How much of the fit is kept as the \code{"fit"} +#' attribute of the returned weights: \code{"none"} (default) attaches +#' nothing, \code{"slim"} and \code{"full"} attach the sampler's +#' estimates, \code{betaEst} and the heritability \code{h2}. This engine +#' keeps no trimmable intermediates, so the two retaining levels behave +#' alike here. +#' @param methodArgs Options forwarded to the sampler, \code{\link{sdpr}}, +#' built with \code{\link{SdprOptions}}. A bare list is refused: it cannot +#' be checked against the engine, so a misspelled option would be #' silently ignored. -#' @return A numeric vector of the posterior SNP coefficients. +#' @return A numeric vector of the posterior SNP coefficients. Unless +#' \code{fitRetention = "none"}, the sampler's estimates, the heritability +#' among them, are attached as attribute \code{"fit"}. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] @@ -384,20 +504,51 @@ sdpr <- function( #' stat <- list( #' b = vapply(ss, `[`, numeric(1), 1L), #' seb = vapply(ss, `[`, numeric(1), 2L), -#' n = rep(nrow(X), ncol(X)) +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) #' ) -#' LD <- cor(X) -#' sdprWeights(stat, LD) +#' w <- sdprWeights(stat, LdMatrix(cor(X)), fitRetention = "slim") +#' attr(w, "fit")$h2 #' @export -sdprWeights <- function(stat, LD, methodArgs = SdprOptions()) { +sdprWeights <- function( + stat, + ldReference, + fitRetention = c("none", "slim", "full"), + methodArgs = SdprOptions() +) { + fitRetention <- arg_match(fitRetention) .assertMethodOptions(methodArgs, "SdprOptions", "methodArgs") - callArgs <- list_modify( - list(bhat = stat$b, R = LD, n = median(stat$n)), - !!!methodArgs + ld <- .rssLdSource(stat, ldReference, "sdprWeights") + n <- median(stat$n) + bhat <- .rssMarginalCor(stat, n = n, p = .ldSourceSize(ld)) + .rssValidateSource(bhat, ld, n) + settings <- list_modify( + .formalDefaults( + sdpr, + c( + "perVariantSampleSize", + "array", + "a", + "c", + "M", + "a0k", + "b0k", + "iter", + "burn", + "thin", + "numThreads", + "optLlk", + "verbose", + "seed" + ) + ), + !!!as.list(methodArgs) ) - model <- exec(sdpr, !!!callArgs) - - return(model$betaEst) + model <- exec(.sdprRun, bhat = bhat, ld = ld, n = n, !!!settings) + if (identical(fitRetention, "none")) { + return(model$betaEst) + } + `attr<-`(model$betaEst, "fit", model) } @@ -537,10 +688,15 @@ mrmashWeights <- function( #' \code{\link{computeCovDiag}}, or \code{mashr::cov_flash}) to add #' data-driven covariance components alongside the canonical mixture. #' -#' @param stat A list with \code{z} (variants x conditions matrix) and \code{n} -#' (per-context numeric vector or scalar). May also include \code{Bhat}, -#' \code{Shat} matrices. -#' @param LD LD correlation matrix. +#' @param stat A list with \code{z} (variants x conditions matrix), +#' \code{n} (per-context numeric vector or scalar) and \code{variantNames}. +#' May also include \code{Bhat}, \code{Shat} matrices. +#' @param ldReference The LD reference the statistics' variants are matched +#' to by \code{stat$variantNames}: a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +#' \code{\link{LdMatrix}}. \code{mr.mash.rss} takes an LD matrix, which is +#' formed from the reference over these variants; it is not read when +#' \code{mrmashRssFit} is supplied. #' @param mrmashRssFit Optional pre-fitted \code{mr.mash.rss} object; skips #' fitting when supplied. #' @param dataDrivenPriorMatrices Optional list with element \code{U} (list of @@ -579,15 +735,16 @@ mrmashWeights <- function( #' cond <- c("brain", "blood", "muscle") #' zmat <- matrix(rnorm(30 * 3), 30, 3, #' dimnames = list(colnames(X), cond)) -#' stat <- list(z = zmat, n = matrix(nrow(X), 30, 3)) -#' mrmashRssWeights(stat, cor(X), +#' stat <- list(z = zmat, n = matrix(nrow(X), 30, 3), +#' variantNames = colnames(X)) +#' mrmashRssWeights(stat, LdMatrix(cor(X)), #' dataDrivenPriorMatrices = multiTraitData$priorMatrices, #' canonicalPriorMatrices = TRUE) #' @export #' @importFrom checkmate assertFlag assertList mrmashRssWeights <- function( stat, - LD, + ldReference, mrmashRssFit = NULL, dataDrivenPriorMatrices = NULL, canonicalPriorMatrices = TRUE, @@ -606,7 +763,7 @@ mrmashRssWeights <- function( if (is.null(mrmashRssFit)) { mrmashRssFit <- .mrmashRssComputeFit( stat, - LD, + .rssLdMatrix(stat, ldReference, "mrmashRssWeights"), dataDrivenPriorMatrices, canonicalPriorMatrices, S0, @@ -630,11 +787,7 @@ mrmashRssWeights <- function( # @noRd .mrmashRssRequirePackage <- function() { if (!requireNamespace("mr.mashr", quietly = TRUE)) { - msg <- glue( - "Package 'mr.mashr' is required. ", - "is required." - ) - abort(msg) + abort("Package 'mr.mashr' is required for mrmashRssWeights().") } } @@ -713,18 +866,6 @@ mrmashRssWeights <- function( } -# Get a reasonable setting for the standard deviations of the mixture -# components in the mixture-of-normals prior based on the data (X, y). -# Input se is an estimate of the residual *variance*, and n is the -# number of standard deviations to return. This code is adapted from -# the autoselect.mixsd function in the ashr package. -#' @importFrom susieR univariate_regression -initPriorSd <- function(X, y, n = 30) { - res <- univariate_regression(X, y) - smax <- 3 * max(res$betahat) - seq(0, smax, length.out = n) -} - # Identify zero-variance columns of X and warn the caller before they are # dropped. Returns a logical vector of length ncol(X) where TRUE indicates a # column to keep. The downstream solvers in pecotmr's regression wrappers @@ -1002,16 +1143,16 @@ MrashRssOptions <- function(...) { c( bhat = "supplied from the data by the pipeline", shat = "supplied from the data by the pipeline", + z = "supplied from the data by the pipeline", R = "supplied from the data by the pipeline", n = "supplied from the data by the pipeline", - # The engine writes these five in snake_case while the wrapper - # spells them camelCase, so they read as unrelated names; every - # one is still fed straight from a formal. - z = "the wrapper's `z`", - var_y = "the wrapper's `varY`", - sigma2_e = "the wrapper's `sigma2E`", s0 = "the wrapper's `s0`", - w0 = "the wrapper's `w0`" + w0 = "the wrapper's `w0`", + # The engine writes these two in snake_case while the wrapper + # spells them camelCase, so they read as unrelated names; both + # are still fed straight from a formal. + var_y = "the wrapper's `varY`", + sigma2_e = "the wrapper's `sigma2E`" ), "MrashRssOptions" ) @@ -1338,9 +1479,10 @@ lassoWeights <- function(X, y, methodArgs = GlmnetOptions()) { #' Compute Weights Using mr.ash Shrinkage #' #' This function fits the `mr.ash` model (adaptive shrinkage regression) to -#' estimate weights for a given set of predictors and response. It uses optional -#' prior standard deviation initialization and can accept custom initial beta -#' values. +#' estimate weights for a given set of predictors and response. The prior is +#' \code{susieR::mr.ash}'s own default mixture grid unless \code{sa2} is +#' supplied through \code{methodArgs}, and custom initial beta values are +#' accepted. #' #' @examples #' set.seed(1) @@ -1351,14 +1493,11 @@ lassoWeights <- function(X, y, methodArgs = GlmnetOptions()) { #' @importFrom stats predict #' @param X Numeric genotype / design matrix (samples x variants). #' @param y Numeric response (phenotype) vector of length \code{nrow(X)}. -#' @param initPriorSd Logical. Initialize the prior standard-deviation grid -#' from the data. Default \code{TRUE}. #' @param fitRetention How much of the fit is kept as the \code{"fit"} #' attribute of the returned weights: \code{"none"} (default) attaches #' nothing, \code{"slim"} and \code{"full"} attach the fitted model. This #' engine keeps no trimmable intermediates, so the two retaining levels #' behave alike here. -#' Default \code{FALSE}. #' @param methodArgs Options forwarded to \code{susieR::mr.ash}, built #' with \code{\link{MrashOptions}}. A bare list is refused: it cannot be #' checked against the engine, so a misspelled option would be @@ -1367,17 +1506,14 @@ lassoWeights <- function(X, y, methodArgs = GlmnetOptions()) { #' zero-variance columns receive weight 0. Unless #' \code{fitRetention = "none"} the fitted \code{mr.ash} object is #' attached as attribute \code{"fit"}. -#' @importFrom checkmate assertFlag #' @export mrashWeights <- function( X, y, - initPriorSd = TRUE, fitRetention = c("none", "slim", "full"), methodArgs = MrashOptions() ) { .assertMethodOptions(methodArgs, "MrashOptions", "methodArgs") - assertFlag(initPriorSd) fitRetention <- arg_match(fitRetention) keep <- .dropZeroVariance(X, "mrashWeights") XKeep <- X[, keep, drop = FALSE] @@ -1387,15 +1523,7 @@ mrashWeights <- function( as.list(methodArgs), !!!.mrashBetaInit(methodArgs, XKeep, y, X, keep) ) - MrashOptions <- c( - list( - X = XKeep, - y = y, - sa2 = if (initPriorSd) initPriorSd(XKeep, y)^2 else NULL - ), - argsList - ) - fit.mr.ash <- exec(mr.ash, !!!MrashOptions) + fit.mr.ash <- exec(mr.ash, X = XKeep, y = y, !!!argsList) # Zero-variance columns were never fitted and keep a zero weight. eff.wgt <- replace( rep(0, ncol(X)), @@ -2153,6 +2281,12 @@ bayesRWeights <- function( #' Based on Mak et al (2017) "Polygenic scores via penalized regression on #' summary statistics", Genetic Epidemiology 41(6):469-480. #' +#' Internal: \code{\link{lassosumRssWeights}} is the public interface. It +#' runs this over a grid of LD shrinkage values, forwards \code{lambda}, +#' \code{thr} and \code{maxiter} through \code{\link{LassosumOptions}}, and +#' with \code{fitRetention} returns the paths as the \code{"fit"} attribute +#' of its weights. +#' #' @param bhat A vector of marginal effect sizes. #' @param R The LD correlation matrix (a single matrix over the analysed #' window), as in \code{susieR::susie_rss()}. If shrinkage is desired, apply @@ -2172,18 +2306,7 @@ bayesRWeights <- function( #' \item{fbeta}{Full objective value at each lambda.} #' \item{nparams}{Number of non-zero coefficients at each lambda.} #' -#' @examples -#' set.seed(42) -#' p <- 10 -#' n <- 100 -#' bhat <- rnorm(p, sd = 0.1) -#' R <- diag(p) -#' for (i in 1:(p - 1)) { -#' R[i, i + 1] <- 0.3 -#' R[i + 1, i] <- 0.3 -#' } -#' out <- lassosumRss(bhat, R, n) -#' @export +#' @keywords internal #' @importFrom checkmate assertCount assertNumber assertNumeric lassosumRss <- function( bhat, @@ -2193,14 +2316,19 @@ lassosumRss <- function( thr = 1e-4, maxiter = 10000 ) { + .lassosumRssPath(bhat, list(R = R), n, lambda, thr, maxiter) +} + +# lassosumRss() on an LD source: the matrix, or a factor of it with its +# shrinkage, which the factor solver applies without forming R. +# @noRd +.lassosumRssPath <- function(bhat, ld, n, lambda, thr, maxiter) { assertNumeric(lambda, lower = 0, any.missing = FALSE) assertNumber(thr, lower = 0, finite = TRUE) assertCount(maxiter, positive = TRUE) - # cpp11 requires exact integer types; the C++ backend takes a block list, so - # the single-window matrix R is wrapped as one block here. .rssSolvePath( bhat, - R, + ld, n, lambda, .rssLassosumSolve, @@ -2208,25 +2336,49 @@ lassosumRss <- function( ) } -.lassosumCorFromStat <- function(stat, n, p) { +# .lassosumRssPath() with lassosumRss()'s own defaults under `args`, the +# caller's options. A matrix takes exactly the path lassosumRss() does. +# @noRd +.lassosumRssOn <- function(bhat, ld, n, args) { + settings <- list_modify( + .formalDefaults(lassosumRss, c("lambda", "thr", "maxiter")), + !!!args + ) + exec(.lassosumRssPath, bhat = bhat, ld = ld, n = n, !!!settings) +} + +# The values `fn` declares as the defaults of its formals `fmlNames`, +# evaluated as the function itself would evaluate them. The internal LD-source +# paths run lassosumRss(), penalizedRss(), prsCs() and sdpr() on a factor of +# the LD, and take those functions' defaults from here rather than restating +# them. +# @noRd +#' @importFrom rlang fn_fmls fn_env eval_bare +.formalDefaults <- function(fn, fmlNames) { + map(fn_fmls(fn)[fmlNames], eval_bare, env = fn_env(fn)) +} + +# The standardized marginal effects, z / sqrt(n): the scale lassosum, PRS-CS +# and SDPR all fit. Read from `cor` as given, else from `z`, else from +# `b / seb`, which is a z-score whatever scale `b` is on, else from `b` alone, +# taken as already standardized. +.rssMarginalCor <- function(stat, n, p) { corInput <- if (!is.null(stat$cor)) { as.numeric(stat$cor) } else if (!is.null(stat$z)) { as.numeric(stat$z) / sqrt(n) + } else if (!is.null(stat$b) && !is.null(stat$seb)) { + as.numeric(stat$b) / as.numeric(stat$seb) / sqrt(n) } else if (!is.null(stat$b)) { as.numeric(stat$b) } else { - msg <- glue( - "stat must contain one of 'cor', 'z', or 'b' for lassosum ", - "selection." - ) - abort(msg) + abort("stat must contain one of 'cor', 'z', or 'b'.") } if (length(corInput) != p) { nInput <- length(corInput) msg <- glue( - "The length of lassosum input statistics ({nInput}) must ", - "equal nrow(LD) ({p})." + "The length of the input statistics ({nInput}) must equal the ", + "number of LD variants ({p})." ) abort(msg) } @@ -2254,10 +2406,9 @@ lassosumRss <- function( ) } -.lassosumSelectLdQuadratic <- function(candidateBeta, corInput, LD) { - ldBeta <- LD %*% candidateBeta +.lassosumSelectLdQuadratic <- function(candidateBeta, corInput, ld) { bxy <- as.numeric(crossprod(corInput, candidateBeta)) - bxxb <- colSums(candidateBeta * ldBeta) + bxxb <- .ldQuadForms(ld, candidateBeta) positive <- is.finite(bxxb) & bxxb > 0 scores <- replace( rep(-Inf, length(bxy)), @@ -2276,9 +2427,9 @@ lassosumRss <- function( # penalizedRss via .rssSolvePath, prsCs, and sdpr). R is a single LD correlation # matrix over one cis-window, matching susieR::susie_rss; bhat must match # nrow(R). missing() guards turn an omitted R / n into a clear message instead -# of an "argument is missing" error, and propagate through the public wrappers -# (verified two levels deep). Method-specific checks -- prsCs's maf length, -# sdpr's M / perVariantSampleSize / array -- stay in the caller. +# of an "argument is missing" error, and propagate through the solvers' +# callers (verified two levels deep). Method-specific checks -- prsCs's maf +# length, sdpr's M / perVariantSampleSize / array -- stay in the caller. #' @importFrom checkmate assertVector .rssValidateInputs <- function(bhat, R, n) { if (missing(R) || !is.matrix(R)) { @@ -2291,19 +2442,35 @@ lassosumRss <- function( invisible(NULL) } -# Validate (bhat, LD, n), run a decreasing-lambda coordinate-descent sweep via -# `solveFn` (the penalty-specific Rcpp backend), then reorder back to the input +# .rssValidateInputs() for an LD source (.ldSourceRows()): the matrix +# checks for a matrix, and for a factor the same checks against its columns. +# @noRd +.rssValidateSource <- function(bhat, ld, n) { + if (!is.null(ld$R)) { + return(.rssValidateInputs(bhat, ld$R, n)) + } + if (missing(n) || n <= 0) { + abort("Please provide a valid sample size using 'n'.") + } + assertVector(bhat, len = ncol(ld$F)) + invisible(NULL) +} + +# Validate (bhat, ld, n), run a decreasing-lambda coordinate-descent sweep via +# `solveFn` (the penalty-specific C++ solver), then reorder back to the input # lambda order via the inverse permutation and assemble the standard result -# list. Shared by lassosumRss and penalizedRss, which differ only in which Rcpp +# list. Shared by lassosumRss and penalizedRss, which differ only in which C++ # solver they pass as `solveFn` (and penalizedRss's per-penalty gamma default). -.rssSolvePath <- function(bhat, R, n, lambda, solveFn, solveArgs = list()) { - .rssValidateInputs(bhat, R, n) +# `ld` is an LD source: the matrix, or a factor of it with the shrinkage the +# factor solver applies itself. +.rssSolvePath <- function(bhat, ld, n, lambda, solveFn, solveArgs = list()) { + .rssValidateSource(bhat, ld, n) z <- bhat / sqrt(n) order <- order(lambda, decreasing = TRUE) # `solveArgs` rather than `...`: the two solvers take different fixed # argument sets, and both callers know theirs statically, so an unknown # solver argument should be an error here rather than reaching the solver. - solved <- exec(solveFn, z, lambda[order], R, !!!solveArgs) + solved <- exec(solveFn, z, lambda[order], ld, !!!solveArgs) # Reorder back to original lambda order via the inverse permutation. invOrder <- order(order) beta <- solved$beta[, invOrder, drop = FALSE] @@ -2324,44 +2491,42 @@ lassosumRss <- function( # fields apply). Returns list(beta, meta); l0learn's inner lambda0 sweep is # here. # @noRd -.rssFitOne <- function(method, solverInput, LDs, n, sVal, config) { +.rssFitOne <- function(method, solverInput, ld, n, sVal, config) { switch( method, - lassosum = .rssFitLassosum(solverInput, LDs, n, sVal, config), - penalized = .rssFitPenalized(solverInput, LDs, n, sVal, config), - l0learn = .rssFitL0learn(solverInput, LDs, n, sVal, config) + lassosum = .rssFitLassosum(solverInput, ld, n, sVal, config), + penalized = .rssFitPenalized(solverInput, ld, n, sVal, config), + l0learn = .rssFitL0learn(solverInput, ld, n, sVal, config) ) } -# Shared (s, lambda, fbeta) path-metadata frame for a single-path model. +# Shared per-candidate frame for a single-path model: the shrinkage s and +# each lambda, with the solver's objective, loss, convergence flag and number +# of non-zero coefficients there. # @noRd .rssPathMeta <- function(sVal, model) { tibble( s = rep(sVal, length(model$lambda)), lambda = model$lambda, - fbeta = model$fbeta + fbeta = model$fbeta, + loss = model$loss, + conv = model$conv, + nparams = model$nparams ) } -# lassosum shrinkage path for one s. +# lassosum shrinkage path for one s, against `ld` shrunk to that s. # @noRd -.rssFitLassosum <- function(solverInput, LDs, n, sVal, config) { - lsArgs <- c( - list(bhat = solverInput, R = LDs, n = n), - as.list(config$dotArgs) - ) - model <- exec(lassosumRss, !!!lsArgs) +.rssFitLassosum <- function(solverInput, ld, n, sVal, config) { + model <- .lassosumRssOn(solverInput, ld, n, as.list(config$dotArgs)) list(beta = model$beta, meta = .rssPathMeta(sVal, model)) } -# ncvreg-penalized shrinkage path for one s. +# ncvreg-penalized shrinkage path for one s, against `ld` shrunk to that s. # @noRd -.rssFitPenalized <- function(solverInput, LDs, n, sVal, config) { - penArgs <- c( +.rssFitPenalized <- function(solverInput, ld, n, sVal, config) { + settings <- c( list( - bhat = solverInput, - R = LDs, - n = n, penalty = config$penalty, gamma = config$gamma, alpha = config$alpha, @@ -2370,18 +2535,18 @@ lassosumRss <- function( ), as.list(config$dotArgs) ) - model <- exec(penalizedRss, !!!penArgs) + model <- .penalizedRssOn(solverInput, ld, n, settings) list(beta = model$beta, meta = .rssPathMeta(sVal, model)) } # L0Learn path for one s: one penalizedRss fit per lambda0, column-bound. # @noRd -.rssFitL0learn <- function(solverInput, LDs, n, sVal, config) { +.rssFitL0learn <- function(solverInput, ld, n, sVal, config) { fits <- map( config$lambda0, .rssL0LambdaFit, solverInput = solverInput, - LDs = LDs, + ld = ld, n = n, sVal = sVal, config = config @@ -2428,57 +2593,147 @@ lassosumRss <- function( `attr<-`(bestBeta, attrName, selection) } -# Shared scaffold for the RSS shrinkage-grid weight functions -# (lassosumRssWeights / .penalizedRssWeights / l0learnRssWeights). Standardizes -# the stat -> solverInput conversion, the outer LD-shrinkage grid over `s`, the -# candidate accumulation, and the ldQuadratic / minFbeta selection. `method` + -# `config` pick the per-`s` solver (.rssFitOne) and the finalizer -# (.rssFinalize). -# One shrinkage level's fit against the correspondingly shrunk LD. +# The LD the RSS weight methods read, matched to the statistics' variants +# (`stat$variantNames`): a factor of it for a genotype reference, which the +# factor solvers use without forming the p x p matrix, or the matrix an +# LdMatrix holds. Matching, allele flips, standardizing and padding are the +# LD reference layer's own (.ldFactorFromRef(), .ldFromRef()). # @noRd -.rssFitAtS <- function(sVal, method, solverInput, LD, n, p, config) { - .rssFitOne( - method, - solverInput, - (1 - sVal) * LD + sVal * diag(p), - n, - sVal, - config - ) +.rssLdSource <- function(stat, ldReference, label) { + ids <- .rssStatVariantIds(stat, label) + if (.ldIsGenotypeRef(ldReference)) { + return(list(F = .ldFactorFromRef(ldReference, ids, label))) + } + list(R = .ldFromRef(ldReference, ids, label)) +} + +# The LD matrix itself, for the engines that take nothing else (mr.ash.rss, +# mr.mash.rss). +# @noRd +.rssLdMatrix <- function(stat, ldReference, label) { + .ldFromRef(ldReference, .rssStatVariantIds(stat, label), label) +} + +# The variant ids an LD reference is matched on. +# @noRd +.rssStatVariantIds <- function(stat, label) { + ids <- stat$variantNames + if (is.null(ids)) { + abort(glue( + "{label}: `stat` must carry `variantNames`, the variant ids ", + "`ldReference` is matched on." + )) + } + ids +} + +# How many variants the statistics describe, for the weight extractors that +# check a fit against them: their variant ids, all of which must be in +# `ldReference` when one is given, or else their z-scores or effects (rows, +# for a multi-condition matrix). NA when the statistics carry none of these. +# @noRd +.rssVariantCount <- function(stat, ldReference, label) { + if (!is.null(ldReference)) { + ids <- .rssStatVariantIds(stat, label) + .ldFromRefValidate(ldReference, label) + .ldFromRefMatch(ldReference, ids, label, "error") + return(length(ids)) + } + described <- stat$variantNames %||% stat$z %||% stat$b + if (is.null(described)) NA_integer_ else NROW(described) +} + +# One shrinkage level's fit against R_s = (1 - s) R + s I. +# @noRd +.rssFitAtS <- function(sVal, method, solverInput, ld, n, config) { + .rssFitOne(method, solverInput, .rssShrunkLd(ld, sVal), n, sVal, config) +} + +# An LD source shrunk to R_s = (1 - s) R + s I: the source carries s to the +# solver, which applies it to the matrix or the factor without forming R_s, +# so the grid over s shares one LD matrix rather than copying it per s. +# @noRd +.rssShrunkLd <- function(ld, s) { + list_assign(ld, shrink = s) } +# Shared scaffold for the RSS shrinkage-grid weight functions +# (lassosumRssWeights / .penalizedRssWeights / l0learnRssWeights), run for the +# statistics `stat` against the LD source `ld` (see .rssLdSource()). +# Standardizes the stat -> solverInput conversion, the outer LD-shrinkage grid +# over `s`, the candidate accumulation, and the ldQuadratic / minFbeta +# selection. `method` + `config` pick the per-`s` solver (.rssFitOne) and the +# finalizer (.rssFinalize); `fitRetention` how much of the search is kept. +# @noRd .rssShrinkGridWeights <- function( stat, - LD, + ld, s, method, config, - selection = c("ldQuadratic", "minFbeta") + selection = c("ldQuadratic", "minFbeta"), + fitRetention = c("none", "slim", "full") ) { selection <- arg_match(selection) + fitRetention <- arg_match(fitRetention) n <- median(stat$n) - p <- nrow(LD) - corInput <- .lassosumClampCor(.lassosumCorFromStat(stat, n = n, p = p)) + p <- .ldSourceSize(ld) + corInput <- .lassosumClampCor(.rssMarginalCor(stat, n = n, p = p)) solverInput <- corInput * sqrt(n) fits <- map( s, .rssFitAtS, method = method, solverInput = solverInput, - LD = LD, + ld = ld, n = n, - p = p, config = config ) candidateBeta <- exec(cbind, !!!map(fits, "beta")) candidateMeta <- bind_rows(map(fits, "meta")) selectorResult <- if (selection == "ldQuadratic") { - .lassosumSelectLdQuadratic(candidateBeta, corInput, LD) + .lassosumSelectLdQuadratic(candidateBeta, corInput, ld) } else { .lassosumSelectMinFbeta(candidateBeta, candidateMeta) } bestBeta <- as.numeric(selectorResult$beta) - .rssFinalize(method, bestBeta, selectorResult, candidateMeta, config) + weights <- .rssFinalize( + method, + bestBeta, + selectorResult, + candidateMeta, + config + ) + .rssAttachGridFit( + weights, + candidateBeta, + candidateMeta, + selectorResult$index, + fitRetention + ) +} + +# The search behind the grid weights as their "fit" attribute: `path`, one +# row per candidate fit with the solver's diagnostics and `selected` marking +# the one returned, and at fitRetention = "full" also `beta`, the candidates' +# coefficients (variants x candidates, in path's row order). Returns `weights` +# unchanged at fitRetention = "none". +# @noRd +.rssAttachGridFit <- function( + weights, + candidateBeta, + candidateMeta, + index, + fitRetention +) { + if (identical(fitRetention, "none")) { + return(weights) + } + fit <- c( + list(path = mutate(candidateMeta, selected = row_number() == index)), + compact(list(beta = if (fitRetention == "full") candidateBeta)) + ) + `attr<-`(weights, "fit", fit) } #' Extract weights from lassosumRss with shrinkage grid search @@ -2501,20 +2756,36 @@ lassosumRss <- function( #' This implementation therefore uses the supplied LD matrix directly for #' selection. \code{min(fbeta)} is retained only as an explicit debug option. #' -#' @param stat A list with \code{$b} (effect sizes) and \code{$n} (per-variant -#' sample sizes). -#' @param LD LD correlation matrix R (single matrix, NOT pre-shrunk). +#' @param stat A list of summary statistics: \code{n} (per-variant sample +#' sizes) and the marginal effects as \code{cor} (standardized), \code{z}, +#' \code{b} with \code{seb}, or \code{b} alone, taken as already +#' standardized. The engine receives the standardized effects z / sqrt(n), +#' with n the median of \code{n}. +#' @param ldReference The LD reference the statistics' variants are matched +#' to by \code{stat$variantNames}: a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +#' \code{\link{LdMatrix}}. A genotype reference's LD is used through its +#' standardized genotypes, never formed as a matrix. #' @param s Numeric vector of shrinkage parameters to search over. Default: #' \code{c(0.2, 0.5, 0.9, 1.0)} following Mak et al (2017) and OTTERS. #' @param selection Selection strategy. Default \code{"ldQuadratic"} uses #' \eqn{c^T \beta / \sqrt{\beta^T R \beta}} on the supplied LD matrix. #' \code{"minFbeta"} is retained as an explicit alternative for debugging. -#' @param methodArgs Options forwarded to \code{lassosumRss}, built -#' with \code{\link{LassosumOptions}}. A bare list is refused: it cannot be -#' checked against the engine, so a misspelled option would be -#' silently ignored. +#' @param fitRetention How much of the search is kept as the \code{"fit"} +#' attribute of the returned weights. \code{"none"} (default) attaches +#' nothing. \code{"slim"} keeps \code{path}, a table with one row per +#' candidate (\code{s}, \code{lambda}) giving the solver's objective +#' \code{fbeta}, \code{loss}, convergence flag \code{conv} and number of +#' non-zero coefficients \code{nparams}, with \code{selected} marking the +#' candidate returned. \code{"full"} also keeps \code{beta}, the +#' candidates' coefficients (variants x candidates, in the rows' order). +#' @param methodArgs Options forwarded to the solver, +#' \code{\link{lassosumRss}}, built with \code{\link{LassosumOptions}}. A +#' bare list is refused: it cannot be checked against the engine, so a +#' misspelled option would be silently ignored. #' @return A numeric vector of the posterior SNP coefficients at the best (s, -#' lambda). +#' lambda). Unless \code{fitRetention = "none"}, the search is attached as +#' attribute \code{"fit"}. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] @@ -2524,27 +2795,31 @@ lassosumRss <- function( #' stat <- list( #' b = vapply(ss, `[`, numeric(1), 1L), #' seb = vapply(ss, `[`, numeric(1), 2L), -#' n = rep(nrow(X), ncol(X)) +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) #' ) -#' LD <- cor(X) -#' lassosumRssWeights(stat, LD) +#' w <- lassosumRssWeights(stat, LdMatrix(cor(X)), fitRetention = "slim") +#' head(attr(w, "fit")$path) #' @export lassosumRssWeights <- function( stat, - LD, + ldReference, s = c(0.2, 0.5, 0.9, 1.0), selection = c("ldQuadratic", "minFbeta"), + fitRetention = c("none", "slim", "full"), methodArgs = LassosumOptions() ) { .assertMethodOptions(methodArgs, "LassosumOptions", "methodArgs") selection <- arg_match(selection) + fitRetention <- arg_match(fitRetention) .rssShrinkGridWeights( stat, - LD, + .rssLdSource(stat, ldReference, "lassosumRssWeights"), s, "lassosum", list(dotArgs = methodArgs), - selection + selection, + fitRetention ) } @@ -2556,6 +2831,13 @@ lassosumRssWeights <- function( #' where \eqn{R} is a (possibly pre-shrunk) LD matrix and \eqn{z = \hat\beta / #' \sqrt{n}}. #' +#' Internal: \code{\link{scadRssWeights}}, \code{\link{mcpRssWeights}} and +#' \code{\link{l0learnRssWeights}} are the public interface, with +#' \code{\link{lassosumRssWeights}} for the lasso. They run this over a grid +#' of LD shrinkage values, forward its options through +#' \code{\link{PenalizedRssOptions}}, and with \code{fitRetention} return +#' the paths as the \code{"fit"} attribute of their weights. +#' #' @param bhat Numeric vector of marginal effect estimates (length p). #' @param R The LD correlation matrix (a single matrix over the analysed #' window), as in \code{lassosumRss()}. @@ -2590,19 +2872,7 @@ lassosumRssWeights <- function( #' \item{betaEst}{Coefficient vector at the lambda minimizing fbeta.} #' } #' -#' @examples -#' set.seed(42) -#' p <- 10; n <- 100 -#' bhat <- rnorm(p, sd = 0.1) -#' R <- diag(p) -#' # MCP -#' penalizedRss(bhat, R, n, penalty = "MCP") -#' # SCAD -#' penalizedRss(bhat, R, n, penalty = "SCAD") -#' # L0 -#' penalizedRss(bhat, R, n, penalty = "L0", lambda0 = 0.01, -#' lambda = c(0)) -#' @export +#' @keywords internal penalizedRss <- function( bhat, R, @@ -2617,16 +2887,44 @@ penalizedRss <- function( maxiter = 10000, maxSwaps = 100 ) { - penalty <- arg_match(penalty) + .penalizedRssPath( + bhat, + list(R = R), + n, + arg_match(penalty), + lambda, + gamma, + alpha, + lambda0, + lambda2, + thr, + maxiter, + maxSwaps + ) +} + +# penalizedRss() on an LD source: the matrix, or a factor of it with its +# shrinkage, which the factor solver applies without forming R. +# @noRd +.penalizedRssPath <- function( + bhat, + ld, + n, + penalty, + lambda, + gamma, + alpha, + lambda0, + lambda2, + thr, + maxiter, + maxSwaps +) { # Default gamma per penalty - if (is.null(gamma)) { - gamma <- switch(penalty, SCAD = 3.7, MCP = 3.0, 0.0) - } - # C++ backend takes a block list; wrap the single-window matrix R as one - # block. + gamma <- gamma %||% switch(penalty, SCAD = 3.7, MCP = 3.0, 0.0) .rssSolvePath( bhat, - R, + ld, n, lambda, .rssPenalizedSolve, @@ -2643,6 +2941,30 @@ penalizedRss <- function( ) } +# .penalizedRssPath() with penalizedRss()'s own defaults under `args`, the +# caller's settings, which always name the penalty. A matrix takes exactly +# the path penalizedRss() does. +# @noRd +.penalizedRssOn <- function(bhat, ld, n, args) { + settings <- list_modify( + .formalDefaults( + penalizedRss, + c( + "lambda", + "gamma", + "alpha", + "lambda0", + "lambda2", + "thr", + "maxiter", + "maxSwaps" + ) + ), + !!!args + ) + exec(.penalizedRssPath, bhat = bhat, ld = ld, n = n, !!!settings) +} + #' RSS Weights Helper for Penalized Methods #' #' Shared implementation for \code{scadRssWeights()} and \code{mcpRssWeights()}. @@ -2652,15 +2974,17 @@ penalizedRss <- function( #' sI}) and selects the best candidate via LD-quadratic pseudovalidation or #' minimum penalized objective. #' -#' @param stat,LD,s,selection,penalty,gamma,alpha,lambda0,lambda2 See the -#' public wrappers for details. +#' @param stat,ldReference,s,selection,penalty,gamma,alpha,lambda0,lambda2 See +#' the public wrappers for details. +#' @param fitRetention How much of the search is kept as the \code{"fit"} +#' attribute; see \code{\link{scadRssWeights}}. #' @param methodArgs Options forwarded to \code{penalizedRss}, built with #' \code{\link{PenalizedRssOptions}}. -#' @return Numeric weight vector of length \code{nrow(LD)}. +#' @return Numeric weight vector, one weight per variant of \code{stat}. #' @keywords internal .penalizedRssWeights <- function( stat, - LD, + ldReference, penalty, s = c(0.2, 0.5, 0.9, 1.0), gamma = NULL, @@ -2668,13 +2992,19 @@ penalizedRss <- function( lambda0 = 0, lambda2 = 0, selection = c("ldQuadratic", "minFbeta"), + fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) { .assertMethodOptions(methodArgs, "PenalizedRssOptions", "methodArgs") selection <- arg_match(selection) + fitRetention <- arg_match(fitRetention) .rssShrinkGridWeights( stat, - LD, + .rssLdSource( + stat, + ldReference, + str_c(str_to_lower(penalty), "RssWeights") + ), s, "penalized", list( @@ -2685,7 +3015,8 @@ penalizedRss <- function( lambda2 = lambda2, dotArgs = methodArgs ), - selection + selection, + fitRetention ) } @@ -2695,20 +3026,31 @@ penalizedRss <- function( #' shrinkage grid \code{s} and lambda path. Model selection uses LD-quadratic #' pseudovalidation by default. #' -#' @param stat A list with \code{$b} (effect sizes) and \code{$n} (per-variant -#' sample sizes). -#' @param LD LD correlation matrix R (single matrix, NOT pre-shrunk). +#' @param stat A list of summary statistics: \code{n} (per-variant sample +#' sizes) and the marginal effects as \code{cor} (standardized), \code{z}, +#' \code{b} with \code{seb}, or \code{b} alone, taken as already +#' standardized. The engine receives the standardized effects z / sqrt(n), +#' with n the median of \code{n}. +#' @param ldReference The LD reference the statistics' variants are matched +#' to by \code{stat$variantNames}: a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +#' \code{\link{LdMatrix}}. A genotype reference's LD is used through its +#' standardized genotypes, never formed as a matrix. #' @param s Numeric vector of LD shrinkage parameters. Default: \code{c(0.2, #' 0.5, 0.9, 1.0)}. #' @param gamma SCAD concavity parameter. Default 3.7. #' @param alpha Elastic-net mixing (1 = pure L1). Default 1. #' @param selection Selection strategy: \code{"ldQuadratic"} (default) or #' \code{"minFbeta"}. -#' @param methodArgs Options forwarded to \code{penalizedRss}, built -#' with \code{\link{PenalizedRssOptions}}. A bare list is refused: it -#' cannot be checked against the engine, so a misspelled option would -#' be silently ignored. -#' @return A numeric vector of SNP coefficient weights. +#' @param methodArgs Options forwarded to the solver, +#' \code{\link{penalizedRss}}, built with +#' \code{\link{PenalizedRssOptions}}. A bare list is refused: it cannot +#' be checked against the engine, so a misspelled option would be +#' silently ignored. +#' @inheritParams lassosumRssWeights +#' @return A numeric vector of SNP coefficient weights. Unless +#' \code{fitRetention = "none"}, the search is attached as attribute +#' \code{"fit"}. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] @@ -2718,34 +3060,37 @@ penalizedRss <- function( #' stat <- list( #' b = vapply(ss, `[`, numeric(1), 1L), #' seb = vapply(ss, `[`, numeric(1), 2L), -#' n = rep(nrow(X), ncol(X)) +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) #' ) -#' LD <- cor(X) -#' scadRssWeights(stat, LD) +#' scadRssWeights(stat, LdMatrix(cor(X))) #' @importFrom checkmate assertList assertNumeric assertNumber #' @export scadRssWeights <- function( stat, - LD, + ldReference, s = c(0.2, 0.5, 0.9, 1.0), gamma = 3.7, alpha = 1.0, selection = c("ldQuadratic", "minFbeta"), + fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) { .assertMethodOptions(methodArgs, "PenalizedRssOptions", "methodArgs") + fitRetention <- arg_match(fitRetention) assertList(stat) assertNumeric(s, lower = 0, any.missing = FALSE) assertNumber(gamma, finite = TRUE) assertNumber(alpha, finite = TRUE) .penalizedRssWeights( stat = stat, - LD = LD, + ldReference = ldReference, penalty = "SCAD", s = s, gamma = gamma, alpha = alpha, selection = selection, + fitRetention = fitRetention, methodArgs = methodArgs ) } @@ -2756,20 +3101,31 @@ scadRssWeights <- function( #' shrinkage grid \code{s} and lambda path. Model selection uses LD-quadratic #' pseudovalidation by default. #' -#' @param stat A list with \code{$b} (effect sizes) and \code{$n} (per-variant -#' sample sizes). -#' @param LD LD correlation matrix R (single matrix, NOT pre-shrunk). +#' @param stat A list of summary statistics: \code{n} (per-variant sample +#' sizes) and the marginal effects as \code{cor} (standardized), \code{z}, +#' \code{b} with \code{seb}, or \code{b} alone, taken as already +#' standardized. The engine receives the standardized effects z / sqrt(n), +#' with n the median of \code{n}. +#' @param ldReference The LD reference the statistics' variants are matched +#' to by \code{stat$variantNames}: a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +#' \code{\link{LdMatrix}}. A genotype reference's LD is used through its +#' standardized genotypes, never formed as a matrix. #' @param s Numeric vector of LD shrinkage parameters. Default: \code{c(0.2, #' 0.5, 0.9, 1.0)}. #' @param gamma MCP concavity parameter. Default 3. #' @param alpha Elastic-net mixing (1 = pure L1). Default 1. #' @param selection Selection strategy: \code{"ldQuadratic"} (default) or #' \code{"minFbeta"}. -#' @param methodArgs Options forwarded to \code{penalizedRss}, built -#' with \code{\link{PenalizedRssOptions}}. A bare list is refused: it -#' cannot be checked against the engine, so a misspelled option would -#' be silently ignored. -#' @return A numeric vector of SNP coefficient weights. +#' @param methodArgs Options forwarded to the solver, +#' \code{\link{penalizedRss}}, built with +#' \code{\link{PenalizedRssOptions}}. A bare list is refused: it cannot +#' be checked against the engine, so a misspelled option would be +#' silently ignored. +#' @inheritParams lassosumRssWeights +#' @return A numeric vector of SNP coefficient weights. Unless +#' \code{fitRetention = "none"}, the search is attached as attribute +#' \code{"fit"}. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] @@ -2779,34 +3135,37 @@ scadRssWeights <- function( #' stat <- list( #' b = vapply(ss, `[`, numeric(1), 1L), #' seb = vapply(ss, `[`, numeric(1), 2L), -#' n = rep(nrow(X), ncol(X)) +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) #' ) -#' LD <- cor(X) -#' mcpRssWeights(stat, LD) +#' mcpRssWeights(stat, LdMatrix(cor(X))) #' @importFrom checkmate assertList assertNumeric assertNumber #' @export mcpRssWeights <- function( stat, - LD, + ldReference, s = c(0.2, 0.5, 0.9, 1.0), gamma = 3.0, alpha = 1.0, selection = c("ldQuadratic", "minFbeta"), + fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) { .assertMethodOptions(methodArgs, "PenalizedRssOptions", "methodArgs") + fitRetention <- arg_match(fitRetention) assertList(stat) assertNumeric(s, lower = 0, any.missing = FALSE) assertNumber(gamma, finite = TRUE) assertNumber(alpha, finite = TRUE) .penalizedRssWeights( stat = stat, - LD = LD, + ldReference = ldReference, penalty = "MCP", s = s, gamma = gamma, alpha = alpha, selection = selection, + fitRetention = fitRetention, methodArgs = methodArgs ) } @@ -2821,9 +3180,16 @@ mcpRssWeights <- function( #' converges, non-zero coefficients are tested for swaps with zero ones to #' escape local optima. #' -#' @param stat A list with \code{$b} (effect sizes) and \code{$n} (per-variant -#' sample sizes). -#' @param LD LD correlation matrix R (single matrix, NOT pre-shrunk). +#' @param stat A list of summary statistics: \code{n} (per-variant sample +#' sizes) and the marginal effects as \code{cor} (standardized), \code{z}, +#' \code{b} with \code{seb}, or \code{b} alone, taken as already +#' standardized. The engine receives the standardized effects z / sqrt(n), +#' with n the median of \code{n}. +#' @param ldReference The LD reference the statistics' variants are matched +#' to by \code{stat$variantNames}: a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +#' \code{\link{LdMatrix}}. A genotype reference's LD is used through its +#' standardized genotypes, never formed as a matrix. #' @param penalty L0 variant: \code{"L0"}, \code{"L0L1"}, or \code{"L0L2"}. #' Default \code{"L0"}. #' @param s Numeric vector of LD shrinkage parameters. Default: \code{c(0.2, @@ -2836,11 +3202,22 @@ mcpRssWeights <- function( #' @param selection Selection strategy: \code{"ldQuadratic"} (default) or #' \code{"minFbeta"}. #' @param maxSwaps Maximum swap rounds per lambda. Default 100. -#' @param methodArgs Options forwarded to \code{penalizedRss}, built -#' with \code{\link{PenalizedRssOptions}}. A bare list is refused: it -#' cannot be checked against the engine, so a misspelled option would -#' be silently ignored. -#' @return A numeric vector of SNP coefficient weights. +#' @param fitRetention How much of the search is kept as the \code{"fit"} +#' attribute of the returned weights. \code{"none"} (default) attaches +#' nothing. \code{"slim"} keeps \code{path}, a table with one row per +#' candidate (\code{s}, \code{lambda0}, \code{lambda}) giving the solver's +#' objective \code{fbeta}, \code{loss}, convergence flag \code{conv} and +#' number of non-zero coefficients \code{nparams}, with \code{selected} +#' marking the candidate returned. \code{"full"} also keeps \code{beta}, +#' the candidates' coefficients (variants x candidates, in the rows' order). +#' @param methodArgs Options forwarded to the solver, +#' \code{\link{penalizedRss}}, built with +#' \code{\link{PenalizedRssOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be silently +#' ignored. +#' @return A numeric vector of SNP coefficient weights. Unless +#' \code{fitRetention = "none"}, the search is attached as attribute +#' \code{"fit"}. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] @@ -2850,14 +3227,14 @@ mcpRssWeights <- function( #' stat <- list( #' b = vapply(ss, `[`, numeric(1), 1L), #' seb = vapply(ss, `[`, numeric(1), 2L), -#' n = rep(nrow(X), ncol(X)) +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) #' ) -#' LD <- cor(X) -#' l0learnRssWeights(stat, LD) +#' l0learnRssWeights(stat, LdMatrix(cor(X))) #' @export l0learnRssWeights <- function( stat, - LD, + ldReference, penalty = c("L0", "L0L1", "L0L2"), s = c(0.2, 0.5, 0.9, 1.0), lambda0 = exp(seq(log(0.001), log(1), length.out = 10)), @@ -2865,11 +3242,13 @@ l0learnRssWeights <- function( lambda2 = 0, selection = c("ldQuadratic", "minFbeta"), maxSwaps = 100, + fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) { .assertMethodOptions(methodArgs, "PenalizedRssOptions", "methodArgs") penalty <- arg_match(penalty) selection <- arg_match(selection) + fitRetention <- arg_match(fitRetention) # Default lambda (L1 component) depends on variant if (is.null(lambda)) { @@ -2882,7 +3261,7 @@ l0learnRssWeights <- function( .rssShrinkGridWeights( stat, - LD, + .rssLdSource(stat, ldReference, "l0learnRssWeights"), s, "l0learn", list( @@ -2893,7 +3272,8 @@ l0learnRssWeights <- function( maxSwaps = maxSwaps, dotArgs = methodArgs ), - selection + selection, + fitRetention ) } @@ -3259,7 +3639,6 @@ bLassoWeights <- function( #' nothing, \code{"slim"} and \code{"full"} attach the fitted model. This #' engine keeps no trimmable intermediates, so the two retaining levels #' behave alike here. -#' Default \code{FALSE}. #' @param nK Integer. Number of variational mixture components for the VB fit #' (\code{dprVbWeights}). Default \code{8}. #' @param sStep Integer. Number of Gibbs sampling steps for the Gibbs fit @@ -3422,7 +3801,7 @@ dprAdaptiveGibbsWeights <- function( numThreads ) { .mrmashRequirePackages() - .assertMethodParam(prior, "MrmashPriorParam", "prior") + .assertMethodParam(prior, "MrmashPriorParam") .assertMethodOptions(methodArgs, "MrmashOptions", "methodArgs") priorOpts <- as.list(prior) .mrmashValidateWrapper( @@ -3658,6 +4037,7 @@ mrmashWrapper <- function( Y, alpha = 0.5, standardize = standardize, + numThreads = numThreads, Xnew = NULL ) } @@ -3701,12 +4081,11 @@ mrmashWrapper <- function( ) } -# Run mr.mash with the resolved prior / init / V. -# @noRd -# The mr.mash call. Everything pecotmr derives -- the prior, the residual -# covariance, the coefficient initialisation -- is supplied here and cannot be -# overridden; the rest of mr.mash's arguments come from `methodArgs` under -# mr.mash's own names, with pecotmr's defaults underneath. +# Run mr.mash with the resolved prior / init / V. Everything pecotmr derives -- +# the prior, the residual covariance, the coefficient initialisation -- is +# supplied here and cannot be overridden; the rest of mr.mash's arguments come +# from `methodArgs` under mr.mash's own names, with pecotmr's defaults +# underneath. # @noRd .mrmashFit <- function( S0, @@ -3860,17 +4239,34 @@ computeCoefficientsGlasso <- function( return(res) } -### Function to compute coefficients for univariate glmnet +# Initial mr.mash coefficients from one cv.glmnet per response. The fits are +# independent, so with `numThreads` >= 2 they run in parallel, each worker on +# its own seeded RNG stream (cv.glmnet draws its folds at random); one thread +# runs them in turn on the session RNG, as before. +# @noRd computeCoefficientsUnivGlmnet <- function( X, Y, alpha, standardize, + numThreads = 1L, Xnew = NULL ) { r <- ncol(Y) - - out <- map(seq_len(r), .linreg, X, Y, alpha, standardize, Xnew) + out <- if (numThreads >= 2L) { + bplapply( + seq_len(r), + .linreg, + X = X, + Y = Y, + alpha = alpha, + standardize = standardize, + Xnew = Xnew, + BPPARAM = .bpSeedParam(numThreads) + ) + } else { + map(seq_len(r), .linreg, X, Y, alpha, standardize, Xnew) + } bhatList <- map(out, "bhat") Bhat <- exec(cbind, !!!bhatList) @@ -3952,10 +4348,11 @@ rescaleCovW0 <- function(w0) { # ceiling(log2(gmax/gmin)/log2(mult)), carried fewer points than mr.mash # would have used. # -# `mult = sqrt(2)` (finer than upstream's default 2) and the square are -# pecotmr's own choices: this grid scales variances, not standard -# deviations. autoselect.mixsd() drops Shat that is zero or non-finite, -# which covers NA, so the port's extra is.na() term was redundant. +# `mult = sqrt(2)` and the square follow mr.mashr's own documented recipe +# (the mr.mash() and mr.mash.rss() examples build their grids exactly so): +# this grid scales variances, not standard deviations. autoselect.mixsd() +# drops Shat that is zero or non-finite, which covers NA, so the port's extra +# is.na() term was redundant. # @noRd computeGrid <- function(bhat, sbhat) { mr.mashr::autoselect.mixsd( @@ -4192,22 +4589,12 @@ buildMrmashPriorMatrices <- function( if (is.null(priorGrid)) { priorGrid <- computeGrid(bhat = Bhat, sbhat = Shat) } - - if (isTRUE(canonicalPriorMatrices)) { - canonical <- exec( - mr.mashr::compute_canonical_covs, - K, - !!!as.list(canonicalCovs) - ) - S0_raw <- if (!is.null(dataDrivenPriorMatrices)) { - c(canonical, dataDrivenPriorMatrices$U) - } else { - canonical - } - } else { - S0_raw <- dataDrivenPriorMatrices$U - } - + S0_raw <- .mrmashRawPriorCovs( + K, + dataDrivenPriorMatrices, + canonicalPriorMatrices, + canonicalCovs + ) S0 <- exec( mr.mashr::expand_covs, S0_raw, @@ -4217,26 +4604,62 @@ buildMrmashPriorMatrices <- function( list(S0 = S0, priorGrid = priorGrid) } +# The unexpanded prior covariances: the canonical set (when requested) plus +# any data-driven matrices, or the data-driven matrices alone. +# @noRd +.mrmashRawPriorCovs <- function( + K, + dataDrivenPriorMatrices, + canonicalPriorMatrices, + canonicalCovs +) { + if (!isTRUE(canonicalPriorMatrices)) { + return(dataDrivenPriorMatrices$U) + } + canonical <- exec( + mr.mashr::compute_canonical_covs, + K, + !!!as.list(canonicalCovs) + ) + if (is.null(dataDrivenPriorMatrices)) { + return(canonical) + } + c(canonical, dataDrivenPriorMatrices$U) +} + # ---- map/apply helpers (lambda-free callbacks) --------------------------- -# `.rssSolvePath` solver for lassosum: RSS lasso over the ordered lambda path. +# `.rssSolvePath` solver for lassosum: RSS lasso over the ordered lambda path, +# on the LD matrix or on a factor of it (never forming R). # @noRd -.rssLassosumSolve <- function(z, lam, R, thr, maxiter) { - lassosumRssRcpp( +.rssLassosumSolve <- function(z, lam, ld, thr, maxiter) { + if (!is.null(ld$F)) { + return(lassosumRssFactorCpp( + zR = z, + factorR = ld$F, + shrink = ld$shrink %||% 0, + lambdaR = lam, + thr = thr, + maxiter = as.integer(maxiter) + )) + } + lassosumRssCpp( zR = z, - LD = list(blk1 = R), + LD = list(blk1 = ld$R), + shrink = ld$shrink %||% 0, lambdaR = lam, thr = thr, maxiter = as.integer(maxiter) ) } -# `.rssSolvePath` solver for the penalized (MCP/SCAD/L0...) RSS path. +# `.rssSolvePath` solver for the penalized (MCP/SCAD/L0...) RSS path, on the +# LD matrix or on a factor of it (never forming R). # @noRd .rssPenalizedSolve <- function( z, lam, - R, + ld, penalty, gamma, alpha, @@ -4246,9 +4669,7 @@ buildMrmashPriorMatrices <- function( maxiter, maxSwaps ) { - penalizedRssRcpp( - zR = z, - LD = list(blk1 = R), + settings <- list( lambdaR = lam, penaltyStr = penalty, gamma = gamma, @@ -4259,16 +4680,29 @@ buildMrmashPriorMatrices <- function( maxiter = as.integer(maxiter), maxSwaps = as.integer(maxSwaps) ) + if (!is.null(ld$F)) { + return(exec( + penalizedRssFactorCpp, + zR = z, + factorR = ld$F, + shrink = ld$shrink %||% 0, + !!!settings + )) + } + exec( + penalizedRssCpp, + zR = z, + LD = list(blk1 = ld$R), + shrink = ld$shrink %||% 0, + !!!settings + ) } # One L0Learn fit at lambda0 = `l0Val`: penalizedRss over the lambda path. # @noRd -.rssL0LambdaFit <- function(l0Val, solverInput, LDs, n, sVal, config) { - penArgs <- c( +.rssL0LambdaFit <- function(l0Val, solverInput, ld, n, sVal, config) { + settings <- c( list( - bhat = solverInput, - R = LDs, - n = n, penalty = config$penalty, lambda = config$lambda, lambda0 = l0Val, @@ -4277,15 +4711,10 @@ buildMrmashPriorMatrices <- function( ), as.list(config$dotArgs) ) - model <- exec(penalizedRss, !!!penArgs) + model <- .penalizedRssOn(solverInput, ld, n, settings) list( beta = model$beta, - meta = tibble( - s = rep(sVal, length(model$lambda)), - lambda0 = rep(l0Val, length(model$lambda)), - lambda = model$lambda, - fbeta = model$fbeta - ) + meta = mutate(.rssPathMeta(sVal, model), lambda0 = l0Val, .after = "s") ) } diff --git a/R/relatednessQc.R b/R/relatednessQc.R index 8a398a229..54e690eee 100644 --- a/R/relatednessQc.R +++ b/R/relatednessQc.R @@ -233,8 +233,8 @@ filterRelatedness <- function( verbose = FALSE ) { .relatednessRequirePackages() - .assertMethodParam(columns, "RelatednessColumnsParam", "columns") - .assertMethodParam(pruning, "RelatednessPruningParam", "pruning") + .assertMethodParam(columns, "RelatednessColumnsParam") + .assertMethodParam(pruning, "RelatednessPruningParam") .assertMethodOptions(plinkQcArgs, "PlinkQcOptions", "plinkQc") analysisType <- arg_match(analysisType) relatedness <- as_tibble(relatedness) diff --git a/R/resultReaders.R b/R/resultReaders.R index b42ebca4f..5b9a3f870 100644 --- a/R/resultReaders.R +++ b/R/resultReaders.R @@ -64,6 +64,7 @@ NULL SE = "marginal_se", WGT = "posterior_mean", WGTSE = "posterior_sd", + THETA = "posterior_theta", PIP = "pip", LBF = "logBF", LFSR = "lfsr" @@ -1216,13 +1217,7 @@ readTwasWeights <- function( label <- "readTwasWeights" src <- .prdRead(path, region, format, sampleSelect, label) df <- src$table - if (!is_in("WGT", names(df))) { - abort(glue( - "{label}: no `WGT` column. The weight is the whole content of a ", - "TwasWeights. For a fine-mapping table use ", - "readFineMappingResult()." - )) - } + .prdRequireWgt(df, label) .prdRequireStandardized(df, weightStandardized, label) supplied <- compact(list( study = studyName, @@ -1239,6 +1234,24 @@ readTwasWeights <- function( supplied = supplied, label = label ) + .prdTwFromRows(rows, label) +} + +# @noRd +.prdRequireWgt <- function(df, label) { + if (!is_in("WGT", names(df))) { + abort(glue( + "{label}: no `WGT` column. The weight is the whole content of a ", + "TwasWeights. For a fine-mapping table use ", + "readFineMappingResult()." + )) + } +} + +# Assemble the TwasWeights collection from the per-group `.prdTwRow()` +# records; an empty file reads back as an empty collection. +# @noRd +.prdTwFromRows <- function(rows, label) { if (length(rows) == 0L) { return(TwasWeights( studyName = character(0), diff --git a/R/resultWriters.R b/R/resultWriters.R index e8b5e6e0f..0bb61c8fd 100644 --- a/R/resultWriters.R +++ b/R/resultWriters.R @@ -7,10 +7,11 @@ # exportToVcf(x, path, ...) GWAS-VCF-style: one record per variant, one # SAMPLE per study / fitted model, the statistics # as FORMAT fields. GwasSumStats, every -# FineMappingResult, TwasWeights. +# FineMappingResultBase, TwasWeights. # exportToBed(x, path, ...) the published long-format tables, one row per # published observation, bgzipped + tabix-indexed -# on request. FineMappingResult, TwasWeights. +# on request. FineMappingResultBase, +# TwasWeights. # # One file because they are one problem -- project an S4 collection onto a # FIXED published schema, join the posterior view to the marginal one, sort @@ -170,8 +171,9 @@ NULL return(combineFineMappingResults(x)) } abort(glue( - "`x` must be a TwasWeights or FineMappingResult object, or a list ", - "of one of those; got a list of {class(x[[1L]])[[1L]]}." + "`x` must be a TwasWeights, QtlFineMappingResult or ", + "GwasFineMappingResult object, or a list of one of those; got a ", + "list of {class(x[[1L]])[[1L]]}." )) } @@ -250,15 +252,16 @@ NULL # Refuse to export a collection whose rows lack a FULL-DATA fit. # # Cross-validation alone is not publishable. A CV-only run -- which is what -# `twasWeightsPipeline(fitFullData = FALSE)` produces, and which is legal only -# WITH cross-validation -- stores each row as an empty element with no weights -# and nothing but its `cvResult`. All it holds is fold-level results, and those -# cannot go in a published file: fold membership is sample-level information -# and sample names can be protected. So an export needs the full-data fit, and -# its absence is an ERROR rather than a silently empty output file. +# twasWeightsPipeline() produces under `CrossValidationParam(fitFullData = +# FALSE)`, legal only WITH cross-validation -- stores each row as an empty +# element with no weights and nothing but its `cvResult`. All it holds is +# fold-level results, and those cannot go in a published file: fold +# membership is sample-level information and sample names can be protected. +# So an export needs the full-data fit, and its absence is an ERROR rather +# than a silently empty output file. # -# The check is on the OBJECT, not on the flag: `fitFullData` is a pipeline -# argument that may not have been the thing that emptied a row, and an export +# The check is on the OBJECT, not on the flag: `fitFullData` is a run setting +# that may not have been the thing that emptied a row, and an export # has to be safe whatever produced its input. # # It also keeps genomicRegion() honest. That derives a row's analysis window @@ -275,7 +278,8 @@ NULL "full-data fit, only cross-validation results -- ", "{str_flatten(.pubRowLabels(x, incomplete), ', ')}. Fold-level ", "results cannot be published (fold membership is sample-level ", - "information), so refit with `fitFullData = TRUE` and export that. ", + "information), so refit with ", + "`CrossValidationParam(fitFullData = TRUE)` and export that. ", "The cross-validation record stays available through cvResult()." )) } @@ -293,10 +297,9 @@ NULL # @noRd .twbRowHasWeights <- function(i, x) !is.null(mcols(x[[i]])$weight) -# Rows of a FineMappingResult with no fitted variants. Fine-mapping has no -# CV-only mode today -- .fmAttachCv() rebuilds the row around its existing -# susieFit and topLoci, so CV is strictly additive -- but the export checks -# rather than assumes it. +# Rows of a fine-mapping result with no fitted variants: what a +# cross-validation only run (CrossValidationParam(fitFullData = FALSE)) leaves +# in each row. # @noRd .fmbIncompleteRows <- function(x) { which(lengths(x) == 0L) @@ -409,10 +412,10 @@ genomicOrder <- function(chrom, start, end = NULL) { # # utils::write.table(), not vroom_write(): the two differ in how they format a # float (1e-06 vs 1e-6) and in how many digits they keep. -# @noRd # `emptySchema` is the header an empty result still documents -- the schema of # whichever table was being written, since the fsusie table's vocabulary is not # the per-variant one. +# @noRd .pubWriteTable <- function( out, path, @@ -788,6 +791,12 @@ setMethod( # susie posterior mean IS the TWAS coefficient. # @noRd .vcfCoreSpecs <- function(base, m, nSnps) { + c(.vcfMarginalSpecs(m, nSnps), .vcfFitSpecs(base, nSnps)) +} + +# The marginal-association FORMAT fields, from the joined marginals `m`. +# @noRd +.vcfMarginalSpecs <- function(m, nSnps) { p <- suppressWarnings(as.numeric(.pubCol(m, "p", nSnps))) list( .vcfSpec( @@ -825,7 +834,15 @@ setMethod( "Variant-specific number of samples/individuals with called ", "genotypes used to test association with specified trait" ) - ), + ) + ) +} + +# The per-variant FORMAT fields read off the fit itself (`base`): allele +# frequency and the posterior effect / prediction weight. +# @noRd +.vcfFitSpecs <- function(base, nSnps) { + list( .vcfSpec( "AF", .pubCol(base, "af", nSnps), @@ -843,6 +860,15 @@ setMethod( .pubCol(base, "posterior_se", nSnps), "Float", "Standard error of the posterior effect estimate" + ), + .vcfSpec( + "THETA", + .pubCol(base, "theta", nSnps), + "Float", + str_c( + "Infinitesimal component of WGT (susieInf / susieAsh); ", + "already included in WGT, 0 for methods without one" + ) ) ) } @@ -1247,7 +1273,6 @@ setMethod( ) } -# @noRd # One mcols cell as a string. `[[row]]` then pack, rather than # as.character() on the column: several of these are List columns (a # TwasWeights `dataType` is one) and as.character() on a CompressedList @@ -1290,7 +1315,7 @@ setMethod( } # The same rule the BED path applies, and for the same reason: a # fine-mapping method's "weights" are the posterior re-expressed, so - # the FineMappingResult says strictly more. This path used to publish + # the fine-mapping result says strictly more. This path used to publish # them, which made the two formats disagree about what a weights file # contains. rows <- intersect(rows, .twbExportableRows(x, "exportToVcf")) @@ -1298,7 +1323,7 @@ setMethod( abort(str_c( "exportToVcf: every selected row is fine-mapping-derived, so ", "there is nothing to write as weights. Export the ", - "FineMappingResult." + "fine-mapping result." )) } .twvWriteSamples( @@ -1699,12 +1724,12 @@ setMethod( "grid_band_halfwidth" ) -# @noRd # The trait-level group. `joint_traits` rather than a new `trait_names`: these # ARE the joint members (fsusieTraitEffects() reads them from the row's # `jointTraits` column), so they use the vocabulary the rest of the schema # already has for joint membership. "epi_mark" also presumed epigenomic data, # which a functional fit does not require. +# @noRd .FMB_FSUSIE_TRAIT_COLUMNS <- c( "trait_positions", "trait_effects", @@ -1773,6 +1798,15 @@ setMethod( # One (row, credible set) block of the fSuSiE table. `v` is that CS's # credibleSets() rows; `band` / `marks` are the matching curve views, already # narrowed to the same row. +# +# The "chr" prefix is kept, as in the other two schemas and in the protocol's +# own phenotype BEDs; stripping it here was unique to this table and made one +# reader rule impossible. AF, not MAF, is published: the same `af` the other +# table publishes. Writing pmin(af, 1 - af) here lost which allele the +# frequency referred to, so one export of an object was recoverable and the +# other was not. Membership is written at EVERY coverage the fit carries, not +# just the one keying the rows -- a secondary coverage would otherwise be +# silently dropped. # @noRd .fmbFsusieBlock <- function( v, @@ -1788,41 +1822,26 @@ setMethod( key <- .pubIdentityKey(v, .PUB_ROW_COLS)[[1L]] cs <- v[[str_c("cs_", primary)]][[1L]] context <- v$context[[1L]] - bKey <- .pubIdentityKey(band, .PUB_ROW_COLS) - mKey <- .pubIdentityKey(marks, .PUB_ROW_COLS) - b <- band[bKey == key & band$cs == cs, , drop = FALSE] + b <- .fmbCurveRows(band, key, cs) if (nrow(b) == 0L) { return(NULL) } - m <- marks[mKey == key & marks$cs == cs, , drop = FALSE] + m <- .fmbCurveRows(marks, key, cs) i <- match(key, names(rowRegionIds)) regionId <- rowRegionIds[[i]] rg <- rowRegions[i] csId <- str_c(context, regionId, str_remove(cs, "^fsusie_"), sep = ":") out <- tibble( - # The "chr" prefix is kept, as in the other two schemas and in the - # protocol's own phenotype BEDs; stripping it here was unique to this - # table and made one reader rule impossible. `#chr` = as.character(v$chrom), start = v$pos - 1L, end = v$pos, ID = v$variant_id, REF = .pubCol(v, "A2"), ALT = .pubCol(v, "A1"), - # AF, not MAF: the same `af` the other table publishes. Writing - # pmin(af, 1 - af) here lost which allele the frequency referred to, - # so one export of an object was recoverable and the other was not. AF = .pubCol(v, "af"), PIP = v$pip, cs_id = csId, cs_root = csId, - grid_resolution = nrow(b), - grid_positions = .pubPack(b$pos), - grid_effects = .pubPack(b$effect), - grid_band_halfwidth = .pubPack(b$halfwidth), - trait_positions = .pubPack(m$traitPos), - trait_effects = .pubPack(m$effect), - joint_traits = .pubPack(m$jointTrait), study = .pubCol(v, "study"), context = context, trait = .pubCol(v, "trait"), @@ -1831,15 +1850,46 @@ setMethod( region_start = start(rg) - 1L, region_end = end(rg) ) - # Membership at EVERY coverage the fit carries, not just the one keying - # the rows -- a secondary coverage would otherwise be silently dropped. - out <- bind_cols(out, .pubFrameCs(v, csCols)) + out <- bind_cols(out, .fmbFsusieGrid(b, m), .pubFrameCs(v, csCols)) bind_cols( select(out, all_of(.fmbFsusieColumns(levels, csCols))), select(v, all_of(added)) ) } +# The rows of a curve view (credible band or trait marks) belonging to one +# (row identity, credible set) pair. +# @noRd +.fmbCurveRows <- function(view, key, cs) { + keep <- .pubIdentityKey(view, .PUB_ROW_COLS) == key & view$cs == cs + view[keep, , drop = FALSE] +} + +# The packed functional-grid columns of one fSuSiE block: the credible band +# `b` over the grid and the per-trait marks `m`. +# @noRd +.fmbFsusieGrid <- function(b, m) { + tibble( + grid_resolution = nrow(b), + grid_positions = .pubPack(b$pos), + grid_effects = .pubPack(b$effect), + grid_band_halfwidth = .pubPack(b$halfwidth), + trait_positions = .pubPack(m$traitPos), + trait_effects = .pubPack(m$effect), + joint_traits = .pubPack(m$jointTrait) + ) +} + +# The fSuSiE BED table: one block per (row, credible set) of the fsusie rows. +# +# genomicRegion() is the window each row was ANALYSED over (the requested +# region, or the trait's cis window), which is what a publication table means +# by its region -- not the narrower span of whichever variants survived QC. +# +# Splitting the views on (context, cs) alone is only safe for a single +# region: once several regions are combined into one table, two regions can +# each contribute context "c1" / "fsusie_1", and they must stay separate rows +# with their own windows. # @noRd .fmbFsusieTable <- function(x, columns, levels, coverage) { fs <- x[as.character(.tupleColumn(x, "method")) == "fsusie"] @@ -1858,19 +1908,11 @@ setMethod( primary <- .fmbPrimaryCsLevel(csTbl, coverage) csCols <- .pubCsColumns(csTbl, coverage) marks <- as.data.frame(fsusieTraitEffects(fs)) - # genomicRegion() is the window each row was ANALYSED over (the requested - # region, or the trait's cis window), which is what a publication table - # means by its region -- not the narrower span of whichever variants - # survived QC. rowRegions <- genomicRegion(fs) rowRegionIds <- set_names( .pubRegionIds(rowRegions), .pubCollectionKey(fs, .PUB_ROW_COLS) ) - # Splitting the views on (context, cs) alone is only safe for a single - # region: once several regions are combined into one table, two regions can - # each contribute context "c1" / "fsusie_1", and they must stay separate - # rows with their own windows. pieces <- compact(map( split( csTbl, @@ -1946,6 +1988,11 @@ setMethod( # columns that are both here. "WGT", "WGTSE", + # The infinitesimal half of WGT. susieInf / susieAsh split the posterior + # into a sparse and an infinitesimal term and coef.susie() sums them, so + # WGT is right either way -- this is what makes the split visible, which + # is otherwise unrecoverable from the published file. 0 elsewhere. + "THETA", # Fine-mapping posterior. CS/PUR are spliced in after these. "PIP", "LBF", @@ -1959,7 +2006,8 @@ setMethod( "block_id", # Provenance. `data_type` is the assay/modality; `data_source` is # individual-level vs summary-statistics, which `data_type` was being - # mistaken for and which is derivable from whether an ldSketch is present. + # mistaken for and which is derivable from whether an ldReference is + # present. "data_type", "data_source", "weight_standardized", @@ -2114,6 +2162,14 @@ setMethod( "p" ) +# The topLoci BED table. +# +# `tl$beta`/`tl$se` are the POSTERIOR mean and sd -- topLoci() is the +# posterior view -- while `mm$beta`/`mm$se` are the MARGINAL estimates. Same +# column name, different quantity, which is why they land in different +# published fields. Per-CS variant-level columns from a fullFit build ride +# after the fixed schema; `columns` adds whatever else the caller asked for +# after those. # @noRd .fmbTopLociTable <- function(x, signalCutoff, minPurity, columns, coverage) { tl <- as.data.frame( @@ -2122,10 +2178,6 @@ setMethod( if (nrow(tl) == 0L) { return(NULL) } - # `tl$beta`/`tl$se` are the POSTERIOR mean and sd -- topLoci() is the - # posterior view -- while `mm$beta`/`mm$se` are the MARGINAL estimates. - # Same column name, different quantity, which is why they land in - # different published fields. mm <- .pubJoinMarginals(tl, as.data.frame(marginalEffects(x))) win <- .fmbRowWindows(x, tl) pos <- .pubCol(tl, "pos") @@ -2147,6 +2199,7 @@ setMethod( LP = if_else(is.na(p) | p <= 0, NA_real_, -log10(p)), WGT = .pubCol(tl, "posterior_effect"), WGTSE = .pubCol(tl, "posterior_se"), + THETA = .pubCol(tl, "theta"), PIP = .pubCol(tl, "pip"), LBF = .pubCol(tl, "logBF"), LFSR = .pubCol(tl, "lfsr") @@ -2160,8 +2213,6 @@ setMethod( ) ) out <- .pubFrame(cols, .pubSchema(csCols)) - # Per-CS variant-level columns from a fullFit build ride after the fixed - # schema; `columns` adds whatever else the caller asked for after those. added <- union( .pubFullFitColumns(tl), .pubViewColumns(tl, columns, .FMB_TOPLOCI_SOURCE) @@ -2211,8 +2262,9 @@ setMethod( } # The identity and provenance values shared by both record kinds. `data_source` -# is derived rather than stored: a collection's ldSketch is the LD reference the -# fit was run against, so its absence means the fit saw individual-level data. +# is derived rather than stored: a collection's ldReference is the LD reference +# the fit was run against, so its absence means the fit saw individual-level +# data. # @noRd .pubIdentityValues <- function(x, view) { list( @@ -2230,19 +2282,15 @@ setMethod( ) } -# The collection-level fallback for `data_source`: an ldSketch is the LD +# The collection-level fallback for `data_source`: an ldReference is the LD # reference a fit was run against, so its absence means individual-level data. # Only a fallback -- a row that recorded its own wins, because a combined -# collection can hold rows of both kinds and has only one ldSketch. +# collection can hold rows of both kinds and has only one ldReference. # @noRd .pubDataSource <- function(x) { - if (is.null(ldSketch(x))) "individual" else "sumstat" + if (is.null(ldReference(x))) "individual" else "sumstat" } -# @noRd -# Absent OR entirely empty both mean "the rows did not record this", because -# .fmrRowMetadata() NA-fills a column the collection lacks -- so testing only -# for absence would return the NA column and never reach the fallback. # `EZ` only when the SOURCE supplied z. The spec defines the field as the z # "provided if it was used to derive the ES and SE fields", so publishing a z # that pecotmr itself computed as beta/se would invert its meaning -- and a @@ -2262,6 +2310,9 @@ setMethod( replace(z, is.na(supplied) | !supplied, NA_real_) } +# Absent OR entirely empty both mean "the rows did not record this", because +# .fmrRowMetadata() NA-fills a column the collection lacks -- so testing only +# for absence would return the NA column and never reach the fallback. # @noRd .pubRowOrDerived <- function(view, nm, fallback) { v <- .pubCol(view, nm) @@ -2292,11 +2343,6 @@ setMethod( ) } -# The analysis window of the collection row each long-view row came from, -# matched on the row identity so a folded multi-row table keeps each row's own -# window rather than the first one's. -# @noRd - # ---- BED: fine-mapping entry point ------------------------------------------ #' @rdname exportToBed @@ -2465,7 +2511,7 @@ setMethod( } # Fine-mapping methods have no business in a weights export: their "weights" -# are the fine-mapping posterior re-expressed, so the FineMappingResult says +# are the fine-mapping posterior re-expressed, so the fine-mapping result says # strictly more. Those rows are skipped with a message rather than written. # @noRd .TWB_FINE_MAPPING_METHODS <- c( @@ -2485,8 +2531,8 @@ setMethod( "{label}: skipping {length(skip)} fine-mapping-derived ", "row(s) ({str_flatten(unique(methods[skip]), ', ')}). Those ", "weights are the fine-mapping posterior re-expressed -- export ", - "the FineMappingResult instead, which carries the posterior, its ", - "standard error and the credible sets." + "the fine-mapping result instead, which carries the posterior, ", + "its standard error and the credible sets." )) } setdiff(seq_len(nrow(x)), skip) @@ -2574,24 +2620,21 @@ setMethod( )) } -# Per-variant allele frequency, from the collection's LD panel when it has one. -# A TwasWeights element records only alleles and a weight, so without a panel -# there is no frequency to publish -- and `AF` is what the standardized-to-raw -# weight conversion needs, so its absence is worth seeing rather than faking. +# Per-variant allele frequency, from the collection's LD reference when it +# records one (an LdMatrix with an AF column, or a stochastic sketch, whose +# real frequencies are recorded from its sidecar). A TwasWeights element +# records only alleles and a weight, so otherwise there is no frequency to +# publish -- and `AF` is what the standardized-to-raw weight conversion needs, +# so its absence is worth seeing rather than faking. # @noRd .twbVariantAf <- function(x, gr) { - panel <- ldSketch(x) - if (is.null(panel)) { - return(NA_real_) - } - rr <- try_fetch( - SummarizedExperiment::rowRanges(panel), - error = function(cnd) NULL - ) - if (is.null(rr) || !is_in("af", colnames(mcols(rr)))) { + ref <- ldReference(x) + af <- if (is.null(ref)) NULL else .ldRefAf(ref) + if (is.null(af)) { return(NA_real_) } - as.numeric(mcols(rr)$af)[match(.grVariantIds(gr), .grVariantIds(rr))] + rr <- .ldRefRanges(ref) + as.numeric(af)[match(.grVariantIds(gr), .grVariantIds(rr))] } # @noRd @@ -2600,7 +2643,7 @@ setMethod( if (length(rows) == 0L) { abort(str_c( "exportToBed: every row is fine-mapping-derived, so there is ", - "nothing to write as weights. Export the FineMappingResult." + "nothing to write as weights. Export the fine-mapping result." )) } schema <- .pubSchema(.pubCsColumns(tibble(), coverage)) diff --git a/R/sumstatsQc.R b/R/sumstatsQc.R index be92e1649..48ea8998a 100644 --- a/R/sumstatsQc.R +++ b/R/sumstatsQc.R @@ -26,7 +26,7 @@ NULL # Allele harmonization (harmonizeAlleles) now lives in R/variantId.R, alongside # the other variant-matching primitives (parseVariantId, matchVariants). It is -# package-internal and called from here (.matchAgainstSketch), ctwasPipeline, +# package-internal and called from here (.matchAgainstLdRef), ctwasPipeline, # and the pipeline join sites. # Standardize a variant set (GRanges or data.frame) to a chrom/pos/alt/ref @@ -140,12 +140,7 @@ resolveLdInput <- function( needNSample = FALSE, ldMethod = "sample" ) { - if (is.null(R) && is.null(X)) { - abort("Either R (LD matrix) or X (genotype matrix) must be provided.") - } - if (!is.null(R) && !is.null(X)) { - abort("Provide either R or X, not both.") - } + .ldRequireOneSource(R, X) if (!is.null(X)) { if (!is.matrix(X)) { X <- as.matrix(X) @@ -161,6 +156,18 @@ resolveLdInput <- function( list(R = R, nSample = nSample) } +# Require exactly one of R (LD matrix) or X (genotype matrix). +# @noRd +.ldRequireOneSource <- function(R, X) { + if (is.null(R) && is.null(X)) { + abort("Either R (LD matrix) or X (genotype matrix) must be provided.") + } + if (!is.null(R) && !is.null(X)) { + abort("Provide either R or X, not both.") + } + invisible(NULL) +} + # --- dentist helpers -------------------------------------------------------- # Validate/rename the pos and z columns (accepting position/zscore) + sort. @@ -196,16 +203,19 @@ resolveLdInput <- function( } # Run DENTIST on a single window, unpacking the shared tuning parameters. -.dentistCallSingle <- function(zScore, ldMat, nSample, methodArgs) { +# `ld` is .dentistLdInput()'s list(R) or list(F); a factor goes in as X, which +# dentistSingleWindow() reads without forming the LD. +.dentistCallSingle <- function(zScore, ld, nSample, dentistParam) { # dentistSingleWindow is what DentistParam() is built for -- ldMismatchQc # splices the same bundle into it -- so the tunables travel as one value # rather than being named again at every hop down from dentist(). exec( dentistSingleWindow, zScore, - R = ldMat, + R = ld$R, + X = ld$F, nSample = nSample, - !!!methodArgs + !!!dentistParam ) } @@ -215,10 +225,10 @@ resolveLdInput <- function( .dentistWindowAt <- function( k, sumStat, - ldMat, + ld, nSample, windowDividedRes, - methodArgs + dentistParam ) { # windowEndIdx is 1-based exclusive; convert to an inclusive range. idxRange <- windowDividedRes$windowStartIdx[ @@ -226,20 +236,52 @@ resolveLdInput <- function( ]:(windowDividedRes$windowEndIdx[k] - 1L) .dentistCallSingle( sumStat$z[idxRange], - ldMat[idxRange, idxRange], + .dentistLdSlice(ld, idxRange), nSample, - methodArgs + dentistParam + ) +} + +# One window's LD: the matrix's diagonal block, or the factor's columns. +# @noRd +.dentistLdSlice <- function(ld, idx) { + if (is.null(ld$F)) { + return(list(R = ld$R[idx, idx, drop = FALSE])) + } + list(F = ld$F[, idx, drop = FALSE]) +} + +# The LD a DENTIST run reads, with the sample size it needs. Genotypes under +# the sample estimator give their factor (.ldFactorFromDosage()), which +# DENTIST's factor kernel reads without forming the p x p LD; an LD matrix, +# or genotypes under another estimator, give the matrix (resolveLdInput()). +# Without `nSample`, genotypes count their own rows, as resolveLdInput() +# does. +# @noRd +.dentistLdInput <- function(R, X, nSample, ldMethod) { + .ldRequireOneSource(R, X) + if (is.null(R) && identical(ldMethod, "sample")) { + X <- as.matrix(X) + return(list(F = .ldFactorFromDosage(X), nSample = nSample %||% nrow(X))) + } + ld <- resolveLdInput( + R = R, + X = X, + nSample = nSample, + needNSample = TRUE, + ldMethod = ldMethod ) + list(R = ld$R, nSample = ld$nSample) } .dentistWindows <- function( sumStat, - ldMat, + ld, nSample, windowMode, windowSize, minDim, - methodArgs + dentistParam ) { if (windowMode == "distance") { windowDividedRes <- segmentByDist( @@ -254,10 +296,10 @@ resolveLdInput <- function( seq_len(nrow(windowDividedRes)), .dentistWindowAt, sumStat = sumStat, - ldMat = ldMat, + ld = ld, nSample = nSample, windowDividedRes = windowDividedRes, - methodArgs = methodArgs + dentistParam = dentistParam ) mergeWindows(dentistResultByWindow, windowDividedRes) } @@ -274,8 +316,10 @@ resolveLdInput <- function( #' @param sumStat A data frame containing summary statistics, including 'pos' or #' 'position' and 'z' or 'zscore' columns. #' @param R Square LD correlation matrix. Provide either \code{R} or \code{X}. -#' @param X Genotype matrix (samples x SNPs). If provided, LD is computed via -#' \code{computeLd(X)} and \code{nSample} defaults to \code{nrow(X)}. +#' @param X Genotype matrix (samples x SNPs). With \code{ldMethod = "sample"} +#' DENTIST works on the standardized genotypes and never forms the LD +#' matrix; any other \code{ldMethod} computes LD via \code{computeLd(X)}. +#' \code{nSample} defaults to \code{nrow(X)}. #' @param nSample The number of samples in the LD reference panel (NOT the GWAS #' sample size). This controls the SVD truncation rank K = min(idx_size, #' nSample) * propSVD. Required when \code{R} is provided; inferred from @@ -287,7 +331,7 @@ resolveLdInput <- function( #' \code{"distance"} (default) creates windows by physical distance using #' \code{segmentByDist} (C++ \code{--wind-dist}), and \code{"count"} creates #' windows by variant count using \code{segmentByCount} (C++ \code{--wind}). -#' @param methodArgs The DENTIST algorithm settings, built with +#' @param dentistParam The DENTIST algorithm settings, built with #' \code{\link{DentistParam}}: \code{pValueThreshold}, \code{propSVD}, #' \code{gcControl}, \code{nIter}, \code{gPvalueThreshold}, #' \code{duprThreshold}, \code{numThreads}, \code{correctChenEtAlBug} @@ -299,9 +343,9 @@ resolveLdInput <- function( #' 2000). In count mode: the number of variants per window (i.e., the window #' size). #' @param ldMethod Character string specifying the LD computation method when -#' \code{X} is provided. Passed to \code{computeLd}. One of \code{"sample"} -#' (default), \code{"population"}, or \code{"gcta"}. Ignored when \code{R} is -#' provided directly. +#' \code{X} is provided: \code{"sample"} (default), which uses the +#' genotypes directly, or \code{"population"} or \code{"gcta"}, which go +#' through \code{computeLd}. Ignored when \code{R} is provided directly. #' #' @return A data frame containing the imputed result and detected outliers. #' @@ -367,42 +411,38 @@ dentist <- function( windowMode = c("distance", "count"), minDim = 2000, ldMethod = "sample", - methodArgs = DentistParam() + dentistParam = DentistParam() ) { # The tunables arrive as the record rather than as nine formals of their # own: DentistParam() is already what ldMismatchQc(method =) takes and # what every helper below is spliced with, and duplicating its defaults # here left two places to change one number. - .assertMethodParam(methodArgs, "DentistParam", "methodArgs") - resolved <- resolveLdInput( - R = R, - X = X, - nSample = nSample, - needNSample = TRUE, - ldMethod = ldMethod - ) - ldMat <- resolved$R - nSample <- resolved$nSample + .assertMethodParam(dentistParam, "DentistParam") + # Genotypes become one factor of the LD here, and each window reads its + # columns; the region-wide LD is never formed. + ld <- .dentistLdInput(R, X, nSample, ldMethod) + nSample <- ld$nSample sumStat <- .dentistResolveColumns(sumStat) windowMode <- arg_match(windowMode) if (nrow(sumStat) < minDim) { - return(.dentistCallSingle(sumStat$z, ldMat, nSample, methodArgs)) + return(.dentistCallSingle(sumStat$z, ld, nSample, dentistParam)) } .dentistWindows( sumStat, - ldMat, + ld, nSample, windowMode, windowSize, minDim, - methodArgs + dentistParam ) } # --- dentistSingleWindow helpers ------------------------------------------- -# Warn on small windows; validate the LD matrix shape against zScore. -.dentistValidateInput <- function(zScore, ldMat) { +# Warn on small windows; validate the LD's shape against zScore: a square +# matrix over the variants, or a factor with one column per variant. +.dentistValidateInput <- function(zScore, ld) { if (length(zScore) < 2000) { nZ <- length(zScore) msg <- glue( @@ -414,6 +454,16 @@ dentist <- function( ) warn(msg) } + if (!is.null(ld$F)) { + if (ncol(ld$F) != length(zScore)) { + abort(glue( + "The genotypes must have one column per z-score ", + "({ncol(ld$F)} columns, {length(zScore)} z-scores)." + )) + } + return(invisible(NULL)) + } + ldMat <- ld$R if ( !is.matrix(ldMat) || nrow(ldMat) != ncol(ldMat) || @@ -428,12 +478,16 @@ dentist <- function( } # Optionally deduplicate near-perfectly-correlated variants before imputation. -.dentistDedup <- function(zScore, ldMat, duprThreshold) { +.dentistDedup <- function(zScore, ld, duprThreshold) { if (duprThreshold >= 1.0) { - return(list(zScore = zScore, ldMat = ldMat, dedupRes = NULL)) + return(list(zScore = zScore, ld = ld, dedupRes = NULL)) } rThreshold <- round(sqrt(duprThreshold) * 1000) / 1000 - dedupRes <- .findDuplicateVariants(zScore, ldMat, rThreshold) + dedupRes <- if (is.null(ld$F)) { + .findDuplicateVariants(zScore, ld$R, rThreshold) + } else { + .findDuplicateVariantsFactor(zScore, ld$F, rThreshold) + } numDup <- sum(dedupRes$dupBearer != -1) if (numDup > 0) { nZ <- length(zScore) @@ -445,7 +499,11 @@ dentist <- function( } list( zScore = dedupRes$filteredZ, - ldMat = dedupRes$filteredLD, + ld = if (is.null(ld$F)) { + list(R = dedupRes$filteredLD) + } else { + list(F = dedupRes$filteredFactor) + }, dedupRes = dedupRes ) } @@ -453,11 +511,17 @@ dentist <- function( # Run the C++ iterative imputation and snake_case the output. The C++ returns # any rsq values it capped at 1.0 in `rsqExceed`; summarize them into a single # warning here (no warning handler / shared env needed). -.dentistRunImpute <- function(ldMat, nSample, zScore, p) { +.dentistRunImpute <- function(ld, nSample, zScore, p) { verboseIter <- getOption("pecotmr.dentist.verbose", FALSE) - raw <- dentistIterativeImpute( + # The factor kernel imputes from the LD's factor without forming it. + kernel <- if (is.null(ld$F)) { + dentistIterativeImpute + } else { + dentistIterativeImputeFactor + } + raw <- kernel( # cpp11 requires exact integer types for int parameters - ldMat, + ld$R %||% ld$F, as.integer(nSample), zScore, p$pValueThreshold, @@ -515,8 +579,10 @@ dentist <- function( #' #' @param zScore Numeric vector of z-scores. #' @param R Square LD correlation matrix. Provide either \code{R} or \code{X}. -#' @param X Genotype matrix (samples x SNPs). If provided, LD is computed via -#' \code{computeLd(X)} and \code{nSample} defaults to \code{nrow(X)}. +#' @param X Genotype matrix (samples x SNPs). With \code{ldMethod = "sample"} +#' DENTIST works on the standardized genotypes and never forms the LD +#' matrix; any other \code{ldMethod} computes LD via \code{computeLd(X)}. +#' \code{nSample} defaults to \code{nrow(X)}. #' @param nSample Number of samples in the LD reference panel (NOT the GWAS #' sample size). Controls the SVD truncation rank. Required when \code{R} is #' provided; inferred from \code{X} when \code{X} is provided. @@ -531,9 +597,9 @@ dentist <- function( #' @param correctChenEtAlBug Correct the original DENTIST operator! bug. Default #' is TRUE. #' @param ldMethod Character string specifying the LD computation method when -#' \code{X} is provided. Passed to \code{computeLd}. One of \code{"sample"} -#' (default), \code{"population"}, or \code{"gcta"}. Ignored when \code{R} is -#' provided directly. +#' \code{X} is provided: \code{"sample"} (default), which uses the +#' genotypes directly, or \code{"population"} or \code{"gcta"}, which go +#' through \code{computeLd}. Ignored when \code{R} is provided directly. #' @param seed Integer or \code{NULL}. Random seed for the iterative #' variant-partitioning RNG. \code{NULL} (default) preserves the original #' DENTIST hard-coded seeds (\code{10} for the initial partition, @@ -565,16 +631,9 @@ dentistSingleWindow <- function( ldMethod = "sample", seed = NULL ) { - ld <- resolveLdInput( - R = R, - X = X, - nSample = nSample, - needNSample = TRUE, - ldMethod = ldMethod - ) + ld <- .dentistLdInput(R, X, nSample, ldMethod) nSample <- ld$nSample - ldMat <- ld$R - .dentistValidateInput(zScore, ldMat) + .dentistValidateInput(zScore, ld) p <- list( pValueThreshold = pValueThreshold, propSVD = propSVD, @@ -586,8 +645,8 @@ dentistSingleWindow <- function( seed = seed ) orgZscore <- zScore - dedup <- .dentistDedup(zScore, ldMat, duprThreshold) - imputed <- .dentistRunImpute(dedup$ldMat, nSample, dedup$zScore, p) + dedup <- .dentistDedup(zScore, ld, duprThreshold) + imputed <- .dentistRunImpute(dedup$ld, nSample, dedup$zScore, p) res <- if (duprThreshold < 1.0) { addDupsBackDentist(orgZscore, imputed, dedup$dedupRes) } else { @@ -596,21 +655,6 @@ dentistSingleWindow <- function( .dentistOutlierStat(res, pValueThreshold) } -#' Add duplicates back to DENTIST output -#' -#' This function takes the output from the DENTIST algorithm and adds back the -#' duplicated variants based on the output from the `findDuplicateVariants` -#' function. -#' @param zScore The original zScore -#' @param dentistOutput A data frame containing the output from the DENTIST -#' algorithm. -#' @param findDupOutput A list containing the output from the -#' `findDuplicateVariants` function. -#' -#' @return A data frame with duplicated variants added back and an additional -#' column indicating duplicates. -#' -#' @noRd # --- addDupsBackDentist helpers --------------------------------------------- # Validate DENTIST output vs the duplicate-bearer bookkeeping. @@ -666,6 +710,21 @@ dentistSingleWindow <- function( ) } +#' Add duplicates back to DENTIST output +#' +#' This function takes the output from the DENTIST algorithm and adds back the +#' duplicated variants based on the output from the `findDuplicateVariants` +#' function. +#' @param zScore The original zScore +#' @param dentistOutput A data frame containing the output from the DENTIST +#' algorithm. +#' @param findDupOutput A list containing the output from the +#' `findDuplicateVariants` function. +#' +#' @return A data frame with duplicated variants added back and an additional +#' column indicating duplicates. +#' +#' @noRd addDupsBackDentist <- function(zScore, dentistOutput, findDupOutput) { dupBearer <- findDupOutput$dupBearer nrowsDup <- length(dupBearer) @@ -764,37 +823,6 @@ buildSegmentResult <- function( ) } -#' Sliding Window Loop for Genomic Segmentation -#' -#' Core overlapping-window loop shared by both distance-based and count-based -#' segmentation strategies. Iterates over contiguous blocks (separated by gaps), -#' creates overlapping windows within each block using mode-specific callbacks, -#' and assembles the result. -#' -#' @param allGaps Integer vector of 1-based block boundaries from -#' \code{\link{detectGaps}}. -#' @param n Total number of positions. -#' @param ctx Named list bundling the caller's mode-specific segmentation state; -#' passed as the final argument to every callback below (so they can be -#' top-level functions rather than closures). -#' @param minBlockFn Function(blockSize, ctx) -> logical; returns TRUE if the -#' block is large enough to process. -#' @param initEndFn Function(startIdx, blockEnd, ctx) -> integer; computes the -#' initial window end index for the first window in a block. -#' @param fillFn Function(startIdx, endIdx, notStartInterval, notLastInterval, -#' ctx) -> list(start, end); computes fill boundaries for each window. -#' @param stepFn Function(startIdx, blockEnd, ctx) -> list(startIdx, endIdx); -#' advances to the next window. -#' @param adjustLastFn Optional function(startIdx, oldStartIdx, endIdx, -#' blockEnd, ctx) -> integer; adjusts startIdx when the last interval is -#' detected. Used by distance mode for small-last-interval correction. Default -#' is NULL (no adjustment). -#' @param verbose Logical; print interval info. Default is FALSE. -#' -#' @return A data frame with columns: windowIdx, windowStartIdx, windowEndIdx, -#' fillStartIdx, fillEndIdx. -#' -#' @noRd # --- slidingWindowLoop helpers ---------------------------------------------- # Generate the window tuples for one block via the mode-specific callbacks in @@ -932,6 +960,37 @@ buildSegmentResult <- function( ) } +#' Sliding Window Loop for Genomic Segmentation +#' +#' Core overlapping-window loop shared by both distance-based and count-based +#' segmentation strategies. Iterates over contiguous blocks (separated by gaps), +#' creates overlapping windows within each block using mode-specific callbacks, +#' and assembles the result. +#' +#' @param allGaps Integer vector of 1-based block boundaries from +#' \code{\link{detectGaps}}. +#' @param n Total number of positions. +#' @param ctx Named list bundling the caller's mode-specific segmentation state; +#' passed as the final argument to every callback below (so they can be +#' top-level functions rather than closures). +#' @param minBlockFn Function(blockSize, ctx) -> logical; returns TRUE if the +#' block is large enough to process. +#' @param initEndFn Function(startIdx, blockEnd, ctx) -> integer; computes the +#' initial window end index for the first window in a block. +#' @param fillFn Function(startIdx, endIdx, notStartInterval, notLastInterval, +#' ctx) -> list(start, end); computes fill boundaries for each window. +#' @param stepFn Function(startIdx, blockEnd, ctx) -> list(startIdx, endIdx); +#' advances to the next window. +#' @param adjustLastFn Optional function(startIdx, oldStartIdx, endIdx, +#' blockEnd, ctx) -> integer; adjusts startIdx when the last interval is +#' detected. Used by distance mode for small-last-interval correction. Default +#' is NULL (no adjustment). +#' @param verbose Logical; print interval info. Default is FALSE. +#' +#' @return A data frame with columns: windowIdx, windowStartIdx, windowEndIdx, +#' fillStartIdx, fillEndIdx. +#' +#' @noRd slidingWindowLoop <- function( allGaps, n, @@ -974,9 +1033,6 @@ slidingWindowLoop <- function( ) } -# Apply the quarter-distance index map `quaterIdx` `n` times to `x` (n = 1..4 -# gives the 1st..4th quarter boundary from x). Used by segmentByDist. -# @noRd # One quarter-index hop; the step index is unused, `reduce` just applies it # `n` times. # @noRd @@ -984,53 +1040,17 @@ slidingWindowLoop <- function( quaterIdx[x] } +# Apply the quarter-distance index map `quaterIdx` `n` times to `x` (n = 1..4 +# gives the 1st..4th quarter boundary from x). Used by segmentByDist. +# @noRd .nthQuaterIdx <- function(x, n, quaterIdx) { reduce(seq_len(n), .nthQuaterStep, quaterIdx = quaterIdx, .init = x) } -#' Segment Genomic Region by Distance (Original DENTIST Algorithm) -#' -#' Implements the same windowing/segmentation algorithm as the original DENTIST -#' C++ binary's \code{segmentingByDist} function. Windows are created using -#' quarter-distance SNP index lookups, with gap detection for centromeres and -#' large gaps. -#' -#' @param pos Integer vector of base pair positions (must be sorted). -#' @param maxDist Maximum distance (bp) between SNPs for windowing. Default is -#' 2000000. -#' @param minDim Minimum number of SNPs per window. Default is 2000. -#' @param verbose Logical; print segmentation info. Default is FALSE. -#' -#' @return A data frame with columns: windowIdx, windowStartIdx, windowEndIdx, -#' fillStartIdx, fillEndIdx. Start indices are 1-based inclusive; end indices -#' (windowEndIdx, fillEndIdx) are 1-based exclusive (one past last element), -#' matching the C++ convention. Use \code{startIdx:(endIdx - 1)} for R -#' inclusive ranges. -#' -#' @details -#' This is a faithful R translation of the C++ \code{segmentingByDist} function. -#' The algorithm: -#' \enumerate{ -#' \item Precomputes for each SNP: the index of the farthest SNP within -#' \code{maxDist}, -#' and the index of the SNP at \code{maxDist/4} distance. -#' \item Detects gaps > \code{maxDist/4} in the position vector (e.g., -#' centromeres). -#' \item Creates overlapping windows that slide by half the distance cutoff, -#' with fill -#' regions covering the inner three-quarters of each window. -#' \item The first window's fill starts at the window start; the last -#' window's fill -#' ends at the window end. -#' } -#' -#' @seealso \code{\link{dentistSingleWindow}}, \code{\link{dentist}} -#' -#' @noRd # --- segmentByDist helpers -------------------------------------------------- -# For each SNP, the last SNP index within cutoff/4 distance (clamped to [1, n]). -# For each SNP, the index of the last SNP within a quarter of `cutoff`. +# For each SNP, the index of the last SNP within a quarter of `cutoff`, +# clamped to [1, n]. # # The C++ original walks a second pointer forward, which is the same thing as # counting how many positions fall strictly below each target -- that is @@ -1087,6 +1107,45 @@ slidingWindowLoop <- function( ) } +#' Segment Genomic Region by Distance (Original DENTIST Algorithm) +#' +#' Implements the same windowing/segmentation algorithm as the original DENTIST +#' C++ binary's \code{segmentingByDist} function. Windows are created using +#' quarter-distance SNP index lookups, with gap detection for centromeres and +#' large gaps. +#' +#' @param pos Integer vector of base pair positions (must be sorted). +#' @param maxDist Maximum distance (bp) between SNPs for windowing. Default is +#' 2000000. +#' @param minDim Minimum number of SNPs per window. Default is 2000. +#' @param verbose Logical; print segmentation info. Default is FALSE. +#' +#' @return A data frame with columns: windowIdx, windowStartIdx, windowEndIdx, +#' fillStartIdx, fillEndIdx. Start indices are 1-based inclusive; end indices +#' (windowEndIdx, fillEndIdx) are 1-based exclusive (one past last element), +#' matching the C++ convention. Use \code{startIdx:(endIdx - 1)} for R +#' inclusive ranges. +#' +#' @details +#' This is a faithful R translation of the C++ \code{segmentingByDist} function. +#' The algorithm: +#' \enumerate{ +#' \item Precomputes for each SNP: the index of the farthest SNP within +#' \code{maxDist}, +#' and the index of the SNP at \code{maxDist/4} distance. +#' \item Detects gaps > \code{maxDist/4} in the position vector (e.g., +#' centromeres). +#' \item Creates overlapping windows that slide by half the distance cutoff, +#' with fill +#' regions covering the inner three-quarters of each window. +#' \item The first window's fill starts at the window start; the last +#' window's fill +#' ends at the window end. +#' } +#' +#' @seealso \code{\link{dentistSingleWindow}}, \code{\link{dentist}} +#' +#' @noRd segmentByDist <- function( pos, maxDist = 2000000, @@ -1171,6 +1230,22 @@ segmentByCount <- function(pos, maxCount, gapDist = 1e6, verbose = FALSE) { ) } +# Window `k`'s rows, indexed globally and trimmed to that window's fill range. +# @noRd +.dentistMergeWindowAt <- function(k, dentistResultByWindow, windowDividedRes) { + imputedK <- dentistResultByWindow[[k]] + offset <- windowDividedRes$windowStartIdx[k] - 1 + imputedK |> + mutate( + index_within_window = seq_len(nrow(imputedK)), + index_global = .data$index_within_window + offset + ) |> + filter( + .data$index_global >= windowDividedRes$fillStartIdx[k] & + .data$index_global < windowDividedRes$fillEndIdx[k] + ) +} + #' Merge dentist Results by Window #' #' This function merges DENTIST results by window into a single data frame. @@ -1188,22 +1263,6 @@ segmentByCount <- function(pos, maxCount, gapDist = 1e6, verbose = FALSE) { #' within the fillers and combines them into a single data frame. #' #' @noRd -# Window `k`'s rows, indexed globally and trimmed to that window's fill range. -# @noRd -.dentistMergeWindowAt <- function(k, dentistResultByWindow, windowDividedRes) { - imputedK <- dentistResultByWindow[[k]] - offset <- windowDividedRes$windowStartIdx[k] - 1 - imputedK |> - mutate( - index_within_window = seq_len(nrow(imputedK)), - index_global = .data$index_within_window + offset - ) |> - filter( - .data$index_global >= windowDividedRes$fillStartIdx[k] & - .data$index_global < windowDividedRes$fillEndIdx[k] - ) -} - mergeWindows <- function(dentistResultByWindow, windowDividedRes) { if (length(dentistResultByWindow) != nrow(windowDividedRes)) { abort("Different number of windows and imputed results!") @@ -1253,12 +1312,22 @@ mergeWindows <- function(dentistResultByWindow, windowDividedRes) { # --- slalom helpers --------------------------------------------------------- -# Require exactly one of R (LD matrix) or X (genotype matrix). -# Lead-variant LD column. `R` has already been resolved from `X` where the -# caller gave genotypes, so there is one source here and `ldMethod` has -# already been applied. +# Lead-variant LD column. From genotypes under the sample estimator it is read +# off X's LD factor -- crossprod(F, F[, lead]) / (n - 1), computeLd()'s column +# exactly -- without forming the p x p matrix. The population and GCTA +# estimators treat missing calls their own way, so they still build it +# through resolveLdInput(), as dentist does. #' @importFrom checkmate assertMatrix -.slalomLeadR <- function(zScore, R, leadIdx) { +.slalomLeadR <- function(zScore, R, X, leadIdx, ldMethod) { + if (is.null(R) && identical(ldMethod, "sample")) { + factor <- .ldFactorFromDosage(as.matrix(X)) + assertMatrix(factor, ncols = length(zScore)) + lead <- crossprod(factor, factor[, leadIdx, drop = FALSE]) + # The lead's correlation with itself is 1 exactly, as on the + # matrix's unit diagonal, not 1 give or take rounding. + return(replace(drop(lead) / (nrow(factor) - 1), leadIdx, 1)) + } + R <- resolveLdInput(R = R, X = X, ldMethod = ldMethod)$R assertMatrix(R, nrows = length(zScore), ncols = length(zScore)) R[, leadIdx] } @@ -1326,12 +1395,15 @@ mergeWindows <- function(dentistResultByWindow, windowDividedRes) { #' p-values from z-scores assuming a two-sided standard normal distribution. #' #' Provide either an LD correlation matrix \code{R} or a genotype matrix -#' \code{X} (from which LD is derived automatically via \code{computeLd}). +#' \code{X}. SLALOM needs only the lead variant's LD with the others, so with +#' \code{ldMethod = "sample"} it computes that one column from the genotypes +#' and never forms the LD matrix. #' #' @param zScore Numeric vector of z-scores corresponding to each variant. #' @param R Square LD correlation matrix. Provide either \code{R} or \code{X}. -#' @param X Genotype matrix (samples x SNPs). If provided, LD is computed via -#' \code{computeLd(X)}. +#' @param X Genotype matrix (samples x SNPs). With \code{ldMethod = "sample"} +#' only the lead variant's LD column is computed from it; any other +#' \code{ldMethod} computes the LD matrix via \code{computeLd(X)}. #' @param standardError Optional numeric vector of standard errors corresponding #' to each z-score. If not provided, a default value of 1 is assumed for all #' variants. @@ -1344,9 +1416,9 @@ mergeWindows <- function(dentistResultByWindow, windowDividedRes) { #' @param leadVariantChoice Character, method to choose the lead variant, either #' "pvalue" or "abf", with default "pvalue". #' @param ldMethod Character string specifying the LD computation method when -#' \code{X} is provided. Passed to \code{computeLd}. One of \code{"sample"} -#' (default), \code{"population"}, or \code{"gcta"}. Ignored when \code{R} is -#' provided directly. +#' \code{X} is provided: \code{"sample"} (default), which uses the +#' genotypes directly, or \code{"population"} or \code{"gcta"}, which go +#' through \code{computeLd}. Ignored when \code{R} is provided directly. #' @return A list containing the annotated LD matrix with ABF results, credible #' sets, lead variant, and DENTIST-S statistics; and a summary dataframe with #' aggregate statistics. @@ -1373,13 +1445,7 @@ slalom <- function( leadVariantChoice = "pvalue", ldMethod = "sample" ) { - # Resolve the LD the same way dentist does, so `ldMethod` selects the - # estimator it advertises. This used to correlate the lead column of `X` - # with cor() directly, which skipped computeLd entirely: "population" - # and "gcta" were accepted and silently given sample LD. Building the - # full matrix is the cost of honouring the choice, and is what the - # sibling QC method already pays on the same input. - R <- resolveLdInput(R = R, X = X, ldMethod = ldMethod)$R + .ldRequireOneSource(R, X) # One-sided p-value matching the original Python (stats.norm.cdf): lead is # the most negative z-score when leadVariantChoice == "pvalue". pvalue <- pnorm(zScore) @@ -1396,7 +1462,7 @@ slalom <- function( } else { which.max(prob) } - rLead <- .slalomLeadR(zScore, R, leadIdx) + rLead <- .slalomLeadR(zScore, R, X, leadIdx, ldMethod) ds <- .slalomDentistS( zScore, rLead, @@ -1492,28 +1558,6 @@ autoDecision <- function(df, highCorrCols) { # RAISS: regression-based sumstats imputation # ============================================================================= -#' Core RAISS implementation for a single LD matrix -#' -#' @param refPanel A data frame containing 'chrom', 'pos', 'variant_id', 'A1', -#' and 'A2'. -#' @param knownZscores A data frame containing 'chrom', 'pos', 'variant_id', -#' 'A1', 'A2', and 'z' values. -#' @param ldMatrix A square matrix of dimension equal to the number of rows in -#' refPanel. -#' @param lamb Regularization term added to the diagonal of the ldMatrix. -#' @param rcond Threshold for filtering eigenvalues in the pseudo-inverse -#' computation. -#' @param r2Threshold R square threshold below which SNPs are filtered from the -#' output. -#' @param minimumLd Minimum LD score threshold for SNP filtering. -#' @param verbose Logical indicating whether to print progress information. -#' -#' @return A list containing filtered and unfiltered results, and filtered LD -#' matrix. -#' @importFrom MASS ginv -#' @importFrom dplyr arrange -#' @noRd -# Drop LD-matrix rows/cols for variants filtered out of the imputation result. # Panel rows that are unsafe to impute, over and above being already known. # # Both cases come from a reference panel that carries a variant and its own @@ -1614,15 +1658,18 @@ autoDecision <- function(df, highCorrCols) { if (is.null(refPanel$chrom) || is.null(knownZ$chrom) || n == 0L) { return(rep(FALSE, n)) } - key <- function(chrom, pos) { - str_c(canonChrom(as.character(chrom)), ":", as.character(pos)) - } is_in( - key(refPanel$chrom, refPanel$pos), - key(knownZ$chrom, knownZ$pos) + .raissPositionKey(refPanel$chrom, refPanel$pos), + .raissPositionKey(knownZ$chrom, knownZ$pos) ) } +# Canonical "chrom:pos" keys, so a "chr1"/"1" difference is one site. +# @noRd +.raissPositionKey <- function(chrom, pos) { + str_c(canonChrom(as.character(chrom)), ":", as.character(pos)) +} + # Imputation targets: panel rows the sumstats do not carry, minus the rows no # imputed value could be trusted for and the rows sitting at a position the # GWAS already typed. @@ -1634,6 +1681,8 @@ autoDecision <- function(df, highCorrCols) { which(candidate & !unsafe & !observed) } +# Drop LD-matrix rows/cols for variants filtered out of the imputation result. +# @noRd .raissFilterLd <- function(ldMatrix, refPanel, resultFilter) { filteredOutVariant <- setdiff(refPanel$variant_id, resultFilter$variant_id) if (length(filteredOutVariant) > 0) { @@ -1644,6 +1693,27 @@ autoDecision <- function(df, highCorrCols) { } } +#' Core RAISS implementation for a single LD matrix +#' +#' @param refPanel A data frame containing 'chrom', 'pos', 'variant_id', 'A1', +#' and 'A2'. +#' @param knownZscores A data frame containing 'chrom', 'pos', 'variant_id', +#' 'A1', 'A2', and 'z' values. +#' @param ldMatrix A square matrix of dimension equal to the number of rows in +#' refPanel. +#' @param lamb Regularization term added to the diagonal of the ldMatrix. +#' @param rcond Threshold for filtering eigenvalues in the pseudo-inverse +#' computation. +#' @param r2Threshold R square threshold below which SNPs are filtered from the +#' output. +#' @param minimumLd Minimum LD score threshold for SNP filtering. +#' @param verbose Logical indicating whether to print progress information. +#' +#' @return A list containing filtered and unfiltered results, and filtered LD +#' matrix. +#' @importFrom MASS ginv +#' @importFrom dplyr arrange +#' @noRd raissSingleMatrix <- function( refPanel, knownZscores, @@ -1684,33 +1754,6 @@ raissSingleMatrix <- function( ) } -#' Core RAISS implementation from a genotype matrix X (SVD-based) -#' -#' Performs the same imputation as \code{raissSingleMatrix} but works directly -#' with the genotype matrix X instead of the LD correlation matrix R. This -#' avoids forming the p x p LD matrix, saving O(p^2) memory and O(np^2) compute. -#' -#' The reformulation is mathematically exact: using the thin SVD of Xt (the -#' known variant columns), all RAISS quantities (mu, var, ld_score) are computed -#' in the SVD basis without ever forming R = X'X/(n-1). -#' -#' @param refPanel A data frame containing 'chrom', 'pos', 'variant_id', 'A1', -#' and 'A2'. -#' @param knownZscores A data frame containing 'chrom', 'pos', 'variant_id', -#' 'A1', 'A2', and 'z' values. -#' @param X Centered and scaled genotype matrix (nSamples x pVariants). Column -#' order must match the variant order in refPanel. -#' @param lamb Regularization term (same role as in the LD-based path). -#' @param svdTol Relative tolerance for filtering small singular values in the -#' SVD of Xt. -#' @param r2Threshold R square threshold below which SNPs are filtered from the -#' output. -#' @param minimumLd Minimum LD score threshold for SNP filtering. -#' @param verbose Logical indicating whether to print progress information. -#' -#' @return A list containing filtered and unfiltered results, and ldMat = NULL. -#' @importFrom dplyr arrange -#' @noRd # --- raissSingleMatrixFromX helpers ---------------------------------------- # Early-return cases: no known variants (NULL) or nothing to impute (knowns). @@ -1745,7 +1788,24 @@ raissSingleMatrix <- function( # SVD-based imputation from the genotype matrix (avoids forming R). Computes # X' %*% [w | U] in a single BLAS call to skip an O(n*m) copy of X_unknown. -.raissSvdImpute <- function(X, knowns, unknowns, zt, lamb, svdTol, nSamples) { +# +# The LD route pseudo-inverts the ridged LD of the known variants with +# MASS::ginv(tol = rcond), which drops every eigen-direction whose eigenvalue +# is below `rcond` times the largest. Here those eigenvalues are +# (d^2 + cReg) / (nSamples - 1), so the same directions are dropped and the +# two routes impute identically. Directions outside the genotypes' span carry +# no LD with the variants being imputed, so they change neither route. The LD +# score inverts nothing and keeps every direction. +.raissSvdImpute <- function( + X, + knowns, + unknowns, + zt, + lamb, + rcond, + svdTol, + nSamples +) { # Thin SVD of the known columns (n x k -> U: n x r, d: r, V: k x r). Xt <- X[, knowns, drop = FALSE] svdResult <- .safeSvd(Xt, tol = svdTol) @@ -1756,9 +1816,11 @@ raissSingleMatrix <- function( cReg <- lamb * (nSamples - 1) d2 <- d^2 d2PlusC <- d2 + cReg - # w = U %*% diag(d / (d^2 + c)) %*% V' zt (projection of zt through SVD). + inverted <- d2PlusC > rcond * d2PlusC[[1L]] + # w = U %*% diag(d / (d^2 + c)) %*% V' zt (projection of zt through SVD), + # over the directions the pseudo-inverse keeps. VtZt <- crossprod(V, zt) - w <- U %*% (d / d2PlusC * VtZt) + w <- U %*% (inverted * d / d2PlusC * VtZt) # Single dgemm X' %*% [w | U]: col 1 (rows unknowns) -> mu; rest -> A. XtWU <- crossprod(X, cbind(w, U)) muRaw <- as.numeric(XtWU[unknowns, 1]) @@ -1767,33 +1829,59 @@ raissSingleMatrix <- function( # Variance and LD score in one pass over A^2. ASq <- A^2 rm(A) - dWeights <- cbind(d2 / d2PlusC, d2) + dWeights <- cbind(inverted * d2 / d2PlusC, d2) scores <- ASq %*% dWeights rm(ASq) nm1 <- nSamples - 1 varRaw <- (1 + lamb) - scores[, 1] / nm1 raissLdScore <- scores[, 2] / nm1^2 rm(scores) - conditionNumber <- rep(d[1] / d[length(d)], length(unknowns)) - correctInversion <- rep(TRUE, length(unknowns)) - # R2 correction (same as raissModel). - varNorm <- varInBoundaries(varRaw, lamb) - R2 <- (1 + lamb) - varNorm - mu <- muRaw / sqrt(R2) - list( - var = varNorm, - mu = mu, + .raissResult( + varRaw = varRaw, + muRaw = muRaw, + lamb = lamb, raissLdScore = raissLdScore, - conditionNumber = conditionNumber, - correctInversion = correctInversion + conditionNumber = rep(d[1] / d[length(d)], length(unknowns)), + correctInversion = rep(TRUE, length(unknowns)) ) } +#' Core RAISS implementation from a genotype matrix X (SVD-based) +#' +#' Performs the same imputation as \code{raissSingleMatrix} but works directly +#' with the genotype matrix X instead of the LD correlation matrix R. This +#' avoids forming the p x p LD matrix, saving O(p^2) memory and O(np^2) compute. +#' +#' The reformulation is mathematically exact: using the thin SVD of Xt (the +#' known variant columns), all RAISS quantities (mu, var, ld_score) are computed +#' in the SVD basis without ever forming R = X'X/(n-1). +#' +#' @param refPanel A data frame containing 'chrom', 'pos', 'variant_id', 'A1', +#' and 'A2'. +#' @param knownZscores A data frame containing 'chrom', 'pos', 'variant_id', +#' 'A1', 'A2', and 'z' values. +#' @param X Centered and scaled genotype matrix (nSamples x pVariants). Column +#' order must match the variant order in refPanel. +#' @param lamb Regularization term (same role as in the LD-based path). +#' @param rcond Eigenvalue cutoff for the pseudo-inverse, as on the LD-based +#' path: directions whose ridged eigenvalue is below \code{rcond} times the +#' largest are dropped. +#' @param svdTol Relative tolerance below which singular values of Xt are +#' treated as numerically zero. +#' @param r2Threshold R square threshold below which SNPs are filtered from the +#' output. +#' @param minimumLd Minimum LD score threshold for SNP filtering. +#' @param verbose Logical indicating whether to print progress information. +#' +#' @return A list containing filtered and unfiltered results, and ldMat = NULL. +#' @importFrom dplyr arrange +#' @noRd raissSingleMatrixFromX <- function( refPanel, knownZscores, X, lamb = 0.01, + rcond = 0.01, svdTol = 1e-8, r2Threshold = 0.6, minimumLd = 5, @@ -1814,9 +1902,10 @@ raissSingleMatrixFromX <- function( knowns, unknowns, knownZscores$z, - lamb, - svdTol, - nrow(X) + lamb = lamb, + rcond = rcond, + svdTol = svdTol, + nSamples = nrow(X) ) results <- formatRaissDf(imp, refPanel, unknowns) |> filterRaissOutput(r2Threshold, minimumLd, verbose) @@ -1831,255 +1920,34 @@ raissSingleMatrixFromX <- function( ) } -# Sequentially append RAISS block results, resolving the shared boundary variant -# (duplicated across adjacent blocks) by keeping the higher-R2 imputation. -# @noRd -.combineWithBoundaryCheck <- function(combinedResult, newResult) { - # If either is empty, simply return the non-empty one or empty data frame - if (is.null(combinedResult)) { - return(newResult) - } - if (is.null(newResult)) { - return(combinedResult) - } - - # Check if the last variant of combined matches the first of new - lastVar <- combinedResult$variant_id[nrow(combinedResult)] - firstVar <- newResult$variant_id[1] - - if (lastVar != firstVar) { - # No overlap - combine all rows - return(bind_rows(combinedResult, newResult)) - } - # The shared boundary variant is kept from whichever side imputed it - # better; two NAs, a tie, or an NA on the new side keep the existing row. - newR2 <- newResult$raissR2[1] - oldR2 <- combinedResult$raissR2[nrow(combinedResult)] - preferNew <- !is.na(newR2) && (is.na(oldR2) || newR2 > oldR2) - resolved <- if (preferNew) { - bind_rows(combinedResult[-nrow(combinedResult), ], newResult[1, ]) - } else { - combinedResult - } - # Every row of `newResult` past the boundary variant is new. - bind_rows(resolved, newResult[-1, ]) -} - -# --- raiss: genotype-matrix and LD-matrix path helpers --------------------- +# --- raiss: the genotype and LD-matrix routes -------------------------------- -# List of genotype-matrix blocks: impute each via SVD, then row-bind. -# One genotype block's imputation, or NULL when the block yields nothing. +# The genotype route: SVD-based imputation from a standardized genotype +# matrix, which never forms the p x p LD matrix. # @noRd -.raissGenotypeBlockAt <- function( - i, - refPanel, - knownZscores, - genotypeMatrix, - p -) { - if (p$verbose) { - nBlocks <- length(genotypeMatrix) - msg <- glue("Processing block {i} of {nBlocks}") - inform(msg) - } - raissSingleMatrixFromX( - refPanel, - knownZscores, - genotypeMatrix[[i]], - p$lamb, - p$svdTol, - p$r2Threshold, - p$minimumLd, - verbose = FALSE - ) -} - -.raissGenotypeBlocks <- function(refPanel, knownZscores, genotypeMatrix, p) { - if (p$verbose) { - msg <- glue( - "Processing multiple genotype matrix blocks via SVD-based ", - "imputation..." - ) - inform(msg) - } - resultsList <- compact(map( - seq_along(genotypeMatrix), - .raissGenotypeBlockAt, - refPanel = refPanel, - knownZscores = knownZscores, - genotypeMatrix = genotypeMatrix, - p = p - )) - if (length(resultsList) == 0) { - if (p$verbose) { - inform("No blocks could be processed.") - } - return(NULL) - } - combinedNofilter <- bind_rows(map(resultsList, "resultNofilter")) - combinedFilter <- bind_rows(map(resultsList, "resultFilter")) - list( - resultNofilter = combinedNofilter |> arrange(.data$pos), - resultFilter = combinedFilter |> arrange(.data$pos), - ldMat = NULL - ) -} - -# Genotype-matrix imputation path: single matrix, list of blocks, or error. .raissGenotypePath <- function(refPanel, knownZscores, genotypeMatrix, p) { - if (is.matrix(genotypeMatrix)) { - if (p$verbose) { - inform("Processing genotype matrix via SVD-based imputation...") - } - return(raissSingleMatrixFromX( - refPanel, - knownZscores, - genotypeMatrix, - p$lamb, - p$svdTol, - p$r2Threshold, - p$minimumLd, - p$verbose - )) - } - if (is.list(genotypeMatrix)) { - return(.raissGenotypeBlocks(refPanel, knownZscores, genotypeMatrix, p)) - } - abort("genotypeMatrix must be a matrix or a list of matrices.") -} - -# Impute one LD block against its reference-panel subset. -.raissLdBlockOne <- function( - refPanel, - knownZscores, - ldMatrix, - variantIndices, - blockId, - p -) { - blockVariantIds <- variantIndices$variant_id[ - variantIndices$blockId == blockId - ] - blockIndices <- match(blockVariantIds, refPanel$variant_id) - blockRefPanel <- refPanel[blockIndices, ] - blockLdMatrix <- ldMatrix$ldMatrices[[blockId]] - blockKnownZscores <- knownZscores |> - filter(is_in(.data$variant_id, blockVariantIds)) - if (nrow(blockLdMatrix) != nrow(blockRefPanel)) { - msg <- glue( - "Block {blockId} : LD matrix dimension does not match number ", - "of variants in reference panel" - ) - abort(msg) - } - raissSingleMatrix( - blockRefPanel, - blockKnownZscores, - blockLdMatrix, - p$lamb, - p$rcond, - p$r2Threshold, - p$minimumLd, - verbose = FALSE - ) -} - -# Combine per-block imputation results (boundary-dedup) + rebuild LD matrix. -.raissLdBlocksCombine <- function(resultsList) { - combinedNofilter <- reduce( - map(resultsList, "resultNofilter"), - .combineWithBoundaryCheck - ) - combinedFilter <- reduce( - map(resultsList, "resultFilter"), - .combineWithBoundaryCheck - ) - ldFilteredList <- map(resultsList, "ldMat") - variantList <- map(ldFilteredList, .ldVariantsDf) - ldMatrix <- createLdMatrix( - ldMatrices = ldFilteredList, - variants = variantList - ) - list( - resultNofilter = combinedNofilter, - resultFilter = combinedFilter, - ldMat = ldMatrix - ) -} - -# LD-block imputation path: impute each block then combine. -# One LD block's imputation, or NULL when the block yields nothing. -# @noRd -.raissLdBlockAt <- function( - blockId, - refPanel, - knownZscores, - ldMatrix, - variantIndices, - blockIds, - p -) { if (p$verbose) { - nBlocks <- length(blockIds) - msg <- glue("Processing block {blockId} of {nBlocks}") - inform(msg) + inform("Processing genotype matrix via SVD-based imputation...") } - .raissLdBlockOne( + raissSingleMatrixFromX( refPanel, knownZscores, - ldMatrix, - variantIndices, - blockId, - p + genotypeMatrix, + lamb = p$lamb, + rcond = p$rcond, + svdTol = p$svdTol, + r2Threshold = p$r2Threshold, + minimumLd = p$minimumLd, + verbose = p$verbose ) } -.raissLdBlocksPath <- function(refPanel, knownZscores, ldMatrix, p) { - if (p$verbose) { - inform("Processing multiple LD blocks...") - } - variantIndices <- ldMatrix$variantIndices - blockIds <- unique(variantIndices$blockId) - perBlock <- map( - blockIds, - .raissLdBlockAt, - refPanel = refPanel, - knownZscores = knownZscores, - ldMatrix = ldMatrix, - variantIndices = variantIndices, - blockIds = blockIds, - p = p - ) - # `resultsList[[blockId]] <- ...` named the entries only when blockIds are - # character, so keep that distinction rather than inventing names. - blockResults <- if (is.character(blockIds)) { - set_names(perBlock, blockIds) - } else { - perBlock - } - resultsList <- compact(blockResults) - if (length(resultsList) == 0) { - if (p$verbose) { - msg <- glue( - "No blocks could be processed. Check that knownZscores ", - "overlap with variants in the blocks." - ) - inform(msg) - } - return(NULL) - } - .raissLdBlocksCombine(resultsList) -} - -# Single LD-matrix imputation path (extracts matrix from a 1-block list). -.raissSingleLdPath <- function(refPanel, knownZscores, ldMatrix, p) { +# The LD-matrix route: imputation from the correlation matrix of refPanel's +# variants. +# @noRd +.raissLdPath <- function(refPanel, knownZscores, ldMatrix, p) { if (p$verbose) { - fromList <- if (!is.matrix(ldMatrix)) " from list" else "" - msg <- glue("Processing single LD matrix{fromList}...") - inform(msg) - } - if (!is.matrix(ldMatrix)) { - ldMatrix <- ldMatrix$ldMatrices[[1]] + inform("Processing LD matrix...") } raissSingleMatrix( refPanel, @@ -2093,6 +1961,65 @@ raissSingleMatrixFromX <- function( ) } +# The LD reference a raiss() call names, if any: an LdMatrix passed as +# `ldMatrix`, or the genotype panel (or mixture of panels) passed as +# `genotypes`. Genotypes are taken only that way, never as a bare matrix: +# centring, scaling, column order and allele coding are all the caller's to get +# right in a bare matrix, and every one of them fails silently. A reference +# passed through the other argument is refused rather than read the wrong way. +# @noRd +.raissReferenceOf <- function(ldMatrix, genotypes) { + if (.ldIsGenotypeRef(ldMatrix)) { + abort("Pass genotypes as `genotypes`, not `ldMatrix`.") + } + if (!is.null(genotypes) && !.ldIsGenotypeRef(genotypes)) { + abort(c( + "`genotypes` must be a genotype panel or a GenotypeMixture.", + i = "Read one with readGenotypes(), or pass LD as `ldMatrix`." + )) + } + if (.ldIsMatrixRef(ldMatrix) || !is.null(genotypes)) { + return(ldMatrix %||% genotypes) + } + if (!is.null(ldMatrix) && !is.matrix(ldMatrix)) { + abort("`ldMatrix` must be a square LD matrix or an LdMatrix.") + } + NULL +} + +# An LD reference brings its own variant table, which refPanel defaults to. +# Known and imputed rows are merged on chrom, and the table labels +# chromosomes canonically ("22"), so knownZscores has to as well; say so here +# rather than in a failed join. +# @noRd +.raissRefPanelOf <- function(ref, knownZscores) { + panel <- .refVariantsFromLdRef(ref) + sameLabels <- is.character(knownZscores$chrom) && + any(is_in(knownZscores$chrom, panel$chrom)) + if (!sameLabels) { + abort(c( + str_c( + "`knownZscores$chrom` must use the LD reference's chromosome ", + "labels." + ), + i = glue( + "They are canonical character labels, like ", + "'{panel$chrom[[1L]]}'." + ) + )) + } + panel +} + +# The genotypes' LD factor for refPanel's variants (see .ldRefFactor()), the +# way summaryStatsQc() hands it to the SVD route, re-signed into refPanel's +# allele coding. +# @noRd +.raissScaledDosage <- function(genotypes, refPanel) { + m <- .ldFromRefMatch(genotypes, refPanel$variant_id, "raiss", "error") + sweep(.ldRefFactor(genotypes, m$idx), 2L, m$sign, `*`) +} + #' Impute Summary Statistics Using LD (RAISS) #' #' An R port of the RAISS summary-statistic imputation library, described in @@ -2105,34 +2032,43 @@ raissSingleMatrixFromX <- function( #' statistics enhances evidence of functional enrichment", Bioinformatics #' 30(20):2906-2914. \doi{10.1093/bioinformatics/btu416} #' -#' This function can process either a single LD matrix or a list of LD matrices -#' for different blocks. For a list of matrices, it processes each block -#' separately and combines the results. Alternatively, it can accept a genotype -#' matrix X directly, avoiding the need to form the p x p LD matrix (memory and +#' One call imputes one region, from either of the two kinds of LD reference. +#' The LD can be given as a square correlation matrix or an +#' \code{\link{LdMatrix}}, and the imputation then inverts it. Or a genotype +#' panel from \code{\link{readGenotypes}} can be given instead, and the +#' imputation then works from the singular value decomposition of its +#' standardized dosages, never forming the p x p LD matrix (memory and #' compute savings when n << p). #' #' @param refPanel A data frame containing 'chrom', 'pos', 'variant_id', 'A1', -#' and 'A2'. +#' and 'A2'. Optional when the LD comes as an \code{LdMatrix} or a genotype +#' panel, whose own variants are used; \code{knownZscores} must then label +#' chromosomes canonically, as character (e.g. \code{"22"}). Required +#' with a plain \code{ldMatrix}, whose rows and columns follow it. #' @param knownZscores A data frame containing 'chrom', 'pos', 'variant_id', #' 'A1', 'A2', and 'z' values. -#' @param ldMatrix Either a square matrix or a list of matrices for LD blocks. -#' Provide either \code{ldMatrix} or \code{genotypeMatrix}, not both. -#' @param genotypeMatrix A centered and scaled genotype matrix (n x p) as an -#' alternative to \code{ldMatrix}. Column order must match the variant order -#' in \code{refPanel}. When provided, the imputation uses an SVD-based -#' approach that avoids forming the p x p LD matrix. +#' @param ldMatrix A square LD matrix over \code{refPanel}'s variants, in its +#' order, or an \code{LdMatrix} covering them. Provide either +#' \code{ldMatrix} or \code{genotypes}, not both. +#' @param genotypes A genotype panel (see \code{\link{readGenotypes}}) or a +#' \code{\link{GenotypeMixture}} covering the variants, as an alternative +#' to \code{ldMatrix}. Its dosages are matched to \code{refPanel} by +#' variant and allele, mean-imputed and standardized here. #' @param lamb Regularization term added to the diagonal of the ldMatrix. -#' @param rcond Threshold for filtering eigenvalues in the pseudo-inverse -#' computation (only used with ldMatrix path). -#' @param svdTol Relative tolerance for filtering small singular values (only -#' used with genotypeMatrix path). +#' @param rcond Eigenvalue cutoff for the pseudo-inverse of the known +#' variants' LD: directions whose ridged eigenvalue is below \code{rcond} +#' times the largest are dropped. Applied on both routes, so a genotype +#' panel and the LD matrix computed from it give the same imputation. +#' @param svdTol Relative tolerance below which singular values of the +#' standardized genotypes are treated as numerically zero (genotype route +#' only). #' @param r2Threshold R square threshold below which SNPs are filtered from the #' output. #' @param minimumLd Minimum LD score threshold for SNP filtering. #' @param verbose Logical indicating whether to print progress information. #' #' @return A list containing filtered and unfiltered results, and filtered LD -#' matrix (ldMat is NULL when using genotypeMatrix path). +#' matrix (ldMat is NULL on the genotype route). #' @importFrom dplyr arrange bind_rows #' @examples #' data(eqtlRegionExample) @@ -2146,10 +2082,10 @@ raissSingleMatrixFromX <- function( #' ldMatrix = cor(X)) #' @export raiss <- function( - refPanel, + refPanel = NULL, knownZscores, ldMatrix = NULL, - genotypeMatrix = NULL, + genotypes = NULL, lamb = 0.01, rcond = 0.01, svdTol = 1e-8, @@ -2165,23 +2101,31 @@ raiss <- function( minimumLd = minimumLd, verbose = verbose ) - if (!is.null(genotypeMatrix)) { - if (!is.null(ldMatrix)) { - abort("Provide either ldMatrix or genotypeMatrix, not both.") - } - return(.raissGenotypePath(refPanel, knownZscores, genotypeMatrix, p)) + if (!is.null(genotypes) && !is.null(ldMatrix)) { + abort("Provide either ldMatrix or genotypes, not both.") + } + if (is.null(genotypes) && is.null(ldMatrix)) { + abort("Provide either ldMatrix or genotypes.") + } + ref <- .raissReferenceOf(ldMatrix, genotypes) + if (!is.null(ref)) { + refPanel <- refPanel %||% .raissRefPanelOf(ref, knownZscores) + } else if (is.null(refPanel)) { + abort(str_c( + "`refPanel` is required unless the LD comes as an LdMatrix or a ", + "genotype panel." + )) } - if (is.null(ldMatrix)) { - abort("Provide either ldMatrix or genotypeMatrix.") + if (!is.null(genotypes)) { + X <- .raissScaledDosage(genotypes, refPanel) + return(.raissGenotypePath(refPanel, knownZscores, X, p)) } - isSingleMatrixCase <- is.matrix(ldMatrix) || - (is.list(ldMatrix) && - !is.null(ldMatrix$ldMatrices) && - length(ldMatrix$ldMatrices) == 1) - if (isSingleMatrixCase) { - return(.raissSingleLdPath(refPanel, knownZscores, ldMatrix, p)) + R <- if (is.null(ref)) { + ldMatrix + } else { + .ldFromRef(ref, refPanel$variant_id, label = "raiss") } - .raissLdBlocksPath(refPanel, knownZscores, ldMatrix, p) + .raissLdPath(refPanel, knownZscores, R, p) } #' @rdname RaissParam @@ -2192,6 +2136,7 @@ setClass( contains = "MethodParam", slots = c( lamb = "numeric", + rcond = "numeric", svdTol = "numeric", r2Threshold = "numeric", minimumLd = "numeric", @@ -2204,20 +2149,25 @@ setClass( #' @title Arguments For RAISS Imputation During Summary-Statistic QC #' @description The settings \code{\link{summaryStatsQc}} uses when -#' \code{impute = TRUE}. Four are forwarded to \code{\link{raiss}}; the +#' \code{impute = TRUE}. Five are forwarded to \code{\link{raiss}}; the #' other four are pecotmr's own, bounding which panel variants RAISS is #' asked to impute and how wide a window it reads. #' -#' \code{\link{raiss}} also takes an \code{rcond}, but only on its -#' LD-matrix path. QC always hands it a genotype matrix, which routes -#' through the SVD solver and uses \code{svdTol} instead, so \code{rcond} -#' is not offered here --- naming it is an error rather than a setting that -#' silently does nothing. +#' \code{rcond} applies whatever the collection's LD reference is: QC hands +#' RAISS a genotype panel's dosages, which route through the SVD solver, or +#' an \code{\link{LdMatrix}}'s correlations, which are inverted directly, +#' and both drop the same weak directions. \code{svdTol} only matters on +#' the genotype route. #' @param lamb Regularization term added to the LD diagonal. Default #' \code{0.01}. -#' @param svdTol Singular-value cutoff for the pseudo-inverse. Default -#' \code{1e-12}. Note this is tighter than \code{\link{raiss}}'s own -#' \code{1e-8} default. +#' @param rcond Eigenvalue cutoff for the pseudo-inverse of the known +#' variants' LD: directions whose ridged eigenvalue is below \code{rcond} +#' times the largest are dropped. Default \code{0.01}, as +#' \code{\link{raiss}}'s own. +#' @param svdTol Relative tolerance below which singular values of the +#' standardized genotypes are treated as numerically zero, used when the LD +#' reference is a genotype panel. Default \code{1e-12}. Note this is +#' tighter than \code{\link{raiss}}'s own \code{1e-8} default. #' @param r2Threshold Imputation \eqn{R^2} below which a variant is dropped #' from the output. Default \code{0.6}. #' @param minimumLd Minimum LD score for retaining an imputed variant. @@ -2236,6 +2186,7 @@ setClass( #' @export RaissParam <- function( lamb = 0.01, + rcond = 0.01, svdTol = 1e-12, r2Threshold = 0.6, minimumLd = 5, @@ -2247,6 +2198,7 @@ RaissParam <- function( new( "RaissParam", lamb = lamb, + rcond = rcond, svdTol = svdTol, r2Threshold = r2Threshold, minimumLd = minimumLd, @@ -2258,15 +2210,15 @@ RaissParam <- function( } # The RAISS bundle as a plain list with every field present. A constructor -# result already carries all eight -- they are all formals with defaults -- +# result already carries all nine -- they are all formals with defaults -- # and the empty list that means "no options" becomes the defaults outright, # so the read sites need no per-field fallback. # @noRd -.ssqcResolveImputeArgs <- function(imputeArgs) { - if (length(imputeArgs) == 0L) { +.ssqcResolveImputeArgs <- function(raissParam) { + if (length(raissParam) == 0L) { return(as.list(RaissParam())) } - as.list(imputeArgs) + as.list(raissParam) } #' @importFrom checkmate assertNumeric @@ -2296,39 +2248,73 @@ raissModel <- function( assertNumeric(zt) assertNumeric(sigT) assertNumeric(sigIT) - if (batch) { - conditionNumber <- if (reportConditionNumber) { - rep(kappa(sigT, exact = TRUE, norm = "2"), nrow(sigIT)) - } else { - NA - } - correctInversion <- rep(checkInversion(sigT, sigTInv), nrow(sigIT)) - } else { - conditionNumber <- if (reportConditionNumber) { - kappa(sigT, exact = TRUE, norm = "2") - } else { - NA - } - correctInversion <- checkInversion(sigT, sigTInv) - } - + checks <- .raissInversionChecks( + sigT, + sigTInv, + lamb, + nOut = if (batch) nrow(sigIT) else 1L, + reportConditionNumber = reportConditionNumber + ) varRaissLdScore <- computeVar(sigIT, sigTInv, lamb, batch) - var <- varRaissLdScore$var - raissLdScore <- varRaissLdScore$raissLdScore - - mu <- computeMu(sigIT, sigTInv, zt) - varNorm <- varInBoundaries(var, lamb) + .raissResult( + varRaw = varRaissLdScore$var, + muRaw = computeMu(sigIT, sigTInv, zt), + lamb = lamb, + raissLdScore = varRaissLdScore$raissLdScore, + conditionNumber = checks$conditionNumber, + correctInversion = checks$correctInversion + ) +} - R2 <- ((1 + lamb) - varNorm) - mu <- mu / sqrt(R2) +# The inversion's diagnostics, repeated for each of the `nOut` variants a +# batch imputes: sigT's condition number when asked for (NA otherwise), and +# whether sigTInv inverts what was inverted. That is the ridged matrix +# (diagonal 1 + lamb), so it is what the inverse is checked against; against +# the raw sigT the check could only fail, off by O(lamb). The original RAiSS +# implementation checks the ridged matrix too: its fill_diagonal() writes the +# ridge into sig_t in place. +# @noRd +.raissInversionChecks <- function( + sigT, + sigTInv, + lamb, + nOut, + reportConditionNumber +) { + conditionNumber <- if (reportConditionNumber) { + rep(kappa(sigT, exact = TRUE, norm = "2"), nOut) + } else { + NA + } + sigTRidged <- `diag<-`(sigT, 1 + lamb) + list( + conditionNumber = conditionNumber, + correctInversion = rep(checkInversion(sigTRidged, sigTInv), nOut) + ) +} - return(list( +# An imputation's result from its raw variances and means, as both RAiSS +# routes (raissModel(), .raissSvdImpute()) report it: the variances bounded +# by varInBoundaries(), and each mean scaled by sqrt(R2), with R2 = (1 + lamb) +# minus that variance. +# @noRd +.raissResult <- function( + varRaw, + muRaw, + lamb, + raissLdScore, + conditionNumber, + correctInversion +) { + varNorm <- varInBoundaries(varRaw, lamb) + R2 <- (1 + lamb) - varNorm + list( var = varNorm, - mu = mu, + mu = muRaw / sqrt(R2), raissLdScore = raissLdScore, conditionNumber = conditionNumber, correctInversion = correctInversion - )) + ) } #' @param imp is the output of raissModel() @@ -2502,8 +2488,10 @@ computeVar <- function(sigIT, sigTInv, lamb, batch = TRUE) { return(list(var = var, raissLdScore = raissLdScore)) } +# TRUE when sigTInv is a pseudo-inverse of sigT (sigT sigTInv sigT == sigT), +# else FALSE -- never all.equal()'s text describing the difference. checkInversion <- function(sigT, sigTInv) { - return(all.equal(sigT, sigT %*% (sigTInv %*% sigT), tolerance = 1e-5)) + isTRUE(all.equal(sigT, sigT %*% (sigTInv %*% sigT), tolerance = 1e-5)) } varInBoundaries <- function(var, lamb) { @@ -2546,31 +2534,6 @@ invertMatRecursive <- function(mat, lamb, rcond) { ) } -invertMatEigen <- function(mat, tol = 1e-3) { - eigenMat <- eigen(mat) - L <- which(cumsum(eigenMat$values) / sum(eigenMat$values) > 1 - tol)[1] - if (is.na(L)) { - # all eigen values are extremely small - msg <- glue( - "Cannot invert the input matrix because all its eigen ", - "values are negative or close to zero" - ) - abort(msg) - } - # Both guards matter when L == 1: the subscript would drop to a vector, - # and diag() of a length-one value returns an identity matrix of THAT - # ORDER -- diag(0.1) is 0x0 -- not a 1x1 matrix holding the value, so - # the product failed with "non-conformable arguments". - kept <- seq_len(L) - vectors <- eigenMat$vectors[, kept, drop = FALSE] - matInv <- vectors %*% - diag(1 / eigenMat$values[kept], nrow = L) %*% - t(vectors) - - return(matInv) -} - - # ============================================================================= # Top-level summaryStatsQc() pipeline + helpers # ============================================================================= @@ -2729,8 +2692,10 @@ DentistParam <- function( #' #' @param zScore Numeric vector of z-scores. #' @param R Square LD correlation matrix. Provide either \code{R} or \code{X}. -#' @param X Genotype matrix (samples x SNPs). If provided, LD is computed via -#' \code{computeLd} and \code{nSample} defaults to \code{nrow(X)}. +#' @param X Genotype matrix (samples x SNPs). With \code{ldMethod = "sample"} +#' both methods work on the genotypes without forming the LD matrix; any +#' other \code{ldMethod} computes LD via \code{computeLd}. \code{nSample} +#' defaults to \code{nrow(X)}. #' @param nSample Number of samples in the LD reference panel. Required when #' \code{R} is provided and \code{method = "dentist"}; inferred from \code{X} #' when \code{X} is provided. @@ -2771,7 +2736,7 @@ ldMismatchQc <- function( names(.ldMismatchCtors()), "method" ) - methodArgs <- chosen$args + engineParam <- chosen$args if (chosen$engine == "dentist") { callArgs <- list_modify( list( @@ -2781,13 +2746,13 @@ ldMismatchQc <- function( nSample = nSample, ldMethod = ldMethod ), - !!!methodArgs + !!!engineParam ) return(exec(dentistSingleWindow, !!!callArgs)) } else { callArgs <- list_modify( list(zScore, R = R, X = X, ldMethod = ldMethod), - !!!methodArgs + !!!engineParam ) qcResults <- exec(slalom, !!!callArgs) # Standardize output: slalom uses "outliers", rename to "outlier" for @@ -2838,7 +2803,7 @@ effectiveN <- function(nCase, nControl) { # ============================================================================= # summaryStatsQc -- SumStats-input QC pipeline (replaces the previous -# data.frame/LdData/QcResult-based summaryStatsQc and rssBasicQc). +# data.frame- and QcResult-based summaryStatsQc and rssBasicQc). # ============================================================================= # Convert one entry's GRanges into a flat tibble with the column shape @@ -2857,18 +2822,18 @@ effectiveN <- function(nCase, nControl) { # Build a refVariants data.frame (chrom, pos, A1, A2, variant_id) from the # panel's own variant ranges so harmonizeAlleles can join by (chrom, pos). -# The id comes from `.ldSketchMatchIds()`, not the raw SNP label: a panel entry +# The id comes from `.ldRefMatchIds()`, not the raw SNP label: a panel entry # that spells a tag where an allele belongs still harmonizes off its A1/A2 # columns, and the repaired id is what the LD lookups downstream can find. -.refVariantsFromSketch <- function(ldSketch) { - gr <- .ldSketchRanges(ldSketch) +.refVariantsFromLdRef <- function(ldReference) { + gr <- .ldRefRanges(ldReference) mc <- S4Vectors::mcols(gr) data.frame( - chrom = .ldSketchChrom(ldSketch), + chrom = .ldRefChrom(ldReference), pos = as.integer(GenomicRanges::start(gr)), A1 = as.character(mc$A1), A2 = as.character(mc$A2), - variant_id = .ldSketchMatchIds(ldSketch), + variant_id = .ldRefMatchIds(ldReference), stringsAsFactors = FALSE ) } @@ -2930,46 +2895,38 @@ effectiveN <- function(nCase, nControl) { # Shared entry-to-sumstat data.frame converter # ----------------------------------------------------------------------------- -# Internal: convert one sumstat-entry GRanges into a flat data.frame with -# (variant_id, chrom, pos, A1, A2) base columns plus a configurable set -# of stats columns (z, beta, se, N, maf). Shared by the four pipelines -# that walk sumstats GRanges (fineMappingPipeline, twasWeights, -# ctwasPipeline, colocboostPipeline). -# -# `require` character vector of mcol names that MUST be present; errors -# when any is missing. Use this for the strict callers -# (e.g. `.fmExtractZn` needs SNP + Z + N to proceed). -# `derive` when "zFromBetaSe" and `z` is absent but BETA + SE are -# present, set z := BETA/SE. Default "none". -# `label` error-message prefix for missing-`require` errors. -# `keepChrPrefix` when TRUE keep the seqname as-is ("chr1"); when FALSE, -# strip any leading "chr" so callers that expect numeric -# chrom (ctwas, colocboost) see "1". # Base (variant_id/chrom/pos/A1/A2) frame for one sumstat-entry GRanges. +# @noRd .entryDfBase <- function(gr, mc, chr) { - colOr <- function(name) { - if (is_in(name, colnames(mc))) { - as.character(mc[[name]]) - } else { - rep(NA_character_, length(gr)) - } - } + n <- length(gr) tibble( - variant_id = colOr("SNP"), + variant_id = .entryDfCharColumn("SNP", mc, n), chrom = chr, pos = unname(as.integer(GenomicRanges::start(gr))), - A1 = colOr("A1"), - A2 = colOr("A2") + A1 = .entryDfCharColumn("A1", mc, n), + A2 = .entryDfCharColumn("A2", mc, n) ) } -# Append the optional numeric stat columns present on the entry's mcols. +# One mcols column as character, or NA for each of the `n` variants when the +# entry does not carry it. +# @noRd +.entryDfCharColumn <- function(name, mc, n) { + if (is_in(name, colnames(mc))) { + as.character(mc[[name]]) + } else { + rep(NA_character_, n) + } +} + # One mcols column as numeric. # @noRd .entryStatColumn <- function(src, mc) { as.numeric(mc[[src]]) } +# Append the optional numeric stat columns present on the entry's mcols. +# @noRd .entryDfAddStats <- function(df, mc) { statMap <- c( z = "Z", @@ -3009,6 +2966,22 @@ effectiveN <- function(nCase, nControl) { mutate(df, maf = pmin(.data$af, 1 - .data$af)) } +# Convert one sumstat-entry GRanges into a flat data.frame with +# (variant_id, chrom, pos, A1, A2) base columns plus a configurable set +# of stats columns (z, beta, se, N, maf). Shared by the four pipelines +# that walk sumstats GRanges (fineMappingPipeline, twasWeights, +# ctwasPipeline, colocboostPipeline). +# +# `require` character vector of mcol names that MUST be present; errors +# when any is missing. Use this for the strict callers +# (e.g. `.fmExtractZn` needs SNP + Z + N to proceed). +# `derive` when "zFromBetaSe" and `z` is absent but BETA + SE are +# present, set z := BETA/SE. Default "none". +# `label` error-message prefix for missing-`require` errors. +# `keepChrPrefix` when TRUE keep the seqname as-is ("chr1"); when FALSE, +# strip any leading "chr" so callers that expect numeric +# chrom (ctwas, colocboost) see "1". +# @noRd .entryToSumstatDf <- function( gr, require = character(0), @@ -3085,33 +3058,70 @@ effectiveN <- function(nCase, nControl) { # bookkeeping that DENTIST's addDupsBackDentist uses to splice the # dropped variants back into the output. .findDuplicateVariants <- function(z, ld, rThreshold) { + walk <- .dupWalk(z, rThreshold, list(R = ld)) + kept <- walk$dupBearer == -1 + c( + list( + filteredZ = z[kept], + filteredLD = ld[kept, kept, drop = FALSE] + ), + walk + ) +} + +# .findDuplicateVariants() from a factor of the LD: the same walk, its LD rows +# computed a stripe at a time from the factor, so the p x p matrix is never +# formed; the duplicates are dropped from the factor's columns. +# @noRd +.findDuplicateVariantsFactor <- function(z, factor, rThreshold) { + walk <- .dupWalk(z, rThreshold, list(F = factor)) + kept <- walk$dupBearer == -1 + c( + list( + filteredZ = z[kept], + filteredFactor = factor[, kept, drop = FALSE] + ), + walk + ) +} + +# The duplicate walk: left to right, each variant not yet marked a duplicate +# anchors every later unmarked variant whose |r| with it exceeds rThreshold. +# Its LD rows are read from the LD source `ld` (.ldSourceRows()) a stripe of +# anchors at a time, so a factor never has to supply more than a stripe. +# @noRd +.dupWalk <- function(z, rThreshold, ld) { p <- length(z) dupBearer <- rep(-1, p) corABS <- rep(0, p) sign <- rep(1, p) count <- 1L minValue <- 1 + blockSize <- .ldStripeSize() + block <- NULL + blockStart <- 0L for (i in seq_len(p - 1L)) { if (dupBearer[i] != -1) { next } + if (is.null(block) || i >= blockStart + nrow(block)) { + blockStart <- i + block <- .ldSourceRows(ld, i:min(i + blockSize - 1L, p - 1L)) + } + row <- block[i - blockStart + 1L, ] idx <- (i + 1L):p - corVec <- abs(ld[i, idx]) + corVec <- abs(row[idx]) dupIdx <- which(dupBearer[idx] == -1 & corVec > rThreshold) if (length(dupIdx) > 0) { j <- idx[dupIdx] - sign[j] <- if_else(ld[i, j] < 0, -1, sign[j]) + sign[j] <- if_else(row[j] < 0, -1, sign[j]) corABS[j] <- corVec[dupIdx] dupBearer[j] <- count } minValue <- min(minValue, min(corVec)) count <- count + 1L } - filteredZ <- z[dupBearer == -1] - filteredLD <- ld[dupBearer == -1, dupBearer == -1, drop = FALSE] list( - filteredZ = filteredZ, - filteredLD = filteredLD, dupBearer = dupBearer, corABS = corABS, sign = sign, @@ -3215,18 +3225,18 @@ effectiveN <- function(nCase, nControl) { } # Apply the panel-vs-sumstats allele harmonization using the slim -# harmonizeAlleles against the ldSketch's variant info. Threads the +# harmonizeAlleles against the ldReference's variant info. Threads the # variant-level filters (indels, strand-ambiguous, duplicates) through # so the LD-panel-anchored pass handles them in a single sweep. -.matchAgainstSketch <- function( +.matchAgainstLdRef <- function( df, - ldSketch, + ldReference, matchMinProp, removeIndels = FALSE, removeStrandAmbiguous = TRUE, removeDups = TRUE ) { - refVariants <- .refVariantsFromSketch(ldSketch) + refVariants <- .refVariantsFromLdRef(ldReference) flipCandidates <- c("Z", "BETA") colToFlip <- intersect(flipCandidates, colnames(df)) if (length(colToFlip) == 0L) { @@ -3634,38 +3644,64 @@ effectiveN <- function(nCase, nControl) { # leaves the drop to onMissing here, so they are dropped here (keeping df # aligned with the returned LD) rather than aborting the run. # -# Returns list(R, df, dropped). `R` is NULL when no variant is panel-supported, -# and `df` is empty then -- each caller shapes its own empty result. +# Returns list(R, X, df, dropped): a genotype reference gives X, the factor of +# its LD (.ldFactorFromRef()), which the mismatch QC reads directly; an +# LdMatrix gives the matrix R. Both are NULL when no variant is +# panel-supported, and `df` is empty then -- each caller shapes its own empty +# result. .qcPanelLdMatrix() turns either into the matrix for a step that +# needs one. # @noRd -.qcPanelSupportedLd <- function(df, ldSketch, label) { +.qcPanelSupportedLd <- function(df, ldReference, label) { nIn <- nrow(df) - raw <- .ldFromSketch(ldSketch, df$SNP, label = label, onMissing = "drop") + isFactor <- .ldIsGenotypeRef(ldReference) + ldFrom <- if (isFactor) .ldFactorFromRef else .ldFromRef + raw <- ldFrom(ldReference, df$SNP, label = label, onMissing = "drop") if (is.null(raw)) { - return(list(R = NULL, df = df[0L, , drop = FALSE], dropped = nIn)) + return(list(df = df[0L, , drop = FALSE], dropped = nIn)) } keptIds <- attr(raw, "keptVariantIds") - R <- `attr<-`(raw, "keptVariantIds", NULL) - if (is.null(keptIds) || length(keptIds) >= nIn) { - return(list(R = R, df = df, dropped = 0L)) + ld <- `attr<-`(raw, "keptVariantIds", NULL) + supported <- if (is.null(keptIds) || length(keptIds) >= nIn) { + list(df = df, dropped = 0L) + } else { + list( + df = filter(df, is_in(.data$SNP, keptIds)), + dropped = nIn - length(keptIds) + ) } - list( - R = R, - df = filter(df, is_in(.data$SNP, keptIds)), - dropped = nIn - length(keptIds) - ) + c(if (isFactor) list(X = ld) else list(R = ld), supported) } +# The LD matrix of a .qcPanelSupportedLd() result, formed from its factor +# when that is what the reference gave. # @noRd -.applyLdMismatchQcToEntry <- function(df, ldSketch, method) { +.qcPanelLdMatrix <- function(panel) { + panel$R %||% (crossprod(panel$X) / (nrow(panel$X) - 1)) +} + +# DENTIST truncates its SVD at a rank bounded by the panel's real size, so it +# needs that size; SLALOM does not, so a reference that cannot say (an +# LdMatrix built without `nSamples`) passes NULL there. +# @noRd +.qcMismatchNSample <- function(ldReference, method) { + if (identical(method, "dentist")) { + return(.ldRefRequireNSamples(ldReference, "DENTIST")) + } + n <- .ldRefRealNSamples(ldReference) + if (is.na(n)) NULL else n +} + +.applyLdMismatchQcToEntry <- function(df, ldReference, method, panel = NULL) { if (is.null(df$SNP) || any(is.na(df$SNP))) { abort("summaryStatsQc: ldMismatchQc requires SNP column on the entry.") } - panel <- .qcPanelSupportedLd( - df, - ldSketch, - "summaryStatsQc: ldMismatchQcMethod" - ) - if (is.null(panel$R)) { + panel <- panel %||% + .qcPanelSupportedLd( + df, + ldReference, + "summaryStatsQc: ldMismatchQcMethod" + ) + if (is.null(panel$R) && is.null(panel$X)) { return(list( df = panel$df, outliers = 0L, @@ -3673,13 +3709,15 @@ effectiveN <- function(nCase, nControl) { panelUnsupportedDropped = panel$dropped )) } - R <- panel$R df <- panel$df variantIds <- df$SNP + # A genotype reference's factor goes in as X: SLALOM reads only the lead + # column of it. qc <- ldMismatchQc( zScore = df$Z, - R = R, - nSample = .ldSketchNSamples(ldSketch), + R = panel$R, + X = panel$X, + nSample = .qcMismatchNSample(ldReference, method), method = method ) # slalom / dentist can leave NA in the outlier column when their @@ -3688,25 +3726,29 @@ effectiveN <- function(nCase, nControl) { # "no evidence of being an outlier" (conservative: keep the variant) # so the downstream df / sum() / IRanges construction stay finite. outlierFlags <- replace(qc$outlier, is.na(qc$outlier), FALSE) - # Attach the variant_id column so the diagnostics data.frame stays - # self-describing once it's separated from the input df. - diagnostics <- if (is.data.frame(qc)) { - cbind( - variant_id = as.character(variantIds), - qc, - stringsAsFactors = FALSE - ) - } else { - NULL - } list( df = filter(df, !outlierFlags), outliers = sum(outlierFlags), - diagnostics = diagnostics, + diagnostics = .ldMismatchDiagnostics(qc, variantIds), panelUnsupportedDropped = panel$dropped ) } +# The QC's per-variant statistics with each variant's id attached, so the +# table stays self-describing once it is separated from the entry; NULL when +# the method returned no table. +# @noRd +.ldMismatchDiagnostics <- function(qc, variantIds) { + if (!is.data.frame(qc)) { + return(NULL) + } + cbind( + variant_id = as.character(variantIds), + qc, + stringsAsFactors = FALSE + ) +} + # ----------------------------------------------------------------------------- # Signal screen: skip an entry/block with no strong signal by a chosen metric. # ----------------------------------------------------------------------------- @@ -3897,7 +3939,7 @@ effectiveN <- function(nCase, nControl) { # --- .runEntrySummaryStatsQc: RAISS imputation step helpers ---------------- # Panel/dosage window indices for the entry, scoped per chromosome. -.qcRaissWindowIdx <- function(df, ldSketch, flank) { +.qcRaissWindowIdx <- function(df, ldReference, flank) { # canonChrom on BOTH sides: the panel answers in its own seqnames # convention, so the two are only comparable once canonicalized. bounds <- tibble( @@ -3913,9 +3955,9 @@ effectiveN <- function(nCase, nControl) { # inner_join keeps only sketch SNPs whose chromosome appears in df (the # old is_in(skChrom, names(loByChr)) guard); filter keeps those inside the # [lo, hi] window. idx carries the original sketch row positions. - gr <- .ldSketchRanges(ldSketch) + gr <- .ldRefRanges(ldReference) tibble( - chrom = .ldSketchChrom(ldSketch), + chrom = .ldRefChrom(ldReference), bp = as.integer(GenomicRanges::start(gr)), idx = seq_along(gr) ) |> @@ -3960,37 +4002,81 @@ effectiveN <- function(nCase, nControl) { knownZ |> mutate(!!!extras) |> arrange(.data$pos) } -.qcRaissBuildInputs <- function(df, ldSketch, windowIdx, opts) { - windowPanel <- .refVariantsFromSketch(ldSketch)[ +.qcRaissBuildInputs <- function(df, ldReference, windowIdx, opts) { + # `refIdx` keeps each window variant's position in the reference through + # the sort, so dosage, frequencies and LD are all read in panel order. + windowPanel <- .refVariantsFromLdRef(ldReference)[ windowIdx, , drop = FALSE ] |> - mutate(variant_id = normalizeVariantId(.data$variant_id)) |> + mutate( + variant_id = normalizeVariantId(.data$variant_id), + refIdx = windowIdx + ) |> arrange(.data$pos) knownZ <- .qcRaissKnownZ(df) - # meanImpute = FALSE so per-variant missingness is still visible; the - # surviving columns are mean-imputed below, which is what meanImpute = - # TRUE did. - windowDosage <- `colnames<-`( - .ldSketchDosage(ldSketch, windowIdx, meanImpute = FALSE), - normalizeVariantId(.ldSketchMatchIds(ldSketch)[windowIdx]) - ) - windowed <- windowDosage[, windowPanel$variant_id, drop = FALSE] - keep <- .qcRaissTargetMask(windowPanel, knownZ, windowed, opts) - refPanel <- windowPanel[keep, , drop = FALSE] + rp <- opts$raissParam + windowed <- if (.ldIsPanel(ldReference)) { + # meanImpute = FALSE so per-variant missingness is still visible; the + # surviving columns are mean-imputed below. + .ldRefDosage(ldReference, windowPanel$refIdx, meanImpute = FALSE) + } + keep <- .qcRaissTargetMask( + windowPanel, + knownZ, + .qcRaissTargetStats(ldReference, windowPanel$refIdx, windowed, rp), + opts, + nSamples = .ldRefMacSamples(ldReference, rp$macCutoff) + ) + c( + list( + refPanel = select(windowPanel[keep, , drop = FALSE], -"refIdx"), + knownZ = knownZ, + nDroppedTargets = sum(!keep) + ), + .qcRaissLdInput(ldReference, windowPanel$refIdx[keep], windowed, keep) + ) +} + +# What RAISS imputes from: a panel's standardized dosages or a mixture's +# stacked factor, for its singular-value route, or an LdMatrix's block over +# the kept variants. +# @noRd +.qcRaissLdInput <- function(ldReference, refIdx, windowed, keep) { + if (.ldIsMatrixRef(ldReference)) { + return(list(ldMatrix = .ldRefLdAt(ldReference, refIdx))) + } + if (.ldIsMixtureRef(ldReference)) { + return(list(genotypeMatrix = .ldRefFactor(ldReference, refIdx))) + } scaled <- scale(.qtlMeanImpute(windowed[, keep, drop = FALSE])) - scaledDosage <- replace(scaled, is.na(scaled), 0) - list( - refPanel = refPanel, - knownZ = knownZ, - scaledDosage = scaledDosage, - nDroppedTargets = sum(!keep) + list(genotypeMatrix = replace(scaled, is.na(scaled), 0)) +} + +# The per-variant statistics the target cutoffs are judged on, or NULL when +# no cutoff is set. A panel of real genotypes measures them on the window's +# dosages, already in hand; a sketch or an LdMatrix answers from what it +# records (see .ldRefVariantStats()). +# @noRd +.qcRaissTargetStats <- function(ldReference, refIdx, windowed, rp) { + if (rp$mafCutoff <= 0 && rp$macCutoff <= 0 && rp$imissCutoff >= 1) { + return(NULL) + } + if (!is.null(windowed) && !.ldRefIsProjection(ldReference)) { + return(.qcRaissVariantStats(windowed)) + } + .ldRefVariantStats( + ldReference, + refIdx, + needMissing = rp$imissCutoff < 1, + step = "RAISS target filtering" ) } # Which reference-panel variants to keep, given the MAF / MAC / missingness -# cutoffs in `imputeArgs`. +# cutoffs in `raissParam` and the per-variant `stats` they are judged on +# (NULL when no cutoff is set). # # The cutoffs govern what RAISS is willing to IMPUTE, not what it is willing to # keep, so an observed variant survives whatever its frequency in the LD panel. @@ -4003,14 +4089,12 @@ effectiveN <- function(nCase, nControl) { # an imputation target, which is both slow and statistically pointless when the # study is much smaller than the panel. # @noRd -.qcRaissTargetMask <- function(refPanel, knownZ, dosage, opts) { - mafCutoff <- opts$imputeArgs$mafCutoff - macCutoff <- opts$imputeArgs$macCutoff - imissCutoff <- opts$imputeArgs$imissCutoff +.qcRaissTargetMask <- function(refPanel, knownZ, stats, opts, nSamples) { keep <- rep(TRUE, nrow(refPanel)) - if (mafCutoff <= 0 && macCutoff <= 0 && imissCutoff >= 1) { + if (is.null(stats)) { return(keep) } + rp <- opts$raissParam # Identified exactly as raissSingleMatrixFromX() does, so this mask cannot # disagree with the knowns/unknowns split it derives moments later. knownIds <- intersect(knownZ$variant_id, refPanel$variant_id) @@ -4020,11 +4104,11 @@ effectiveN <- function(nCase, nControl) { unsafe <- isTarget & (.raissUnsafeToImpute(refPanel$variant_id, knownZ$variant_id) | .raissObservedPosition(refPanel, knownZ)) - stats <- .qcRaissVariantStats(dosage) - effectiveMaf <- .panelEffectiveMaf(mafCutoff, macCutoff, nrow(dosage)) - fails <- (!is.na(stats$maf) & stats$maf < effectiveMaf) | - stats$missRate > imissCutoff | - is.na(stats$maf) + effectiveMaf <- .panelEffectiveMaf(rp$mafCutoff, rp$macCutoff, nSamples) + fails <- (!is.na(stats$maf) & stats$maf < effectiveMaf) | is.na(stats$maf) + if (!is.null(stats$missRate)) { + fails <- fails | stats$missRate > rp$imissCutoff + } keep & !(isTarget & fails) & !unsafe } @@ -4038,30 +4122,35 @@ effectiveN <- function(nCase, nControl) { } -# RaissParam() covers two audiences: four fields are raiss()'s own formals and +# RaissParam() covers two audiences: five fields are raiss()'s own formals and # four bound what RAISS is asked to impute. Splitting the bundle here lets the # call site splice rather than name each field, and keeps the two groups from # being confused for one another. # @noRd .raissForwardedNames <- function() { - c("lamb", "svdTol", "r2Threshold", "minimumLd") + c("lamb", "rcond", "svdTol", "r2Threshold", "minimumLd") } # @noRd -.raissForwardedArgs <- function(imputeArgs) { - as.list(imputeArgs)[.raissForwardedNames()] +.raissForwardedArgs <- function(raissParam) { + as.list(raissParam)[.raissForwardedNames()] } -# Run RAISS with per-call option defaults. +# Run RAISS on the inputs .qcRaissBuildInputs() assembled: the window's +# standardized dosages on the genotype route, or its LD block on the matrix +# route. These were built here from the collection's own LD reference, so +# they go straight to the route rather than back through raiss()'s checks. .qcRaissRun <- function(inp, opts) { - exec( - raiss, - refPanel = inp$refPanel, - knownZscores = inp$knownZ, - genotypeMatrix = inp$scaledDosage, - verbose = FALSE, - !!!.raissForwardedArgs(opts$imputeArgs) - ) + p <- c(.raissForwardedArgs(opts$raissParam), list(verbose = FALSE)) + if (!is.null(inp$genotypeMatrix)) { + return(.raissGenotypePath( + inp$refPanel, + inp$knownZ, + inp$genotypeMatrix, + p + )) + } + .raissLdPath(inp$refPanel, inp$knownZ, inp$ldMatrix, p) } # Convert the imputer output back into a QC tibble. @@ -4150,12 +4239,12 @@ effectiveN <- function(nCase, nControl) { ) } -# Optional RAISS imputation against the ldSketch. Returns updated df + audit +# Optional RAISS imputation against the ldReference. Returns updated df + audit # fields + before/after counts (imputation adds variants, so not monotonic). -.qcRaissImpute <- function(df, ldSketch, opts, lbl) { +.qcRaissImpute <- function(df, ldReference, opts, lbl) { imputeBefore <- nrow(df) - flank <- as.integer(opts$imputeArgs$flank) - windowIdx <- .qcRaissWindowIdx(df, ldSketch, flank) + flank <- as.integer(opts$raissParam$flank) + windowIdx <- .qcRaissWindowIdx(df, ldReference, flank) if (length(windowIdx) == 0L) { .qcEmit( lbl, @@ -4170,7 +4259,7 @@ effectiveN <- function(nCase, nControl) { imputeAfter = nrow(df) )) } - inp <- .qcRaissBuildInputs(df, ldSketch, windowIdx, opts) + inp <- .qcRaissBuildInputs(df, ldReference, windowIdx, opts) if (inp$nDroppedTargets > 0L) { .qcEmit( lbl, @@ -4268,18 +4357,18 @@ effectiveN <- function(nCase, nControl) { # --- .runEntrySummaryStatsQc: harmonization / kriging / mismatch steps ------ # Panel-vs-sumstats allele harmonization + counter bookkeeping. -.qcHarmonizeEntry <- function(df, ldSketch, opts, lbl) { +.qcHarmonizeEntry <- function(df, ldReference, opts, lbl) { nHarmIn <- nrow(df) - matched <- .matchAgainstSketch( + matched <- .matchAgainstLdRef( df, - ldSketch, + ldReference, matchMinProp = opts$matchMinProp, - removeIndels = opts$sumstatsFilterArgs$removeIndels, - removeStrandAmbiguous = opts$sumstatsFilterArgs$removeStrandAmbiguous, + removeIndels = opts$sumstatsFilterParam$removeIndels, + removeStrandAmbiguous = opts$sumstatsFilterParam$removeStrandAmbiguous, removeDups = TRUE ) harmCounts <- attr(matched, "qcCounts") - # Re-key SNP to the harmonized id: .matchAgainstSketch rewrites variant_id + # Re-key SNP to the harmonized id: .matchAgainstLdRef rewrites variant_id # to the panel orientation + sign-flips swapped variants but leaves SNP; a # stale SNP makes flipped variants miss the panel in later lookups. reKeyed <- mutate( @@ -4306,7 +4395,7 @@ effectiveN <- function(nCase, nControl) { ) list( df = reKeyed, - audit = list(matchedAgainstSketch = nrow(reKeyed)), + audit = list(matchedAgainstLdReference = nrow(reKeyed)), counts = counts ) } @@ -4359,17 +4448,18 @@ effectiveN <- function(nCase, nControl) { } # @noRd -.qcKrigingFlip <- function(df, ldSketch, opts, lbl) { - if (!isTRUE(opts$alleleFlipKriging) || nrow(df) < 2L) { +.qcKrigingFlip <- function(df, ldReference, opts, lbl, panel = NULL) { + if (!.qcKrigingRuns(df, opts)) { return(list(df = df, audit = list(), count = 0L)) } nKrIn <- nrow(df) - panel <- .qcPanelSupportedLd( - df, - ldSketch, - "summaryStatsQc: kriging prefilter" - ) - if (is.null(panel$R)) { + panel <- panel %||% + .qcPanelSupportedLd( + df, + ldReference, + "summaryStatsQc: kriging prefilter" + ) + if (is.null(panel$R) && is.null(panel$X)) { return(list( df = panel$df, count = 0L, @@ -4379,9 +4469,10 @@ effectiveN <- function(nCase, nControl) { supported <- panel$df nPanelDrop <- panel$dropped .qcEmitPanelDrop(lbl, nPanelDrop, nKrIn) + # kriging_rss takes nothing but the matrix (dev/ld-factor-audit.md). kr <- krigingOutlierQc( supported$Z, - panel$R, + .qcPanelLdMatrix(panel), n = .qcKrigingN(supported, opts), variantIds = supported$SNP ) @@ -4406,16 +4497,32 @@ effectiveN <- function(nCase, nControl) { ) } +# TRUE when the kriging allele-flip check runs on this entry. +# @noRd +.qcKrigingRuns <- function(df, opts) { + isTRUE(opts$alleleFlipKriging) && nrow(df) >= 2L +} + +# TRUE when an LD-mismatch check runs on this entry. +# @noRd +.qcMismatchRuns <- function(df, opts) { + !identical(.engineOf(opts$ldMismatchQcMethod), "none") && nrow(df) >= 2L +} + # LD-mismatch QC (SLALOM / DENTIST). Retains full per-variant diagnostics. -.qcMismatchQc <- function(df, ldSketch, opts, lbl) { - if ( - identical(.engineOf(opts$ldMismatchQcMethod), "none") || - nrow(df) < 2L - ) { +# `panel` is the entry's panel-supported LD when the caller has already read +# it (see .qcPhaseLdChecks()). +.qcMismatchQc <- function(df, ldReference, opts, lbl, panel = NULL) { + if (!.qcMismatchRuns(df, opts)) { return(list(df = df, audit = list(), count = 0L)) } nMmIn <- nrow(df) - ldQc <- .applyLdMismatchQcToEntry(df, ldSketch, opts$ldMismatchQcMethod) + ldQc <- .applyLdMismatchQcToEntry( + df, + ldReference, + opts$ldMismatchQcMethod, + panel = panel + ) df <- ldQc$df baseAudit <- list( ldMismatchOutliersDropped = ldQc$outliers, @@ -4485,7 +4592,7 @@ effectiveN <- function(nCase, nControl) { nSanIn <- nrow(df) # The boundary: the bundle travels this far, and .applySanityChecks and # the per-check helpers below it keep plain scalars. - cleaning <- opts$sumstatsCleaningArgs + cleaning <- opts$sumstatsCleaningParam sanity <- exec(.applySanityChecks, df, !!!cleaning) df <- sanity$df audit <- .qcAudit( @@ -4535,8 +4642,8 @@ effectiveN <- function(nCase, nControl) { cf <- .applyContentFilters( df, mafCutoff = opts$panelFilterParam$mafCutoff, - infoCutoff = opts$sumstatsFilterArgs$infoCutoff, - nCutoff = opts$sumstatsFilterArgs$nCutoff + infoCutoff = opts$sumstatsFilterParam$infoCutoff, + nCutoff = opts$sumstatsFilterParam$nCutoff ) df <- cf$df audit <- .qcAudit( @@ -4585,7 +4692,7 @@ effectiveN <- function(nCase, nControl) { # Re-clamp the P values just derived from Z, and report how many moved. # @noRd .qcClampDerivedP <- function(df, opts) { - cleaning <- opts$sumstatsCleaningArgs + cleaning <- opts$sumstatsCleaningParam if (!isTRUE(cleaning$clampSmallP) || nrow(df) == 0L) { return(list(df = df, nClamped = 0L)) } @@ -4659,11 +4766,11 @@ effectiveN <- function(nCase, nControl) { } # Optional RAISS imputation step wrapper (guarded; threads impute counters). -.qcRaissImputeStep <- function(df, ldSketch, opts, lbl, qcCount) { +.qcRaissImputeStep <- function(df, ldReference, opts, lbl, qcCount) { if (!isTRUE(opts$impute) || nrow(df) < 1L) { return(list(df = df, audit = list(), qcCount = qcCount)) } - imp <- .qcRaissImpute(df, ldSketch, opts, lbl) + imp <- .qcRaissImpute(df, ldReference, opts, lbl) list( df = imp$df, audit = imp$audit, @@ -4690,7 +4797,7 @@ effectiveN <- function(nCase, nControl) { # Each QC phase below is (state) -> state, so the sequence reads as a pipeline # rather than a run of reassignments. `state` carries df + entryAudit + opts + -# qcCount + lbl (+ ldSketch for the panel-aware phases); a phase touches only +# qcCount + lbl (+ ldReference for the panel-aware phases); a phase touches only # the parts it owns and passes the rest through. # Per-row sanity checks. @@ -4751,7 +4858,7 @@ effectiveN <- function(nCase, nControl) { .qcPhaseHarmonize <- function(state) { harm <- .qcHarmonizeEntry( state$df, - state$ldSketch, + state$ldReference, state$opts, state$lbl ) @@ -4778,8 +4885,32 @@ effectiveN <- function(nCase, nControl) { # reads the kriging-corrected frame and the two counts are reported together. # @noRd .qcPhaseLdChecks <- function(state) { - kr <- .qcKrigingFlip(state$df, state$ldSketch, state$opts, state$lbl) - mm <- .qcMismatchQc(kr$df, state$ldSketch, state$opts, state$lbl) + # Both checks read the same panel-supported variants -- kriging only flips + # signs -- so when both run the reference is read once, for the two. + shared <- if ( + .qcKrigingRuns(state$df, state$opts) && + .qcMismatchRuns(state$df, state$opts) + ) { + .qcPanelSupportedLd(state$df, state$ldReference, "summaryStatsQc") + } + kr <- .qcKrigingFlip( + state$df, + state$ldReference, + state$opts, + state$lbl, + panel = shared + ) + mm <- .qcMismatchQc( + kr$df, + state$ldReference, + state$opts, + state$lbl, + # Kriging has already recorded the panel's drops; its output carries + # only supported variants. + panel = if (!is.null(shared)) { + list_assign(shared, df = kr$df, dropped = 0L) + } + ) list_assign( state, df = mm$df, @@ -4800,7 +4931,7 @@ effectiveN <- function(nCase, nControl) { .qcPhaseImpute <- function(state) { imp <- .qcRaissImputeStep( state$df, - state$ldSketch, + state$ldReference, state$opts, state$lbl, state$qcCount @@ -4840,7 +4971,7 @@ effectiveN <- function(nCase, nControl) { .runEntrySummaryStatsQc <- function( gr, - ldSketch, + ldReference, opts, entryLabel = NULL ) { @@ -4861,7 +4992,7 @@ effectiveN <- function(nCase, nControl) { qcCount = pre$qcCount, opts = pre$opts, lbl = pre$lbl, - ldSketch = ldSketch + ldReference = ldReference ) |> .qcPhaseHarmonize() |> .qcPhaseScreen() |> @@ -4881,6 +5012,12 @@ effectiveN <- function(nCase, nControl) { ) } +# Number of ranges an entry contributes, NULL-safe. +# @noRd +.entryRangeCount <- function(gr) { + if (is.null(gr)) 0L else length(gr) +} + # 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 @@ -4889,14 +5026,8 @@ effectiveN <- function(nCase, nControl) { # 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. # @noRd -# Number of ranges an entry contributes, NULL-safe. -# @noRd -.entryRangeCount <- function(gr) { - if (is.null(gr)) 0L else length(gr) -} - -.subsetSketchToRange <- function(ldSketch, entries) { - if (is.null(ldSketch)) { +.subsetLdRefToRange <- function(ldReference, entries) { + if (is.null(ldReference)) { return(NULL) } chromAll <- unname(list_c(map(entries, .entryChrom))) @@ -4907,18 +5038,18 @@ effectiveN <- function(nCase, nControl) { if (length(pos) == 0L) { # No span to keep: a zero-variant object references no LD, so the # retained panel is empty rather than the full genome-wide sketch. - return(.emptySketch(ldSketch)) + return(.emptyLdRef(ldReference)) } bounds <- tibble(chrom = chrom, pos = pos) |> group_by(chrom) |> summarise(lo = min(pos), hi = max(pos), .groups = "drop") - gr <- .ldSketchRanges(ldSketch) + gr <- .ldRefRanges(ldReference) # left_join keeps every sketch SNP; one on a chromosome absent from the # entries gets lo/hi = NA -> inWindow FALSE (the old is_in guard). The # explicit is.na() guards force FALSE (never NA) for an absent chrom or an # NA bp, replacing the base keep[is.na(keep)] <- FALSE. keep <- tibble( - chrom = .ldSketchChrom(ldSketch), + chrom = .ldRefChrom(ldReference), bp = as.integer(GenomicRanges::start(gr)) ) |> left_join(bounds, by = "chrom") |> @@ -4929,7 +5060,7 @@ effectiveN <- function(nCase, nControl) { .data$bp <= .data$hi ) |> pull("inWindow") - .ldSketchSubset(ldSketch, keep) + .ldRefSubset(ldReference, keep) } # Shrink an LD-sketch GenotypeHandle to EXACTLY the variants present across the @@ -4937,8 +5068,8 @@ effectiveN <- function(nCase, nControl) { # matched by canonical variant id. Applied at the end of summaryStatsQc so the # retained sketch mirrors the object's final variant set. NULL-safe. # @noRd -.subsetSketchToIds <- function(ldSketch, entries) { - if (is.null(ldSketch)) { +.subsetLdRefToIds <- function(ldReference, entries) { + if (is.null(ldReference)) { return(NULL) } # Genuine variant count (ranges) across entries, read independently of the @@ -4948,11 +5079,11 @@ effectiveN <- function(nCase, nControl) { # sketch rather than blanking a panel it simply could not key. nRanges <- sum(map_int(entries, .entryRangeCount)) if (nRanges == 0L) { - return(.emptySketch(ldSketch)) + return(.emptyLdRef(ldReference)) } ids <- unname(list_c(map(entries, .entrySnpIds))) if (length(ids) == 0L) { - return(ldSketch) + return(ldReference) } # Match on the (chrom, pos, allele) tuple rather than the raw id string. # The entry ids have just been canonicalized to chr:pos:A2:A1 by the QC @@ -4961,15 +5092,15 @@ effectiveN <- function(nCase, nControl) { # -- so a panel keyed chr:pos:A1:A2 (which is how a PLINK .bim writes ids; # a .pvar writes REF:ALT and is therefore already canonical) matches # nothing under string equality and the panel is silently emptied. This is - # the matcher `.ldFromSketchMatch()` and every other LD lookup already use. - panelIds <- .ldSketchMatchIds(ldSketch) + # the matcher `.ldFromRefMatch()` and every other LD lookup already use. + panelIds <- .ldRefMatchIds(ldReference) matched <- matchVariants( panelIds, unique(ids), removeStrandAmbiguous = FALSE ) keep <- is_in(seq_along(panelIds), matched$idxA) - .ldSketchSubset(ldSketch, keep) + .ldRefSubset(ldReference, keep) } # --- summaryStatsQc orchestration helpers ---------------------------------- @@ -5018,39 +5149,39 @@ effectiveN <- function(nCase, nControl) { # Build the per-entry QC options list from the captured call parameters. .ssqcBuildOpts <- function( - sumstatsFilterArgs, + sumstatsFilterParam, panelFilterParam, skipRegion, ldMismatchQcMethod, alleleFlipKriging, effectiveN, impute, - imputeArgs, + raissParam, matchMinProp, - sumstatsCleaningArgs, + sumstatsCleaningParam, keepVariants, - signalScreenArgs + signalScreenParam ) { # Built explicitly rather than by subsetting a captured environment with a # character vector: a renamed argument is now an error, not a NULL entry. opts <- list( - sumstatsFilterArgs = sumstatsFilterArgs, + sumstatsFilterParam = sumstatsFilterParam, panelFilterParam = panelFilterParam, skipRegion = skipRegion, ldMismatchQcMethod = ldMismatchQcMethod, alleleFlipKriging = alleleFlipKriging, effectiveN = effectiveN, impute = impute, - imputeArgs = imputeArgs, + raissParam = raissParam, matchMinProp = matchMinProp, - sumstatsCleaningArgs = sumstatsCleaningArgs + sumstatsCleaningParam = sumstatsCleaningParam ) # nCase / nControl / nForPip are deliberately absent here: they are # per-entry, and `.ssqcEntryOpts()` adds them for the entry being run. list_assign( opts, keepVariants = as.character(keepVariants), - screen = .screenResolve(signalScreenArgs) + screen = .screenResolve(signalScreenParam) ) } @@ -5099,38 +5230,38 @@ effectiveN <- function(nCase, nControl) { # retained panel no longer covers, and kriging, SLALOM/DENTIST and the RAISS # known/unknown split then only ever see what survived. # @noRd -.ssqcPrunePanel <- function(ldSketch, cutoffs, label) { - if (is.null(ldSketch) || is.null(cutoffs)) { - return(ldSketch) +.ssqcPrunePanel <- function(ldReference, cutoffs, label) { + if (is.null(ldReference) || is.null(cutoffs)) { + return(ldReference) } - ids <- .ldSketchMatchIds(ldSketch) + ids <- .ldRefMatchIds(ldReference) if (length(ids) == 0L) { - return(ldSketch) + return(ldReference) } - keep <- .panelKeepMask(ids, ldSketch, cutoffs, label) + keep <- .panelKeepMask(ids, ldReference, cutoffs, label) if (all(keep)) { - return(ldSketch) + return(ldReference) + } + if (.ldIsMatrixRef(ldReference) || .ldIsMixtureRef(ldReference)) { + return(.ldRefSubset(ldReference, keep)) } - # Prune the underlying GenotypeHandle, not just an RSE row view: the - # handle is the dosage DelayedArray's seed, and `sketch[keep, ]` leaves - # that seed carrying the whole panel (the trap `.emptySketch()` - # documents), so every read would still see the dropped variants. This is - # a seed-level edit, which is why it reaches for the handle. - pruned <- .subsetGenotypeHandle(.ldSketchHandle(ldSketch), keep) - if (methods::is(ldSketch, "GenotypeHandle")) { - return(pruned) + if (methods::is(ldReference, "GenotypeHandle")) { + return(.subsetGenotypeHandle(ldReference, keep)) } - .genotypeExperiment(pruned) + # A panel is cut where it can shed the dropped variants from its seed as + # well as from its rows (.panelSubsetRows()). The mask is over the + # PANEL's rows, so it is never applied to a handle whose rows differ. + .panelSubsetRows(ldReference, keep) } # One entry's QC result: list(gr, audit). `opts` arrives as the shared base # options; the per-entry fields are derived here rather than carried over from # the previous entry. # @noRd -.ssqcRunEntry <- function(i, sumstats, opts, ldSketch, isQtl) { +.ssqcRunEntry <- function(i, sumstats, opts, ldReference, isQtl) { .runEntrySummaryStatsQc( gr = .collectionEntry(sumstats, i), - ldSketch = ldSketch, + ldReference = ldReference, opts = .ssqcEntryOpts(opts, sumstats, i), entryLabel = .ssqcEntryLabel(sumstats, i, isQtl) ) @@ -5142,8 +5273,8 @@ effectiveN <- function(nCase, nControl) { # Panel filter, once for the shared LD reference and BEFORE any entry is # harmonized, so a variant the panel cannot support is gone from the LD # and from the summary statistics alike. - ldSketch <- .ssqcPrunePanel( - ldSketch(sumstats), + ldReference <- .ssqcPrunePanel( + ldReference(sumstats), .panelCutoffs(opts$panelFilterParam), "summaryStatsQc" ) @@ -5153,13 +5284,13 @@ effectiveN <- function(nCase, nControl) { .ssqcRunEntry, sumstats = sumstats, opts = opts, - ldSketch = ldSketch, + ldReference = ldReference, isQtl = isQtl ) list( newEntries = map(results, "gr"), entryAudits = map(results, "audit"), - ldSketch = ldSketch + ldReference = ldReference ) } @@ -5168,21 +5299,21 @@ effectiveN <- function(nCase, nControl) { # like qcDiagnostics() index these four names, so the output shape is kept # even though the input is now one argument. # @noRd -.ssqcScreenEcho <- function(signalScreenArgs, metric) { - signalScreenArgs[[metric]] %||% 0 +.ssqcScreenEcho <- function(signalScreenParam, metric) { + signalScreenParam[[metric]] %||% 0 } # Assemble the qcInfo record (echoed options + per-entry audits). .ssqcBuildQcInfo <- function( entryAudits, - sumstatsFilterArgs, + sumstatsFilterParam, panelFilterParam, - signalScreenArgs, + signalScreenParam, ldMismatchQcMethod, alleleFlipKriging, effectiveN, impute, - sumstatsCleaningArgs + sumstatsCleaningParam ) { list( timestamp = NA_character_, @@ -5191,50 +5322,58 @@ effectiveN <- function(nCase, nControl) { # these names. The bundles are an argument convention, not an # output one. options = list( - removeIndels = sumstatsFilterArgs$removeIndels, - removeStrandAmbiguous = sumstatsFilterArgs$removeStrandAmbiguous, + removeIndels = sumstatsFilterParam$removeIndels, + removeStrandAmbiguous = sumstatsFilterParam$removeStrandAmbiguous, mafCutoff = panelFilterParam$mafCutoff, macCutoff = panelFilterParam$macCutoff, imissCutoff = panelFilterParam$imissCutoff, - infoCutoff = sumstatsFilterArgs$infoCutoff, - nCutoff = sumstatsFilterArgs$nCutoff, - pipCutoffToSkip = .ssqcScreenEcho(signalScreenArgs, "pip"), - absZCutoffToSkip = .ssqcScreenEcho(signalScreenArgs, "absZ"), - bfCutoffToSkip = .ssqcScreenEcho(signalScreenArgs, "bf"), - logBfCutoffToSkip = .ssqcScreenEcho(signalScreenArgs, "logBf"), + infoCutoff = sumstatsFilterParam$infoCutoff, + nCutoff = sumstatsFilterParam$nCutoff, + pipCutoffToSkip = .ssqcScreenEcho(signalScreenParam, "pip"), + absZCutoffToSkip = .ssqcScreenEcho(signalScreenParam, "absZ"), + bfCutoffToSkip = .ssqcScreenEcho(signalScreenParam, "bf"), + logBfCutoffToSkip = .ssqcScreenEcho(signalScreenParam, "logBf"), ldMismatchQcMethod = ldMismatchQcMethod, alleleFlipKriging = alleleFlipKriging, effectiveN = effectiveN, impute = impute, # Echoed FLAT for the same reason the screen cutoffs are: these # nine names are part of the returned object's shape. - coerceNumeric = sumstatsCleaningArgs$coerceNumeric, - normalizeChr = sumstatsCleaningArgs$normalizeChr, - dropNonstandardChr = sumstatsCleaningArgs$dropNonstandardChr, - dropMissData = sumstatsCleaningArgs$dropMissData, - dropPOutOfRange = sumstatsCleaningArgs$dropPOutOfRange, - clampSmallP = sumstatsCleaningArgs$clampSmallP, - smallPFloor = sumstatsCleaningArgs$smallPFloor, - dropZeroEffect = sumstatsCleaningArgs$dropZeroEffect, - dropNonpositiveSe = sumstatsCleaningArgs$dropNonpositiveSe + coerceNumeric = sumstatsCleaningParam$coerceNumeric, + normalizeChr = sumstatsCleaningParam$normalizeChr, + dropNonstandardChr = sumstatsCleaningParam$dropNonstandardChr, + dropMissData = sumstatsCleaningParam$dropMissData, + dropPOutOfRange = sumstatsCleaningParam$dropPOutOfRange, + clampSmallP = sumstatsCleaningParam$clampSmallP, + smallPFloor = sumstatsCleaningParam$smallPFloor, + dropZeroEffect = sumstatsCleaningParam$dropZeroEffect, + dropNonpositiveSe = sumstatsCleaningParam$dropNonpositiveSe ), entryAudit = entryAudits ) } # Rebuild the SumStats object with QC'd entries, trimmed sketch, and qcInfo. -.ssqcRebuild <- function(sumstats, newEntries, newLdSketch, qcInfo) { - has <- function(nm) is_in(nm, .tupleColumnNames(sumstats)) - nSample <- if (has("nSample")) as.numeric(sumstats$nSample) else NULL +.ssqcRebuild <- function(sumstats, newEntries, newLdReference, qcInfo) { + cols <- .tupleColumnNames(sumstats) + nSample <- if (is_in("nSample", cols)) { + as.numeric(sumstats$nSample) + } else { + NULL + } if (methods::is(sumstats, "GwasSumStats")) { GwasSumStats( studyName = as.character(sumstats$study), entry = newEntries, genome = unique(unname(GenomeInfoDb::genome(sumstats))), - ldSketch = newLdSketch, + ldReference = newLdReference, varY = as.numeric(sumstats$varY), - nCase = if (has("nCase")) as.numeric(sumstats$nCase) else NULL, - nControl = if (has("nControl")) { + nCase = if (is_in("nCase", cols)) { + as.numeric(sumstats$nCase) + } else { + NULL + }, + nControl = if (is_in("nControl", cols)) { as.numeric(sumstats$nControl) } else { NULL @@ -5244,7 +5383,7 @@ effectiveN <- function(nCase, nControl) { # Carry the existing block keys through: the entries are already # split, so without this the constructor re-derives them from # seqname and every block on one chromosome collapses to one key. - blockId = if (has("blockId")) { + blockId = if (is_in("blockId", cols)) { as.character(sumstats$blockId) } else { NULL @@ -5257,7 +5396,7 @@ effectiveN <- function(nCase, nControl) { trait = as.character(sumstats$trait), entry = newEntries, genome = unique(unname(GenomeInfoDb::genome(sumstats))), - ldSketch = newLdSketch, + ldReference = newLdReference, varY = as.numeric(sumstats$varY), nSample = nSample, qcInfo = qcInfo @@ -5273,10 +5412,11 @@ effectiveN <- function(nCase, nControl) { #' tiny P; normalize CHR; coerce signed columns to numeric), variant-content #' filters (MAF / INFO / N) via \code{.applyContentFilters}, optional #' \code{skipRegion} drop, optional PIP screen, panel-vs-sumstats allele -#' harmonization against the \code{ldSketch} via \code{harmonizeAlleles} (which -#' handles indels, strand-ambiguous variants, sign / strand flips, and duplicate -#' drops in a single sweep), optional SLALOM/DENTIST LD-mismatch QC, and -#' optional RAISS imputation. No Bioconductor genome / dbSNP packages required. +#' harmonization against the \code{ldReference} via \code{harmonizeAlleles} +#' (which handles indels, strand-ambiguous variants, sign / strand flips, and +#' duplicate drops in a single sweep), optional SLALOM/DENTIST LD-mismatch QC, +#' and optional RAISS imputation. No Bioconductor genome / dbSNP packages +#' required. #' #' The returned collection has its \code{qcInfo} slot populated with a per-entry #' audit record (variant counts, drop counts at each step, which filters fired, @@ -5310,7 +5450,7 @@ effectiveN <- function(nCase, nControl) { #' variant common in the panel but rare in the study is dropped as well. #' #' @param sumstats A \code{QtlSumStats} or \code{GwasSumStats} collection. -#' @param sumstatsFilterArgs Row filters applied to the summary statistics +#' @param sumstatsFilterParam Row filters applied to the summary statistics #' themselves, built with \code{\link{SumstatsFilterParam}}: #' \code{removeIndels} drops indels during panel harmonization, #' \code{removeStrandAmbiguous} drops A/T and C/G variants, @@ -5321,8 +5461,10 @@ effectiveN <- function(nCase, nControl) { #' @param panelFilterParam LD-reference-panel filters, built with #' \code{\link{PanelFilterParam}}. \code{macCutoff} is converted to a MAF #' equivalent using \code{macCutoff / (2 * nSamples)} and the stricter of -#' it and \code{mafCutoff} applies; \code{imissCutoff} is a per-variant -#' missingness ceiling. See the panel-filters section below. +#' it and \code{mafCutoff} applies; \code{nSamples} counts the panel's real +#' samples, which for a stochastic LD sketch are those its \code{.afreq} +#' records rather than its pseudo-samples. \code{imissCutoff} is a +#' per-variant missingness ceiling. See the panel-filters section below. #' #' \code{mafCutoff} is the one setting that reaches past the panel: it is #' measured wherever it can be, against the summary statistics' own @@ -5333,7 +5475,7 @@ effectiveN <- function(nCase, nControl) { #' retain prior to harmonization. #' @param skipRegion Optional character vector of \code{"chr:start-end"} #' strings, or a \code{GRanges}, of regions to drop. -#' @param signalScreenArgs Whether to skip an entry before fitting it, +#' @param signalScreenParam Whether to skip an entry before fitting it, #' built with #' \code{\link{SignalScreenParam}} --- the same bundle #' \code{\link{fineMappingPipeline}} and \code{\link{colocboostPipeline}} @@ -5366,14 +5508,14 @@ effectiveN <- function(nCase, nControl) { #' records the setting and each entry's \code{nSource} is one of #' \code{"effective"}, \code{"column"}, \code{"total"}, or \code{NA}. #' @param impute Logical (length 1). Run RAISS imputation against the -#' \code{ldSketch}. Default \code{FALSE}. (Note: RAISS against the sketch is -#' not yet fully wired for the new path; the option is accepted but currently -#' emits a warning and is skipped.) -#' @param imputeArgs RAISS settings, built with \code{\link{RaissParam}}. +#' \code{ldReference}'s genotype panel as the last QC step, adding z-scores +#' for panel variants the input lacks (see \code{raissParam}). The audit +#' records how many variants were imputed. Default \code{FALSE}. +#' @param raissParam RAISS settings, built with \code{\link{RaissParam}}. #' A bare list is refused, since it cannot be checked. #' #' RAISS imputation scopes its reference panel to the analysis-region window -#' (so a per-chromosome / genome-wide \code{ldSketch} does not materialize +#' (so a per-chromosome / genome-wide \code{ldReference} does not materialize #' its full dosage); \code{flank} widens that window by the given number of #' base pairs on each side to retain LD context for edge variants. #' @@ -5390,7 +5532,7 @@ effectiveN <- function(nCase, nControl) { #' the panel handed to RAISS holds nothing below those. Use them to impute #' only common variants from a panel deliberately kept wider than that --- #' e.g. \code{mafCutoff = 0.001} with -#' \code{imputeArgs = RaissParam(mafCutoff = 0.01)}. A variant present in +#' \code{raissParam = RaissParam(mafCutoff = 0.01)}. A variant present in #' the sumstats is never dropped here: RAISS derives its LD basis from those #' same panel rows. #' @@ -5398,12 +5540,12 @@ effectiveN <- function(nCase, nControl) { #' are forwarded to \code{\link{raiss}} itself. #' @param matchMinProp Minimum proportion of LD panel variants that must be #' matched by the sumstats; default 0. -#' @param sumstatsCleaningArgs What makes a row a well-formed record, built with -#' \code{\link{SumstatsCleaningParam}}: \code{coerceNumeric}, +#' @param sumstatsCleaningParam What makes a row a well-formed record, built +#' with \code{\link{SumstatsCleaningParam}}: \code{coerceNumeric}, #' \code{normalizeChr} / \code{dropNonstandardChr}, \code{dropMissData}, #' \code{dropPOutOfRange}, \code{clampSmallP} / \code{smallPFloor}, #' \code{dropZeroEffect} and \code{dropNonpositiveSe}. Applied before any -#' filter or screen. Distinct from \code{sumstatsFilter}, which applies +#' filter or screen. Distinct from \code{sumstatsFilterParam}, which applies #' quality thresholds to rows that are already well formed. #' @return A new \code{QtlSumStats} / \code{GwasSumStats} with cleaned entries #' and \code{qcInfo} populated. @@ -5413,55 +5555,44 @@ effectiveN <- function(nCase, nControl) { #' @export summaryStatsQc <- function( sumstats, - sumstatsFilterArgs = SumstatsFilterParam(), + sumstatsFilterParam = SumstatsFilterParam(), panelFilterParam = PanelFilterParam(), keepVariants = NULL, skipRegion = NULL, - signalScreenArgs = SignalScreenParam(), + signalScreenParam = SignalScreenParam(), ldMismatchQcMethod = c("none", "slalom", "dentist"), alleleFlipKriging = FALSE, effectiveN = TRUE, impute = FALSE, - imputeArgs = RaissParam(), + raissParam = RaissParam(), matchMinProp = 0, - sumstatsCleaningArgs = SumstatsCleaningParam() + sumstatsCleaningParam = SumstatsCleaningParam() ) { r <- .ssqcResolveInputs( sumstats, - sumstatsFilterArgs, + sumstatsFilterParam, panelFilterParam, - signalScreenArgs, - sumstatsCleaningArgs, - imputeArgs, + signalScreenParam, + sumstatsCleaningParam, + raissParam, ldMismatchQcMethod ) opts <- .ssqcBuildOpts( - sumstatsFilterArgs = sumstatsFilterArgs, + sumstatsFilterParam = sumstatsFilterParam, panelFilterParam = panelFilterParam, skipRegion = skipRegion, ldMismatchQcMethod = r$ldMismatchQcMethod, alleleFlipKriging = alleleFlipKriging, effectiveN = effectiveN, impute = impute, - imputeArgs = r$imputeArgs, + raissParam = r$raissParam, matchMinProp = matchMinProp, - sumstatsCleaningArgs = r$cleaning, + sumstatsCleaningParam = r$cleaning, keepVariants = keepVariants, - signalScreenArgs = signalScreenArgs + signalScreenParam = signalScreenParam ) res <- .ssqcRunEntries(sumstats, opts) - .ssqcAssemble( - sumstats, - res, - sumstatsFilterArgs = sumstatsFilterArgs, - panelFilterParam = panelFilterParam, - signalScreenArgs = signalScreenArgs, - ldMismatchQcMethod = r$ldMismatchQcMethod, - alleleFlipKriging = alleleFlipKriging, - effectiveN = effectiveN, - impute = impute, - cleaning = r$cleaning - ) + .ssqcAssemble(sumstats, res, opts, signalScreenParam) } # Validate every bundle and resolve the three that have a resolved form: @@ -5471,59 +5602,47 @@ summaryStatsQc <- function( # @noRd .ssqcResolveInputs <- function( sumstats, - sumstatsFilterArgs, + sumstatsFilterParam, panelFilterParam, - signalScreenArgs, - sumstatsCleaningArgs, - imputeArgs, + signalScreenParam, + sumstatsCleaningParam, + raissParam, ldMismatchQcMethod ) { .assertMethodParam( - sumstatsFilterArgs, - "SumstatsFilterParam", - "sumstatsFilter" + sumstatsFilterParam, + "SumstatsFilterParam" ) - .assertMethodParam(panelFilterParam, "PanelFilterParam", "panelFilter") - .assertMethodParam(signalScreenArgs, "SignalScreenParam", "signalScreen") - .assertMethodParam(imputeArgs, "RaissParam", "imputeArgs") - .ssqcCheckEntries(sumstats, sumstatsFilterArgs$infoCutoff) + .assertMethodParam(panelFilterParam, "PanelFilterParam") + .assertMethodParam(signalScreenParam, "SignalScreenParam") + .assertMethodParam(raissParam, "RaissParam") + .ssqcCheckEntries(sumstats, sumstatsFilterParam$infoCutoff) .ssqcCheckPanelCutoffs(panelFilterParam) list( ldMismatchQcMethod = .resolveLdMismatchChoice(ldMismatchQcMethod), - cleaning = .sumstatsCleaningResolve(sumstatsCleaningArgs), - imputeArgs = .ssqcResolveImputeArgs(imputeArgs) + cleaning = .sumstatsCleaningResolve(sumstatsCleaningParam), + raissParam = .ssqcResolveImputeArgs(raissParam) ) } # The QC record and the rebuilt object around the filtered entries. # @noRd -.ssqcAssemble <- function( - sumstats, - res, - sumstatsFilterArgs, - panelFilterParam, - signalScreenArgs, - ldMismatchQcMethod, - alleleFlipKriging, - effectiveN, - impute, - cleaning -) { +.ssqcAssemble <- function(sumstats, res, opts, signalScreenParam) { qcInfo <- .ssqcBuildQcInfo( res$entryAudits, - sumstatsFilterArgs = sumstatsFilterArgs, - panelFilterParam = panelFilterParam, - signalScreenArgs = signalScreenArgs, - ldMismatchQcMethod = ldMismatchQcMethod, - alleleFlipKriging = alleleFlipKriging, - effectiveN = effectiveN, - impute = impute, - sumstatsCleaningArgs = cleaning + sumstatsFilterParam = opts$sumstatsFilterParam, + panelFilterParam = opts$panelFilterParam, + signalScreenParam = signalScreenParam, + ldMismatchQcMethod = opts$ldMismatchQcMethod, + alleleFlipKriging = opts$alleleFlipKriging, + effectiveN = opts$effectiveN, + impute = opts$impute, + sumstatsCleaningParam = opts$sumstatsCleaningParam ) # From the PRUNED panel, not the input's: narrowing the original again # would hand back a sketch the panel filter never reached. - newLdSketch <- .subsetSketchToIds(res$ldSketch, res$newEntries) - .ssqcRebuild(sumstats, res$newEntries, newLdSketch, qcInfo) + newLdReference <- .subsetLdRefToIds(res$ldReference, res$newEntries) + .ssqcRebuild(sumstats, res$newEntries, newLdReference, qcInfo) } # ---- slidingWindowLoop callbacks (distance mode) ------------------------ @@ -5802,21 +5921,20 @@ SumstatsCleaningParam <- function( # .assertMethodOptions accepts `list()` as "no options", and .applySanityChecks # tests these with `if (!flag)`, so a missing field must not arrive as NULL. # @noRd -.sumstatsCleaningResolve <- function(sumstatsCleaningArgs) { +.sumstatsCleaningResolve <- function(sumstatsCleaningParam) { .assertMethodParam( - sumstatsCleaningArgs, - "SumstatsCleaningParam", - "sumstatsCleaning" + sumstatsCleaningParam, + "SumstatsCleaningParam" ) list( - coerceNumeric = sumstatsCleaningArgs$coerceNumeric %||% TRUE, - normalizeChr = sumstatsCleaningArgs$normalizeChr %||% TRUE, - dropNonstandardChr = sumstatsCleaningArgs$dropNonstandardChr %||% TRUE, - dropMissData = sumstatsCleaningArgs$dropMissData %||% TRUE, - dropPOutOfRange = sumstatsCleaningArgs$dropPOutOfRange %||% TRUE, - clampSmallP = sumstatsCleaningArgs$clampSmallP %||% TRUE, - smallPFloor = sumstatsCleaningArgs$smallPFloor %||% 5e-324, - dropZeroEffect = sumstatsCleaningArgs$dropZeroEffect %||% TRUE, - dropNonpositiveSe = sumstatsCleaningArgs$dropNonpositiveSe %||% TRUE + coerceNumeric = sumstatsCleaningParam$coerceNumeric %||% TRUE, + normalizeChr = sumstatsCleaningParam$normalizeChr %||% TRUE, + dropNonstandardChr = sumstatsCleaningParam$dropNonstandardChr %||% TRUE, + dropMissData = sumstatsCleaningParam$dropMissData %||% TRUE, + dropPOutOfRange = sumstatsCleaningParam$dropPOutOfRange %||% TRUE, + clampSmallP = sumstatsCleaningParam$clampSmallP %||% TRUE, + smallPFloor = sumstatsCleaningParam$smallPFloor %||% 5e-324, + dropZeroEffect = sumstatsCleaningParam$dropZeroEffect %||% TRUE, + dropNonpositiveSe = sumstatsCleaningParam$dropNonpositiveSe %||% TRUE ) } diff --git a/R/tupleSelectors.R b/R/tupleSelectors.R index 094ef3408..70e718088 100644 --- a/R/tupleSelectors.R +++ b/R/tupleSelectors.R @@ -1,7 +1,7 @@ # ============================================================================= # Tuple row matchers # ----------------------------------------------------------------------------- -# Internal helpers shared by the FineMappingResult / TwasWeights / SumStats +# Internal helpers shared by the fine-mapping result / TwasWeights / SumStats # collections to resolve a tuple-keyed selection to a single row index. Every # collection is a RangedTupleList, so these read identity columns off mcols # and payloads off the elements -- there is no second shape to branch on. @@ -398,14 +398,14 @@ } # Internal: append a validated `region` GRanges to a constructor's column list -# (no-op when NULL). Shared by the TwasWeights / FineMappingResult +# (no-op when NULL). Shared by the TwasWeights / FineMappingResultBase # constructors so the provenance column is added identically everywhere. # Internal: an optional per-row provenance column. One helper for all three # (`dataType`, `dataSource`, `standardized`) since they differ only in name and # coercion. # # `dataSource` is per ROW, not per collection: it used to be derived from the -# collection's single `ldSketch` slot, so after combineFineMappingResults() +# collection's single `ldReference` slot, so after combineFineMappingResults() # folded individual-level and RSS-derived fits together every row got the # combined object's answer. # @@ -426,11 +426,6 @@ c(cols, set_names(list(rep(v, length.out = n)), nm)) } -# @noRd -.appendDataTypeCol <- function(cols, dataType, n) { - .appendProvenanceCol(cols, dataType, "dataType", n) -} - # @noRd .appendFmProvenanceCols <- function( cols, @@ -458,7 +453,7 @@ } # Internal: validate the optional `region` GRanges column (one range per row), -# shared by the TwasWeights / FineMappingResult validity methods. Returns a +# shared by the TwasWeights / FineMappingResultBase validity methods. Returns a # character vector of errors (empty when valid or the column is absent). .validateRegionColumn <- function(object) { if (!is_in("region", .tupleColumnNames(object))) { @@ -554,23 +549,23 @@ } # Internal: row-bind two or more per-tuple collection objects (TwasWeights / -# FineMappingResult subclasses), carrying forward EVERY column. Columns are +# FineMappingResultBase subclasses), carrying forward EVERY column. Columns are # unioned, and a collection lacking an optional column (e.g. jointContexts or # region) is padded with `.naLikeColumn` -- so adding a column to a class flows # through combines automatically rather than being hand-listed at each site. -# Preserves the concrete class and sets the `ldSketch` slot explicitly (rbind +# Preserves the concrete class and sets the `ldReference` slot explicitly (rbind # does not reliably carry it). Returns NULL when given no inputs. Every # collection is a RangedTupleList now, so this only drops the NULL parts and # hands off; the old DFrame path went with the rebase onto GRangesList. # # `slots` carries the collection-level state a concrete subclass adds beyond -# `ldSketch` (SumStatsBase's `genome` / `qcInfo`). It is passed in rather than -# read off `parts[[1L]]` because those slots describe the WHOLE collection, so -# merging them is the caller's decision -- first-wins would silently drop the +# `ldReference` (SumStatsBase's `genome` / `qcInfo`). It is passed in rather +# than read off `parts[[1L]]` because those slots describe the WHOLE collection, +# so merging them is the caller's decision -- first-wins would silently drop the # other parts' QC audit. .rbindCollections <- function( parts, - ldSketch = NULL, + ldReference = NULL, slots = list(), genome = NULL ) { @@ -578,7 +573,7 @@ if (length(parts) == 0L) { return(NULL) } - .rbindRangedCollections(parts, ldSketch, slots, genome) + .rbindRangedCollections(parts, ldReference, slots, genome) } # Internal: aggregate a per-entry accessor across every row of a @@ -706,7 +701,7 @@ .fmrEntryPart <- function(i, x, perEntry, meta, viewArgs) { # `perEntry` is an internal per-row function taking the stored payload, not # an S4 generic dispatching on a rebuilt entry. That indirection is what - # the FineMappingRow class existed for. + # the retired FineMappingEntry class existed for. raw <- exec(perEntry, .fmrRowParts(x, i), !!!viewArgs) if (is.null(raw) || nrow(raw) == 0L) { return(NULL) @@ -737,8 +732,6 @@ } } -# Concatenate column `cn` across all parts (NA-filling parts that lack it). -# @noRd # Row-binding a collection: the elements append and the mcols rbind. # # S4Vectors::combineRows() does the union-with-NA-fill this needs, but it @@ -749,7 +742,7 @@ # @noRd .rbindRangedCollections <- function( parts, - ldSketch, + ldReference, slots = list(), genome = NULL ) { @@ -775,12 +768,14 @@ methods::new, cls, grl, - !!!c(list(ldSketch = ldSketch), slots) + !!!c(list(ldReference = ldReference), slots) ) validObject(out) out } +# Concatenate column `cn` across all parts (NA-filling parts that lack it). +# @noRd .rbindColumn <- function(cn, parts) { pieces <- map(parts, .rbindColPiece, cn = cn, parts = parts) # GRanges concat may warn on seqinfo. @@ -790,7 +785,7 @@ # ============================================================================= # Per-row primitives # ----------------------------------------------------------------------------- -# The per-row views a collection projects. These replace the FineMappingRow +# The per-row views a collection projects. These replace the FineMappingEntry # S4 class, which existed only to be the DISPATCH TARGET for exactly this work: # a collection method would rebuild an entry for each row and call the exported # generic on it. That indirection cost a whole class, a validity method and a @@ -819,11 +814,6 @@ ) } -# The same, for a set of rows collapsed into one logical entry (a multi-block -# row group). The fit payload comes from the first row, matching the previous -# .fmeEntryFromRows behaviour. -# @noRd - # @noRd .fmrPartsVariantIds <- function(parts) { variantIds(.asFmRowPayload(parts)) @@ -845,7 +835,7 @@ } # ---- per-row views ---------------------------------------------------------- -# Each of these is the body of what used to be a FineMappingRow method, +# Each of these is the body of what used to be a FineMappingEntry method, # reading the stored form through `parts` instead of through S4 slots. They are # what .fmrAggregateView() maps over. @@ -1024,7 +1014,7 @@ list(variantIds = vids[ok], weights = w[ok]) } -# Class-aware row payload: the TwasWeights and FineMappingResult shapes differ +# Class-aware row payload: the TwasWeights and fine-mapping shapes differ # (weights vs a susie fit), so callers that accept either weight source route # through here. Replaces the old .collectionEntry bridge. # @noRd @@ -1051,7 +1041,7 @@ # A fine-mapping row deliberately reports NULL: cTWAS would otherwise # renormalize alpha into an UNstandardized weight, which is inconsistent with # the standardized posterior effect the topLoci view already carries. Preserved -# verbatim from the FineMappingRow methodFits method. +# verbatim from the retired FineMappingEntry methodFits method. # @noRd .rowFits <- function(parts) { if (methods::is(parts, "TwasWeightsRow")) methodFits(parts) else NULL @@ -1070,15 +1060,12 @@ TRUE } -# ---- row-payload builders --------------------------------------------------- -# What callers use in place of the retired FineMappingRow / TwasWeightsRow -# constructors. Same arguments, but they return the STORED form directly -- a -# plain list holding one GRanges plus the fit payload -- so nothing has to be -# converted on the way into a collection. +# ---- row-payload normalizers ------------------------------------------------ +# The per-row views read a FineMappingRow / TwasWeightsRow. Callers may also +# hold a single-row collection -- what fineMappingResult() returns -- so these +# accept either and hand back the row. -# Accept either a row payload (the stored form) or a legacy entry object, so -# the constructors can be flipped independently of their ~300 call sites. -# Delete the entry branch once nothing constructs entries. +# A FineMappingRow from a row or from a fine-mapping collection's rows. # @noRd .asFmRowPayload <- function(e) { # A single-row collection is the other shape callers hand over -- it is @@ -1120,8 +1107,6 @@ abort(msg) } -# @noRd - # Shape-tolerant readers for values that may still be a legacy entry object # while the flip is in progress. Delete the entry branch (and these) once # nothing produces entries. @@ -1155,7 +1140,7 @@ # ============================================================================= # Combining summary-statistics collections # ----------------------------------------------------------------------------- -# A SumStatsBase subclass carries three COLLECTION-level slots -- ldSketch, +# A SumStatsBase subclass carries three COLLECTION-level slots -- ldReference, # genome and qcInfo -- on top of the elements and their mcols, so row-binding # per-block pieces back into one collection has to say what happens to each. # The rules live here once, shared by combineGwasSumStats() and @@ -1165,9 +1150,9 @@ # qcInfo `entryAudit` concatenates in element order (it is indexed BY # element); the rest is carried from the first part after checking # the QC options agree -# ldSketch the panels union, read through the parts' shared GenotypeHandle +# ldReference the panels union, read through the parts' shared GenotypeHandle # -# The ldSketch rule is the one that matters for correctness. A block-parallel +# The ldReference rule is the one that matters for correctness. A block-parallel # pipeline narrows each piece's panel to that block, so first-wins would hand # back a collection spanning every block whose LD reference covers only the # first -- and cTWAS computes its full-panel LD from exactly that slot. @@ -1192,14 +1177,14 @@ invisible(NULL) } -# The collection-level slots BEYOND ldSketch that a combine has to merge, for +# The collection-level slots BEYOND ldReference that a combine has to merge, for # whatever concrete class `parts` are. A slot describes the whole collection, # so first-wins would silently drop the other parts' state; each gets its own # rule and an unrecognised slot is an error rather than a quiet default, so # adding one to a class cannot slip through a combine unnoticed. # @noRd .rtlExtraSlots <- function(parts, fn) { - own <- setdiff(.rtlOwnSlots(parts[[1L]]), "ldSketch") + own <- setdiff(.rtlOwnSlots(parts[[1L]]), "ldReference") out <- compact(list( qcInfo = if (is_in("qcInfo", own)) .ssCombineQcInfo(parts, fn) )) @@ -1217,9 +1202,9 @@ # Merge `parts` into one collection, reconciling every collection-level slot. # The single path behind `c()` / `append()` and the four combine*() wrappers. -# A non-NULL `ldSketch` overrides the unioned panel. +# A non-NULL `ldReference` overrides the unioned panel. # @noRd -.combineTupleCollections <- function(parts, ldSketch, fn) { +.combineTupleCollections <- function(parts, ldReference, fn) { .rtlRequireSameClass(parts, fn) # Forced before the rebuild: GRangesList() merges seqinfo and rejects # mismatched builds itself, with a message about sequence-level genomes @@ -1227,7 +1212,7 @@ genome <- .rtlCombineGenome(parts, fn) .rbindCollections( parts, - ldSketch = ldSketch %||% .combineLdSketch(parts, fn), + ldReference = ldReference %||% .combineLdRef(parts, fn), slots = .rtlExtraSlots(parts, fn), genome = genome ) @@ -1244,10 +1229,10 @@ } # Row-bind summary-statistics parts, merging the three collection-level slots. -# `ldSketch` (when non-NULL) overrides the unioned panel. +# `ldReference` (when non-NULL) overrides the unioned panel. # @noRd -.rbindSumStats <- function(parts, ldSketch, fn) { - .combineTupleCollections(parts, ldSketch, fn) +.rbindSumStats <- function(parts, ldReference, fn) { + .combineTupleCollections(parts, ldReference, fn) } # One genome build per collection (every entry shares the LD sketch), so the @@ -1340,8 +1325,8 @@ # collection has no panel); a mix is an error, because silently keeping the # panels that exist would leave elements harmonized against nothing. # @noRd -.combineLdSketch <- function(parts, fn) { - sketches <- map(parts, ldSketch) +.combineLdRef <- function(parts, fn) { + sketches <- map(parts, ldReference) present <- !map_lgl(sketches, is.null) if (!any(present)) { return(NULL) @@ -1349,40 +1334,161 @@ if (!all(present)) { msg <- glue( "{fn}: {sum(!present)} of {length(parts)} inputs carry no ", - "ldSketch. Combine collections that all have an LD reference, or ", - "all have none." + "ldReference. Combine collections that all have an LD reference, ", + "or all have none." ) abort(msg) } - handles <- map(sketches, .ldSketchHandle) - .ssCheckSameSource(handles, fn) + if (any(map_lgl(sketches, .ldIsMatrixRef))) { + return(.combineLdMatrixRefs(sketches, fn)) + } + if (any(map_lgl(sketches, .ldIsMixtureRef))) { + return(.combineMixtureRefs(sketches, fn)) + } + .ssCheckSameSource(sketches, fn) + chromPaths <- .ssUnionChromPaths(sketches, fn) + handles <- map(sketches, .ldRefHandle) + if (any(map_lgl(handles, is.null))) { + return(.ssUnionPanels(sketches, chromPaths)) + } handle <- methods::initialize( handles[[1L]], snpInfo = .ssUnionSnpInfo(handles), - chromPaths = .ssUnionChromPaths(handles, fn) + chromPaths = chromPaths ) - .asLdSketch(handle) + .asLdRef(handle) } -# Union the per-chromosome shard paths across handles. Two sketches trimmed -# from one genoMeta panel to different chromosomes share path/format/samples -# and differ ONLY here, so unioning is what lets their snpInfo rows keep -# routing: a row reaches its file by its own CHR. One chromosome mapping to -# two different files means the parts are not the same panel after all. +# The union of panels from one source that read through no handle -- a VCF, +# GDS or PLINK1 panel, or a per-chromosome set of them: their rows, each +# once, in genomic order, over the first panel's samples. The parts' assays +# are bound, not read. Parts that are all the same panel union to it. # @noRd -.ssUnionChromPaths <- function(handles, fn) { - combined <- .ssConcatChr(map(handles, .ssHandleChromPaths)) +.ssUnionPanels <- function(panels, chromPaths) { + first <- panels[[1L]] + if (all(map_lgl(map(panels, rownames), identical, rownames(first)))) { + return(first) + } + rr <- suppressWarnings( + exec(c, !!!unname(map(panels, SummarizedExperiment::rowRanges))) + ) + stacked <- SummarizedExperiment::SummarizedExperiment( + assays = list( + dosage = exec( + BiocGenerics::rbind, + !!!unname(map(panels, .seDosage)) + ) + ), + rowRanges = rr, + colData = SummarizedExperiment::colData(first), + metadata = S4Vectors::metadata(first) + ) + kept <- which(!duplicated(names(rr))) + ord <- kept[order( + canonChrom(as.character(seqnames(rr)[kept])), + start(rr)[kept] + )] + md <- S4Vectors::metadata(stacked) + if (!is.null(md$genotypeSource)) { + md$genotypeSource$chromPaths <- chromPaths + } + S4Vectors::`metadata<-`(stacked[ord, ], value = md) +} + +# LdMatrix references, unlike panels, cannot be unioned: the LD between +# variants held by different parts is recorded in neither. They combine only +# when one of them already holds every other's variants with the same LD -- +# the same matrix, or one part that kept all of the others' variants. +# Otherwise the caller passes the matrix covering them all as `ldReference`. +# @noRd +.combineLdMatrixRefs <- function(refs, fn) { + if (!all(map_lgl(refs, .ldIsMatrixRef))) { + msg <- glue( + "{fn}: inputs mix genotype-panel and LdMatrix references; ", + "combine collections that share one LD reference." + ) + abort(msg) + } + widest <- refs[[which.max(map_int(refs, length))]] + if (all(map_lgl(refs, .ldmCoveredBy, by = widest))) { + return(widest) + } + abort(c( + glue( + "{fn}: the inputs' LdMatrix references cover different variants, ", + "and the LD between them is held by none." + ), + i = "Pass an LdMatrix covering all of their variants as `ldReference`." + )) +} + +# Mixture references combine like LdMatrix ones: when one of them already +# holds every other's variants and they average the same panels with the +# same weights. Their panels stay lazy, so the widest mixture loses nothing. +# @noRd +.combineMixtureRefs <- function(refs, fn) { + if (!all(map_lgl(refs, .ldIsMixtureRef))) { + msg <- glue( + "{fn}: inputs mix GenotypeMixture references with other kinds; ", + "combine collections that share one LD reference." + ) + abort(msg) + } + widest <- refs[[which.max(map_int(refs, .ldRefNVariants))]] + sameMix <- map_lgl(refs, .gmSameMixture, y = widest) + covered <- map_lgl(refs, .ldRefVariantsCoveredBy, by = widest) + if (all(sameMix & covered)) { + return(widest) + } + abort(c( + glue( + "{fn}: the inputs' GenotypeMixture references differ or cover ", + "different variants." + ), + i = "Pass the mixture covering all of their variants as `ldReference`." + )) +} + +# TRUE when every variant of `x` is in `by`, coded the same way. +# @noRd +.ldRefVariantsCoveredBy <- function(x, by) { + m <- matchVariants( + .ldRefMatchIds(x), + .ldRefMatchIds(by), + removeStrandAmbiguous = FALSE + ) + length(m$idxA) == .ldRefNVariants(x) && all(m$sign > 0) +} + +# TRUE when every variant of `x` is in `by`, coded the same way, with the +# same LD. +# @noRd +.ldmCoveredBy <- function(x, by) { + m <- matchVariants( + .ldRefMatchIds(x), + .ldRefMatchIds(by), + removeStrandAmbiguous = FALSE + ) + length(m$idxA) == length(x) && + all(m$sign > 0) && + .ldmAgreesOn(x, by, m$idxA, m$idxB) +} + +# Union the per-chromosome shard paths across LD references (panels, or +# bare handles). Two sketches trimmed from one genoMeta panel to different +# chromosomes share path/format/samples and differ ONLY here, so unioning is +# what lets their rows keep routing: a row reaches its file by its own CHR. +# One chromosome mapping to two different files means the parts are not the +# same panel after all. +# @noRd +.ssUnionChromPaths <- function(refs, fn) { + combined <- .ssConcatChr(map(refs, .ldRefChromPaths)) byChrom <- split(unname(combined), names(combined)) walk2(names(byChrom), byChrom, .ssCheckOneFilePerChrom, fn = fn) # Every chromosome agrees, so the first mapping stands for all of them. combined[!duplicated(names(combined))] } -# @noRd -.ssHandleChromPaths <- function(h) { - h@chromPaths -} - # @noRd .ssConcatChr <- function(pieces) { if (length(pieces) == 0L) { @@ -1400,41 +1506,48 @@ } msg <- glue( "{fn}: chromosome '{ch}' maps to two different genotype ", - "files across the inputs, so their LD sketches cannot ", + "files across the inputs, so their LD references cannot ", "be unioned." ) abort(msg) } -# Every panel must read from the same file(s): the union keeps the first -# handle and widens its snpInfo, and each row's `fileIdx` addresses a position -# in THAT file, so rows from another panel would read the wrong variants. +# Every panel must read from the same file(s) and samples: a handle union +# keeps the first handle and widens its snpInfo, each row's `fileIdx` +# addressing a position in THAT file, and a panel union binds the parts over +# the first one's samples. # @noRd -.ssCheckSameSource <- function(handles, fn) { - same <- map_lgl(handles, .ssSameGenotypeSource, first = handles[[1L]]) +.ssCheckSameSource <- function(sketches, fn) { + same <- map_lgl(sketches, .ssSameGenotypeSource, first = sketches[[1L]]) if (all(same)) { return(invisible(NULL)) } msg <- glue( "{fn}: inputs reference different genotype panels (input ", - "{which(!same)[[1L]]} differs from the first). Their LD sketches ", + "{which(!same)[[1L]]} differs from the first). Their LD references ", "cannot be unioned." ) abort(msg) } # @noRd -.ssSameGenotypeSource <- function(h, first) { +.ssSameGenotypeSource <- function(x, first) { # chromPaths is deliberately NOT compared: two sketches trimmed from the # same genoMeta panel to different chromosomes differ there and nowhere # else, and .ssUnionChromPaths() merges them (erroring on a genuine # conflict). Everything below must match for the union to mean anything -- - # snpInfo rows carry file POSITIONS, which only make sense against the - # same files and the same sample axis. - identical(h@path, first@path) && - identical(h@format, first@format) && - identical(h@nSamples, first@nSamples) && - identical(h@sampleIds, first@sampleIds) + # rows address the same files, over the same sample axis. + a <- .ldRefSource(x) + b <- .ldRefSource(first) + identical(a$path, b$path) && + identical(a$format, b$format) && + identical(.ssSampleIds(x), .ssSampleIds(first)) +} + +# An LD reference's samples: a panel's columns, a bare handle's sample ids. +# @noRd +.ssSampleIds <- function(x) { + if (methods::is(x, "GenotypeHandle")) sampleIds(x) else colnames(x) } # The parts' snpInfo rows, de-duplicated by variant id and returned in genomic diff --git a/R/twasWeights.R b/R/twasWeights.R index 0fcc17316..6d05440bb 100644 --- a/R/twasWeights.R +++ b/R/twasWeights.R @@ -26,7 +26,7 @@ # DFrame-subclass collection keyed by the identity tuple (study, context, # trait, method). Each row holds a TwasWeightsRow payload (variant ids # + per-variant weight vector/matrix). Class-level slots: -# * ldSketch GenotypeHandle (NULL for individual-level fits, the +# * ldReference GenotypeHandle (NULL for individual-level fits, the # LD-sketch handle for RSS-derived weights). # Constructor + accessors below. The twasWeights pipeline helpers # (learnTwasWeights, CV, ensemble, etc.) follow at the bottom. @@ -52,21 +52,22 @@ NULL #' column lists the semicolon-joined members of the joined axis. For non-joint #' rows the joint columns are \code{NA_character_}. Tuple uniqueness is enforced #' jointly across the identity-tuple columns and any present joint columns. -#' @slot ldSketch The LD reference genotype panel the weights were -#' derived against, or \code{NULL} when the weights were learned from -#' individual-level data. Used downstream for cross-pipeline LD-sketch -#' identity validation. +#' @slot ldReference The LD reference the weights were derived against (a +#' genotype panel, a \code{GenotypeMixture} or an \code{LdMatrix}), or +#' \code{NULL} when the weights were learned from individual-level data. +#' Used downstream to check that pipelines combining results share one LD +#' reference. #' @export setClass( "TwasWeights", contains = "RangedTupleList", - representation(ldSketch = "LdSketch_OR_NULL"), + representation(ldReference = "LdReference_OR_NULL"), validity = function(object) .validateTwasWeights(object) ) # Validity for the TwasWeights collection: required columns, entry payloads, # region/traitPos provenance, joint* column types, tuple uniqueness, and the -# optional ldSketch. Returns TRUE or a character vector of error messages. +# optional ldReference. Returns TRUE or a character vector of error messages. # @noRd #' @importFrom checkmate makeAssertCollection assertNames .validateTwasWeights <- function(object) { @@ -170,7 +171,7 @@ setClass( #' shape as \code{jointStudies}. #' @param jointTraits Optional character vector for cross-trait joints. Same #' shape as \code{jointStudies}. -#' @param ldSketch An optional genotype panel (see +#' @param ldReference An optional genotype panel (see #' \code{\link{readGenotypes}}), or \code{NULL} for individual-level fits. #' @param traitPos Optional per-row trait genomic anchor (a \code{GRanges} or #' \code{NULL}), carried forward as provenance; not part of the identity key. @@ -202,7 +203,7 @@ TwasWeights <- function( jointTraits = NULL, traitPos = NULL, region = NULL, - ldSketch = NULL + ldReference = NULL ) { .twasAssertArgs( studyName, @@ -230,13 +231,7 @@ TwasWeights <- function( region, n ) - obj <- new( - "TwasWeights", - .rtlGrlWithMetadata(entry, cols), - ldSketch = .asLdSketch(ldSketch) - ) - validObject(obj) - obj + .rtlNewValidated("TwasWeights", entry, cols, ldReference) } # The identity and joint-axis arguments, checked. Mirrors @@ -302,24 +297,11 @@ TwasWeights <- function( .appendRegionCol(.appendTraitPosCol(withJoint, traitPos, n), region, n) } -# One entry -> its element: the variants as a GRanges, with the per-variant -# weights carried in the element's own mcols alongside the alleles. -# @noRd - -# The non-variant half of each entry, as outer mcols columns. Objects of -# arbitrary shape (fits, cvResult, dataType) ride in SimpleLists. -# @noRd - # @noRd .twPayloadStandardized <- function(p) { weightStandardized(p) } -# Every `entry` must be a TwasWeightsRow. Checked before the payload is -# unpacked, so a wrong type reports itself rather than surfacing as a missing -# method on whatever was passed instead. -# @noRd - # Require study/context/trait/method/entry to share one length; returns it. # @noRd .twasCheckRowLengths <- function(studyName, context, trait, method, entry) { @@ -432,15 +414,6 @@ setMethod( mcols(x[[i]])$weight } -# Rebuild the TwasWeightsRow for a tuple from its stored element(s). -# -# The entry is a DERIVED VIEW, not stored state: the variants live in the -# element, the weights in that element's mcols, and the rest of the payload in -# the collection's mcols. A tuple split across chromosomes owns several -# elements, so they are stitched back into the single entry callers expect -- -# the same contract sumStats() keeps. -# @noRd - # The row payload a (study, context, trait, method) selector pins. # # Read directly rather than via twasWeights(): that accessor returns a @@ -609,9 +582,9 @@ setMethod( #' @export setMethod("studyName", "TwasWeights", function(x) unique(as.character(x$study))) -#' @rdname ldSketch +#' @rdname ldReference #' @export -setMethod("ldSketch", "TwasWeights", function(x) x@ldSketch) +setMethod("ldReference", "TwasWeights", function(x) x@ldReference) #' @rdname contexts #' @export @@ -645,12 +618,12 @@ setMethod("show", "TwasWeights", function(object) { .trim = FALSE )) } - ldSrc <- if (is.null(object@ldSketch)) { + ldSrc <- if (is.null(object@ldReference)) { "NULL (individual-level fit)" } else { - .ldSketchLabel(object@ldSketch) + .ldRefLabel(object@ldReference) } - cat(glue(" LD sketch: {ldSrc}\n", .trim = FALSE)) + cat(glue(" LD reference: {ldSrc}\n", .trim = FALSE)) }) @@ -715,7 +688,7 @@ setMethod("show", "TwasWeights", function(object) { mrash = list( fn = "mrash_weights", impl = "mrashWeights", - args = list(initPriorSd = TRUE, max.iter = 100) + args = list(max.iter = 100) ), enet = list(fn = "enet_weights", impl = "enetWeights", args = list()), lasso = list( @@ -857,7 +830,7 @@ setMethod("show", "TwasWeights", function(object) { # fit enters -- not by reading the sources, which hides forwarding behind # list_modify()/exec() and imported-without-:: calls. test_twasWeights.R # re-traces them and fails if one drifts. -# @noRd + # Which wrapper and engine each TWAS weight method actually reaches. Split # by data path because the two share almost nothing: a method's individual # and summary-statistic routes usually run different engines entirely, and @@ -909,7 +882,12 @@ setMethod("show", "TwasWeights", function(object) { } # Summary statistics: each chain ends in pecotmr's own RSS solver or an -# upstream *.rss entry point, never the individual-level engine. +# upstream *.rss entry point, never the individual-level engine. pecotmr's +# solvers are reached through their LD-source paths (.penalizedRssPath(), +# .lassosumRssPath(), .prsCsRun(), .sdprRun()), which take the options of +# penalizedRss(), lassosumRss(), prsCs() and sdpr() under the same names, so +# a genotype reference can be used through its factor without forming the LD +# matrix. # @noRd .twasMethodChainsSumstat <- function() { list( @@ -917,26 +895,26 @@ setMethod("show", "TwasWeights", function(object) { "scadRssWeights", ".penalizedRssWeights", ".rssShrinkGridWeights", - "penalizedRss" + ".penalizedRssPath" ), mcp = c( "mcpRssWeights", ".penalizedRssWeights", ".rssShrinkGridWeights", - "penalizedRss" + ".penalizedRssPath" ), l0learn = c( "l0learnRssWeights", ".rssShrinkGridWeights", - "penalizedRss" + ".penalizedRssPath" ), lasso = c( "lassosumRssWeights", ".rssShrinkGridWeights", - "lassosumRss" + ".lassosumRssPath" ), - prsCs = c("prsCsWeights", "prsCs"), - dprGibbs = c("sdprWeights", "sdpr"), + prsCs = c("prsCsWeights", ".prsCsRun"), + dprGibbs = c("sdprWeights", ".sdprRun"), mrash = c("mrashRssWeights", "susieR::mr.ash.rss"), mrmash = c( "mrmashRssWeights", @@ -964,7 +942,9 @@ setMethod("show", "TwasWeights", function(object) { "Y", "y", "stat", + "ldReference", "LD", + "ld", "bhat", "shat", "R", @@ -994,7 +974,7 @@ setMethod("show", "TwasWeights", function(object) { fn <- if (str_detect(nm, fixed("::"))) { .engineCallee(nm) } else { - tryCatch( + try_fetch( get(nm, envir = asNamespace("pecotmr")), error = function(cnd) NULL ) @@ -1028,11 +1008,6 @@ setMethod("show", "TwasWeights", function(object) { } -# The argument constructor for each weight-method token. Several tokens share -# an engine, so this maps token -> constructor rather than token -> package. -# Tokens absent from this list take no options at all; .twasTokenNoArgsReason -# says why, so the error can be specific. -# @noRd # The implementation that runs one method on one input path. # @noRd .twasMethodImplFor <- function(token, inputKind) { @@ -1060,7 +1035,7 @@ setMethod("show", "TwasWeights", function(object) { if (is.null(impl)) { return(NULL) } - fn <- tryCatch( + fn <- try_fetch( get(impl, envir = asNamespace("pecotmr")), error = function(cnd) NULL ) @@ -1083,7 +1058,7 @@ setMethod("show", "TwasWeights", function(object) { if (is.null(nm)) { return(NULL) } - tryCatch( + try_fetch( get(nm, envir = asNamespace("pecotmr")), error = function(cnd) NULL ) @@ -1105,7 +1080,8 @@ setMethod("show", "TwasWeights", function(object) { .twasMethodsFor <- function(inputKind) { conf <- keep( .twasConfigurableMethods(), - function(tk) !is.null(.twasMethodImplFor(tk, inputKind)) + .twasMethodRunsOn, + inputKind = inputKind ) unique(c( conf, @@ -1113,6 +1089,12 @@ setMethod("show", "TwasWeights", function(object) { )) } +# Whether configurable method `token` has an implementation on `inputKind`. +# @noRd +.twasMethodRunsOn <- function(token, inputKind) { + !is.null(.twasMethodImplFor(token, inputKind)) +} + # Every configurable method's name, independent of input path. The answer to # "is this a method that takes options", which the token normalisers ask. # @noRd @@ -1120,21 +1102,6 @@ setMethod("show", "TwasWeights", function(object) { names(.twasMethodCapabilities) } -# Path-blind view, kept for the callers that have not yet been taught which -# input class they are serving: the individual-level constructor, or the -# summary-statistics one for a method that only runs there (prsCs). -# @noRd -.twasMethodCtors <- function() { - toks <- .twasConfigurableMethods() - set_names( - map(toks, function(tk) { - .twasMethodCtorFor(tk, "QtlDataset") %||% - .twasMethodCtorFor(tk, "QtlSumStats") - }), - toks - ) -} - # Why a token takes no options, so the error can say something useful rather # than just "unknown method". # @noRd @@ -1460,15 +1427,15 @@ setMethod("show", "TwasWeights", function(object) { # the fit it needs. These wrappers extract weights from an existing fit and # never fine-map, so the run is already doomed; checking here reports the # missing fit by name instead of surfacing it from inside the per-fold map. -# `available(token)` answers "is this token's fit present?" for the caller's -# own supply channel. +# `available(token, ...)` answers "is this token's fit present?" for the +# caller's own supply channel; `...` carries what that channel needs. # @noRd -.twasRequireSusieFits <- function(weightMethods, available, fnLabel, how) { +.twasRequireSusieFits <- function(weightMethods, available, fnLabel, how, ...) { tokens <- .twasSusieTokensRequested(weightMethods) if (length(tokens) == 0L) { return(invisible(NULL)) } - missing <- tokens[!map_lgl(tokens, available)] + missing <- tokens[!map_lgl(tokens, available, ...)] if (length(missing) == 0L) { return(invisible(NULL)) } @@ -1895,7 +1862,7 @@ twasWeightsCv <- function( # fit trained on a different split has seen some of this split's held-out # samples, so its out-of-fold predictions are contaminated and the CV metrics # come out optimistic -- silently. Fits carry the producer's partition -# fingerprint (see .cvPartitionKey); anything unstamped is refused too, since +# fingerprint (see .cvPartitionKey); a fit carrying none is refused too, since # it cannot be shown to match. # @noRd .twasCheckFoldFitPartition <- function(fittedModelsCv, samplePartitions) { @@ -2028,15 +1995,14 @@ twasWeightsCv <- function( .twasCheckFoldFitPartition(fittedModelsCv, samplePartitions) .twasRequireSusieFits( weightMethods, - available = function(tk) { - !is.null(.twasFoldFitsFor(fittedModelsCv, tk)) - }, + available = .twasFoldFitAvailable, fnLabel = "twasWeightsCv", how = str_c( "Cross-validation refits on each fold, so it needs that fold's ", "own fit: pass `fittedModelsCv = list( = )` ", "from a fineMappingPipeline() run with cvFolds > 1." - ) + ), + fittedModelsCv = fittedModelsCv ) if (is.null(seed) && !exists(".Random.seed") && verbose >= 1) { inform(str_c( @@ -2047,6 +2013,12 @@ twasWeightsCv <- function( .twasAsMethodRecord(weightMethods) } +# Whether `fittedModelsCv` carries per-fold fits for `tk`. +# @noRd +.twasFoldFitAvailable <- function(tk, fittedModelsCv) { + !is.null(.twasFoldFitsFor(fittedModelsCv, tk)) +} + # Fit one TWAS weight method by name against the filtered design matrix, # embedding the fitted weights back into the full variant space. `ctx` carries # the shared fit state (X, Y, Xfiltered, validColumns, fitRetention, @@ -2321,8 +2293,9 @@ twasWeightsCv <- function( #' are already standardized. Default \code{FALSE}. #' @param weightsDataType Character or \code{NULL}. Data-type label recorded on #' the weights (e.g. \code{"individual"}). -#' @param ldSketch A genotype panel (see \code{\link{readGenotypes}}) to -#' record on the weights as their LD sketch, or \code{NULL}. +#' @param ldReference An LD reference (a genotype panel, see +#' \code{\link{readGenotypes}}, a \code{GenotypeMixture} or an +#' \code{LdMatrix}) to record on the weights, or \code{NULL}. #' @param seed Integer or \code{NULL}. When supplied, seeds the main-process #' RNG and the parallel method-fitting RNG via the \code{BiocParallel} #' \code{RNGseed}, for reproducibility under multi-threading. The @@ -2360,7 +2333,7 @@ learnTwasWeights <- function( fitRetention = c("none", "slim", "full"), weightStandardized = FALSE, weightsDataType = NULL, - ldSketch = NULL, + ldReference = NULL, verbose = 1, seed = NULL ) { @@ -2391,7 +2364,7 @@ learnTwasWeights <- function( fitRetention = fitRetention, weightStandardized = weightStandardized, weightsDataType = weightsDataType, - ldSketch = ldSketch, + ldReference = ldReference, verbose = verbose, seed = seed ) @@ -2479,17 +2452,15 @@ learnTwasWeights <- function( .twasRequireLearnFits <- function(resolvedMethods, fittedModels) { .twasRequireSusieFits( resolvedMethods, - available = partial( - .twasLearnFitAvailable, - resolvedMethods = resolvedMethods, - fittedModels = fittedModels - ), + available = .twasLearnFitAvailable, fnLabel = "learnTwasWeights", how = str_c( "Pass it as `fittedModels = list( = )`, or on the ", "method's own arguments; run fineMappingPipeline() first to ", "produce one." - ) + ), + resolvedMethods = resolvedMethods, + fittedModels = fittedModels ) } @@ -2505,7 +2476,7 @@ learnTwasWeights <- function( fitRetention, weightStandardized, weightsDataType, - ldSketch, + ldReference, verbose, seed ) { @@ -2539,7 +2510,7 @@ learnTwasWeights <- function( ) |> .twasApplyRownames(X) rows <- .buildTwasWeightEntries(weightsList, .twasVariantIds(X), ctx) - .twasLearnResult(rows, ldSketch) + .twasLearnResult(rows, ldReference) } # The learn path's column-wise row record as a TwasWeights collection. NOT @@ -2547,14 +2518,14 @@ learnTwasWeights <- function( # and map_chr()s across them -- a different input entirely, and sharing a # name with it would let collate order decide which one a call reaches. # @noRd -.twasLearnResult <- function(rows, ldSketch) { +.twasLearnResult <- function(rows, ldReference) { TwasWeights( studyName = rows$study, context = rows$context, trait = rows$trait, method = rows$method, entry = rows$entry, - ldSketch = ldSketch + ldReference = ldReference ) } @@ -2748,7 +2719,7 @@ estimateSparsity <- function(weightResults) { } # Route a caller's per-method arguments into a weight function. A wrapper's -# own formals (a pre-fit, fitRetention, initPriorSd, ...) bind by name; any +# own formals (a pre-fit, fitRetention, ...) bind by name; any # else is a tool option and goes in the wrapper's `methodArgs` list, so an # unknown option errors inside the wrapper rather than vanishing. Wrappers # with no `methodArgs` formal get everything by name, and R reports an unused diff --git a/R/twasWeightsPipeline.R b/R/twasWeightsPipeline.R index 3cc2440ed..7d0afb5a3 100644 --- a/R/twasWeightsPipeline.R +++ b/R/twasWeightsPipeline.R @@ -7,12 +7,12 @@ # and pads a side lacking an optional column such as joint* / region). # @noRd #' @importFrom checkmate assertClass -.rbindTwasWeights <- function(a, b, ldSketch = NULL) { +.rbindTwasWeights <- function(a, b, ldReference = NULL) { assertClass(a, "TwasWeights") assertClass(b, "TwasWeights") # Carry forward every column (joint*, region, ...) and reconcile the # collection-level slots via the shared combine. - .combineTupleCollections(list(a, b), ldSketch, ".rbindTwasWeights") + .combineTupleCollections(list(a, b), ldReference, ".rbindTwasWeights") } # Normalize combine() varargs: accept either N objects or a single list of @@ -49,8 +49,8 @@ #' #' @param ... Two or more \code{TwasWeights} objects, or a single \code{list} of #' them. -#' @param ldSketch Optional genotype panel (see \code{\link{readGenotypes}}) to -#' attach to the +#' @param ldReference Optional genotype panel (see \code{\link{readGenotypes}}) +#' to attach to the #' combined collection. Default \code{NULL}. Applied when combining two or #' more inputs; a single input is returned unchanged. #' @return A single combined \code{TwasWeights}. @@ -66,9 +66,9 @@ #' combineTwasWeights(tw1, tw2) #' @importFrom stringr str_starts #' @export -combineTwasWeights <- function(..., ldSketch = NULL) { +combineTwasWeights <- function(..., ldReference = NULL) { parts <- .asCombineList(list(...), "TwasWeights", "combineTwasWeights") - .combineTupleCollections(parts, ldSketch, "combineTwasWeights") + .combineTupleCollections(parts, ldReference, "combineTwasWeights") } # --- Multi-region (jointRegions) helpers for the QtlDataset method ---------- @@ -169,21 +169,6 @@ combineTwasWeights <- function(..., ldSketch = NULL) { ) } -# Mapping from short / canonical TWAS weight-method name to dispatch -# capability. Used to reject incompatible (input class, method) pairs. -# -# `allowsIndiv` : may be invoked on a QtlDataset (individual-level X, Y). -# `allowsRss` : may be invoked on a QtlSumStats / GwasSumStats (RSS). -# `multivariate` : requires a multi-trait / multi-context Y (mvsusie / -# mr.mash family). -# -# Rules from `dev/refactor-design.md` (`twasWeightsPipeline` row): -# - PRS-CS is RSS-only. -# - BGLR / CRAN-stable qgg methods (bayes_a/b/c/l/n/r, b_lasso, dpr_*) -# are individual-level only. -# - mr.mash / mvsusie follow the multi-trait / multi-context rules of -# the mvSuSiE fine-mapping family. -# @noRd # User-facing TWAS method tokens are unified across input classes; # auto-dispatch picks the individual-level vs sumstat implementation based # on the QtlDataset / QtlSumStats input. Each entry records: @@ -198,9 +183,10 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # b_lasso) are individual-only until the qgg CRAN release adds qBayes # sumstat support. dpr_gibbs has the SDPR sumstat counterpart; # dpr_vb / dpr_adaptive_gibbs remain individual-only. enet has no cpp11 -# sumstat solver yet (lassosumRssRcpp is pure L1, no alpha mixing) and is +# sumstat solver yet (lassosumRssCpp is pure L1, no alpha mixing) and is # documented as individual-only for now. prsCs has no individual-level # counterpart (it is a sumstat-only Bayesian shrinkage method). +# @noRd .twasMethodCapabilities <- list( # NOTE: fine-mapping methods (susie / susieInf / susieAsh / mvsusie / # fsusie) are NOT listed here. Their availability is governed by @@ -336,10 +322,6 @@ combineTwasWeights <- function(..., ldSketch = NULL) { ) return(.twasNormalizeListMethods(resolved$methodArgs)) } - if (.isMethodOptions(methods)) { - # The retired TwasWeightsMethodsParam() record. - return(.twasNormalizeListMethods(map(as.list(methods), as.list))) - } msg <- glue( "`methods` must be a character vector, a preset string, a named ", "list of per-method options, or a TwasWeightsMethodsParam() record." @@ -369,11 +351,6 @@ combineTwasWeights <- function(..., ldSketch = NULL) { list(tokens = unique(methods), methodList = methodList) } -# Named-list `methods`: re-key each entry to its canonical `_weights` -# name, merge the caller's kwargs over the method's defaults, and carry the -# token->impl map as an "impl" attribute (without this, downstream -# .resolveMethodFunction falls back to the bare token, which is not a function). -# @noRd # One `methods` entry re-keyed to its canonical name, with the caller's # kwargs merged over the method's defaults. A token with no learner default # is kept under its own name (the capability gate reports it downstream). @@ -393,6 +370,11 @@ combineTwasWeights <- function(..., ldSketch = NULL) { ) } +# Named-list `methods`: re-key each entry to its canonical `_weights` +# name, merge the caller's kwargs over the method's defaults, and carry the +# token->impl map as an "impl" attribute (without this, downstream +# .resolveMethodFunction falls back to the bare token, which is not a function). +# @noRd .twasNormalizeListMethods <- function(methods) { entries <- map(names(methods), .twasNormalizeOneMethod, methods = methods) # Later entries win on a repeated canonical key, as the keyed assignment @@ -610,7 +592,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { } # Canonical fine-mapping tokens actually present as methods in a -# FineMappingResult, matched tolerantly across canonical / camelCase / +# fine-mapping result, matched tolerantly across canonical / camelCase / # snake_case spellings (mirrors the candidate logic in .twasFineMappingFits). # @noRd .twasFineMappingMethodsPresent <- function(fineMappingResult) { @@ -641,7 +623,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { } # Reject fine-mapping methods (susie / susieInf / susieAsh / mvsusie / -# fsusie) when no FineMappingResult is supplied. twasWeightsPipeline is +# fsusie) when no fine-mapping result is supplied. twasWeightsPipeline is # not allowed to re-fit fine-mapping models from scratch; users must run # fineMappingPipeline() first and pass the result via `fineMappingResult`. # Input-class compatibility (e.g. fsusie has no QtlSumStats path) is @@ -653,7 +635,8 @@ combineTwasWeights <- function(..., ldSketch = NULL) { tokens, fineMappingResult, inputKind, - cvFolds = 0 + cvFolds = 0, + fitFullData = TRUE ) { fmTokens <- intersect(tokens, .twasFineMappingTokens()) if (length(fmTokens) == 0L) { @@ -666,16 +649,19 @@ combineTwasWeights <- function(..., ldSketch = NULL) { .twasRequireFmResult(fineMappingResult, fmTokens) .twasCheckFmPresent(fmTokens, fineMappingResult) .twasCheckFmCvPresent(fmTokens, fineMappingResult, cvFolds) + if (isTRUE(fitFullData)) { + .twasCheckFmFullFits(fmTokens, fineMappingResult) + } invisible(NULL) } -# Whether row `i` of a FineMappingResult carries a cross-validation result. +# Whether row `i` of a fine-mapping result carries a cross-validation result. # @noRd .fmrRowHasCv <- function(i, fineMappingResult) { !is.null(cvResult(.fmrRowParts(fineMappingResult, i))) } -# Whether a FineMappingResult carries any cross-validation result at all. +# Whether a fine-mapping result carries any cross-validation result at all. # @noRd .fmrAnyCvResult <- function(fineMappingResult) { if (!is(fineMappingResult, "FineMappingResultBase")) { @@ -715,6 +701,31 @@ combineTwasWeights <- function(..., ldSketch = NULL) { abort(msg) } +# Full-data weights for a fine-mapping-derived method are read off the +# fine-mapping fit, so a row from a cross-validation-only fine-mapping run +# (CrossValidationParam(fitFullData = FALSE)) cannot supply them. Say so up +# front rather than failing inside the extraction. +# @noRd +.twasCheckFmFullFits <- function(fmTokens, fineMappingResult) { + rows <- seq_len(nrow(fineMappingResult)) + method <- as.character(fineMappingResult$method) + noFit <- rows[ + is_in(method, fmTokens) & + !map_lgl(rows, .fmrRowHasFit, fineMappingResult = fineMappingResult) + ] + if (length(noFit) == 0L) { + return(invisible(NULL)) + } + msg <- glue( + "twasWeightsPipeline: {length(noFit)} fineMappingResult row(s) for ", + "{str_flatten(unique(method[noFit]), ', ')} carry no full-data fit -- ", + "they come from a cross-validation-only fine-mapping run. Rerun ", + "fineMappingPipeline() with CrossValidationParam(fitFullData = TRUE), ", + "or run twasWeightsPipeline() cross-validation-only as well." + ) + abort(msg) +} + # Reject fine-mapping methods that have no TWAS-weight extractor (e.g. fsusie). # @noRd .twasCheckFmAdapters <- function(fmTokens) { @@ -732,7 +743,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { } # A supplied fineMappingResult is mandatory (fine-mapping is never re-fit) and -# must be a FineMappingResult. +# must be a FineMappingResultBase. # @noRd #' @importFrom checkmate assertClass .twasRequireFmResult <- function(fineMappingResult, fmTokens) { @@ -742,7 +753,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { "twasWeightsPipeline: method(s) {fmStr} are fine-mapping ", "methods and may not be re-fit by twasWeightsPipeline. Run ", "fineMappingPipeline() first and pass the result via ", - "`fineMappingResult = `." + "`fineMappingResult = `." ) abort(msg) } @@ -766,7 +777,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { "twasWeightsPipeline: method(s) {missingStr} were requested but ", "the supplied fineMappingResult contains no such fine-mapping ", "fit. Run fineMappingPipeline() with method(s) {missingStr} first ", - "and pass the result via `fineMappingResult = `." + "and pass the result via `fineMappingResult = `." ) abort(msg) } @@ -788,11 +799,6 @@ combineTwasWeights <- function(..., ldSketch = NULL) { FALSE } -# Enforce the multi-trait / multi-context rule for mvsusie / mr.mash -# methods (same family as the fine-mapping mvSuSiE rule in the design -# doc). Multivariate methods need at least 2 traits *or* at least 2 -# contexts in the Y matrix passed to learnTwasWeights. -# @noRd # The multivariate rule across a MultiStudyQtlDataset's components. # # A multivariate method -- mvsusie, mr.mash, fsusie, and the PCA alternative @@ -835,13 +841,18 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # @noRd .twasComponentIsUnivariate <- function(key, components) { d <- components[[key]] - nTraits <- length(tryCatch(traitNames(d), error = function(cnd) { + nTraits <- length(try_fetch(traitNames(d), error = function(cnd) { character(0) })) - nCtx <- length(tryCatch(contexts(d), error = function(cnd) character(0))) + nCtx <- length(try_fetch(contexts(d), error = function(cnd) character(0))) nTraits < 2L && nCtx < 2L } +# Enforce the multi-trait / multi-context rule for mvsusie / mr.mash +# methods (same family as the fine-mapping mvSuSiE rule in the design +# doc). Multivariate methods need at least 2 traits *or* at least 2 +# contexts in the Y matrix passed to learnTwasWeights. +# @noRd .twasCheckMultivariateY <- function(tokens, nTraits, nContexts) { multivariateTokens <- tokens[map_lgl(tokens, .twasIsMultivariateToken)] if (length(multivariateTokens) == 0L) { @@ -858,7 +869,10 @@ combineTwasWeights <- function(..., ldSketch = NULL) { } } -# Reject SumStats inputs that have not been QC'd via summaryStatsQc. +# Reject SumStats inputs that have not been QC'd via summaryStatsQc(), which +# is mandatory before twasWeightsPipeline for SumStats input: it also drops the +# variants absent from the ldReference, so once this passes every entry's SNP +# set is a subset of the ldReference panel. # @noRd .twasAssertQcd <- function(sumstats) { if (length(qcInfo(sumstats)) == 0L) { @@ -900,7 +914,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { .twrRowParts(twasWeights, idx[[1L]]) } -# Convert a FineMappingResult (single-method susie/susie_inf row matched +# Convert a fine-mapping result (single-method susie/susie_inf row matched # to the requested study/context/trait) into a `fittedModels` list # suitable for `learnTwasWeights`. Pulls the trimmedFit from the matching # entry. Returns a (possibly empty) list. @@ -977,17 +991,6 @@ combineTwasWeights <- function(..., ldSketch = NULL) { fits[[token]] } -# Collect the cross-validation payload that fineMappingPipeline stored on the -# FineMappingResult for one (study, context, trait) tuple. fineMapping records -# one cvResult per (study, context, trait, method) entry (samplePartition + -# per-fold predictions/metrics, keyed by the TWAS snake method name); this -# merges them across the fine-mapping methods of the tuple into a single -# twasWeightsCv()-shaped list so twasWeightsPipeline can reuse the partition and -# feed those out-of-fold predictions into the SR-TWAS ensemble without re- -# fitting the fine-mapping models. A multi-region entry stores cvResult as a -# per-region list; the first region carrying CV is used. Returns NULL when no -# fine-mapping entry for the tuple recorded CV. -# @noRd # Concatenate per-row lists, empty-safe. # @noRd .twasCvConcat <- function(pieces) { @@ -1016,6 +1019,17 @@ combineTwasWeights <- function(..., ldSketch = NULL) { hit[[1L]] } +# Collect the cross-validation payload that fineMappingPipeline stored on the +# fine-mapping result for one (study, context, trait) tuple. It records one +# cvResult per (study, context, trait, method) entry (samplePartition + +# per-fold predictions/metrics, keyed by the TWAS snake method name); this +# merges them across the fine-mapping methods of the tuple into a single +# twasWeightsCv()-shaped list so twasWeightsPipeline can reuse the partition and +# feed those out-of-fold predictions into the SR-TWAS ensemble without re- +# fitting the fine-mapping models. A multi-region entry stores cvResult as a +# per-region list; the first region carrying CV is used. Returns NULL when no +# fine-mapping entry for the tuple recorded CV. +# @noRd .twasCvResultFor <- function(fineMappingResult, studyName, context, trait) { if (is.null(fineMappingResult)) { return(NULL) @@ -1056,8 +1070,9 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' \itemize{ #' \item a \code{\link{QtlDataset}} for individual-level cohort fits; #' \item a \code{\link{QtlSumStats}} for per-trait RSS fits; -#' \item a \code{\link{GwasSumStats}} for per-LD-block PRS-CS-style fits -#' from GWAS summary statistics. +#' \item a \code{\link{MultiStudyQtlDataset}}, whose individual-level +#' studies and optional summary-statistic studies are each fitted, +#' then combined. #' } #' #' Method-restriction rules (enforced): @@ -1065,33 +1080,35 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' \item \code{mr.mash}, \code{mvsusie} follow the multi-trait / #' multi-context rules of the fine-mapping \code{mvsusie} family #' (require at least two traits OR at least two contexts). -#' \item RSS-only methods (PRS-CS, \code{lassosumRss}, SDPR, all -#' \code{*Rss} variants) are rejected on \code{QtlDataset} -#' input. -#' \item Individual-level-only methods (BGLR and CRAN-stable qgg: -#' \code{bayes_a/b/c/l/n/r}, \code{b_lasso}, \code{dpr_*}) are -#' rejected on \code{QtlSumStats} / \code{GwasSumStats} input. +#' \item \code{prsCs} runs only on summary statistics, so it is rejected +#' on \code{QtlDataset} input. +#' \item \code{enet}, \code{dprVb}, \code{dprAdaptiveGibbs} and the +#' Bayesian alphabet (\code{bayesA}, \code{bayesB}, \code{bayesC}, +#' \code{bayesL}, \code{bayesN}, \code{bayesR}, \code{bLasso}) run +#' only on individual-level data, so they are rejected on +#' \code{QtlSumStats} input. #' } #' -#' Both \code{QtlSumStats} and \code{GwasSumStats} inputs must have been QC'd -#' via \code{\link{summaryStatsQc}} first; otherwise an error is raised pointing +#' A \code{QtlSumStats} input must have been QC'd via +#' \code{\link{summaryStatsQc}} first; otherwise an error is raised pointing #' at that function. #' -#' The returned \code{\link{TwasWeights}} collection's \code{ldSketch} slot is -#' set automatically: \code{NULL} for individual-level fits, the input's -#' \code{ldSketch} for RSS-derived fits. +#' The returned \code{\link{TwasWeights}} collection's \code{ldReference} slot +#' is set automatically: \code{NULL} for individual-level fits, the input's +#' \code{ldReference} for RSS-derived fits. #' -#' Optionally a \code{FineMappingResult} may be supplied as a source of pre-fit -#' SuSiE / SuSiE-inf / SuSiE-ash objects; their \code{trimmedFit} payloads are -#' passed through to \code{learnTwasWeights} / the RSS sub-pipelines via the +#' Optionally a \code{QtlFineMappingResult} may be supplied as a source of +#' pre-fit SuSiE / SuSiE-inf / SuSiE-ash objects; their stored fits are passed +#' through to \code{learnTwasWeights} / the RSS sub-pipelines via the #' \code{fittedModels} slot, avoiding a re-fit. #' -#' When the supplied \code{FineMappingResult} was produced with cross-validation -#' (\code{fineMappingPipeline(..., cvFolds > 1)}), each matching \code{(study, -#' context, trait)} entry's \code{cvResult} is reused: its fold partition -#' becomes the CV partition (unless \code{samplePartition} is given explicitly) -#' and its per-fold out-of-fold predictions/metrics are fed directly into the -#' SR-TWAS ensemble in place of re-fitting those fine-mapping methods here. +#' When the supplied result was produced with cross-validation (a +#' \code{\link{CrossValidationParam}} with \code{folds >= 2}), each matching +#' \code{(study, context, trait)} entry's \code{cvResult} is reused: its fold +#' partition becomes the CV partition (unless \code{samplePartition} is given +#' explicitly) and its per-fold out-of-fold predictions/metrics are fed +#' directly into the SR-TWAS ensemble in place of re-fitting those +#' fine-mapping methods here. #' Non-fine-mapping methods (lasso, enet, ...) are still cross-validated on the #' same shared partition. #' @@ -1101,14 +1118,25 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' embedded \code{QtlSumStats}, then rbinds the results. #' @param methods A character vector of short method names, a preset string #' (\code{"default"} or \code{"fastDefault"}), or a named list of -#' \code{_weights = args} entries. For QtlSumStats / GwasSumStats -#' inputs the default switches to the RSS preset (\code{c("susieRss", -#' "susieInfRss", "lassosumRss", "prsCs", "sdpr")}). -#' @param contexts Optional character vector of contexts to restrict processing -#' to (QtlDataset / QtlSumStats inputs). Default \code{NULL} (use all -#' contexts). -#' @param traitId Optional character vector of trait identifiers to restrict -#' processing to (QtlDataset / QtlSumStats inputs). Default \code{NULL}. +#' \code{_weights = args} entries. For QtlSumStats input the +#' default is \code{c("lasso", "prsCs", "dprGibbs")}, which there run +#' lassosum, PRS-CS and SDPR; the fine-mapping methods are not in it, and +#' are requested by name together with a \code{fineMappingResult}. +#' @param contexts Optional context selection; \code{NULL} (the default) uses +#' every context. A character vector applies to every study: a context no +#' study has is an error, and one only some studies lack is skipped for +#' those, with a warning. A list keyed by study name picks each study's +#' contexts separately (\code{list(A = "liver")}); studies it does not name +#' keep all of theirs. +#' @param traitId Optional trait selection; \code{NULL} (the default) uses +#' every trait, or those overlapping \code{region} when one is given. A +#' character vector applies to every study. A list keyed by study name +#' picks each study's traits separately (\code{list(A = "ENSG1")}), and a +#' study's entry may itself be a list keyed by context +#' (\code{list(A = list(brain = "ENSG1"))}). Studies and contexts the list +#' does not name keep all of their traits. A joint fit spanning a study's +#' contexts uses every trait selected in any of them, minus the (context, +#' trait) pairs a per-context entry leaves out. #' @param region Optional variant window for QtlDataset trait selection: a #' \code{GRanges}, a \code{"chr:start-end"} string, or a one-row data.frame #' with \code{chrom}/\code{start}/\code{end}. Mutually exclusive with @@ -1117,17 +1145,17 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' position when extracting variants. Required when \code{traitId} is #' supplied. Mutually exclusive with \code{region}. #' @section Panel filters on the RSS path: On \code{QtlSumStats} input there -#' is no genotype matrix to filter, so \code{panelFilter}'s +#' is no genotype matrix to filter, so \code{panelFilterParam}'s #' \code{mafCutoff} / \code{macCutoff} / \code{imissCutoff} are measured #' against the \strong{LD reference panel} instead: a variant whose panel #' genotypes fall below the cutoffs is dropped before the z-scores and LD #' matrix are built. The thresholds mean the same thing as -#' \code{genotypeFilter}'s on the \code{QtlDataset} path (MAC is converted -#' to a MAF equivalent and the stricter of the two applies), so one number -#' carries across input types. The defaults filter nothing. +#' \code{genotypeFilterParam}'s on the \code{QtlDataset} path (MAC is +#' converted to a MAF equivalent and the stricter of the two applies), so +#' one number carries across input types. The defaults filter nothing. #' #' This discards \emph{observed} variants, unlike -#' \code{summaryStatsQc(imputeArgs = ...)}, which only bounds which variants +#' \code{summaryStatsQc(raissParam = ...)}, which only bounds which variants #' RAISS will impute. #' #' @param genotypeFilterParam For QtlDataset: per-call genotype-filter @@ -1149,14 +1177,20 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' flat \code{cvResult} data frame (one row per region). \code{TRUE} #' concatenates the ranges' genotypes into one joint fit. Ignored for a #' single-range / cis request. -#' @param jointSpecification Optional joint-fit specification (NULL by default). -#' When NULL, the pipeline runs the implicit multi-trait / multi-context -#' mr.mash branches as before. When non-NULL, the argument is parsed and -#' validated via the joint-spec grammar documented under -#' \code{parseJointSpecification}; the per-spec axis dispatcher implementation -#' is in progress and a non-NULL value currently errors with an informative -#' message. -#' @param fineMappingResult Optional \code{FineMappingResult}. When supplied, +#' @param jointSpecification Optional joint-fit specification saying which +#' axes \code{mrmash} fits across. When NULL (the default) it runs its +#' implicit multi-trait / multi-context fit. Otherwise give a character +#' vector of axes (one spec) or a list of specs. A spec is a character +#' vector drawn from \code{"study"}, \code{"context"} and \code{"trait"}, +#' or \code{list(axes = , scope = )}, where \code{scope} +#' (keys \code{study}, \code{context}, \code{trait}) limits the fit to the +#' listed values, each of which must exist in \code{data}. A list-form +#' spec always goes inside the outer list, even on its own. Other methods +#' run per (study, context, trait) as usual. The \code{"study"} axis needs +#' summary statistics: it is rejected on a \code{QtlDataset}, and on a +#' \code{MultiStudyQtlDataset} only the summary-statistics studies take +#' part. +#' @param fineMappingResult Optional \code{QtlFineMappingResult}. When supplied, #' its SuSiE / SuSiE-inf / SuSiE-ash trimmed fits for the matching (study, #' context, trait) tuples are injected into \code{learnTwasWeights} via #' \code{fittedModels} so SuSiE-family weight methods reuse the prior fit @@ -1172,9 +1206,9 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' produce one fit jointly across multiple \code{(context, trait)} columns. #' @param mashPrior Optional \code{\link{MashPrior}} (or coercible) supplying #' data-driven prior matrices for mr.mash weight methods; \code{NULL} to skip. -#' @param fitFullData Logical. If \code{TRUE}, fit final weights on the full -#' data after cross-validation. Default \code{TRUE}. -#' @param usePCA Logical (length 1). \code{QtlDataset} only. When +#' @param usePCA Logical (length 1). Individual-level data only: a +#' \code{QtlDataset}, or the \code{QtlDataset} components of a +#' \code{MultiStudyQtlDataset}. When #' \code{TRUE}, each multi-trait context is additionally PCA-reduced and #' weights are fitted for each top principal component \emph{as a trait} #' (\code{topPC1}, \code{topPC2}, ...), alongside the per-trait rows. The @@ -1191,18 +1225,21 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' takes, which has no \code{"none"} --- its \code{susieFit} slot is part #' of the returned object's contract. #' -#' \code{"full"} is honoured only by the mr.mash engines, the only ones -#' that distinguish the two retaining levels; every other method keeps its -#' fit whole or not at all. Requesting \code{"full"} for a run where no -#' method can honour it is an error, and a mixed run warns rather than -#' dropping it in silence. +#' \code{"full"} is honoured by the mr.mash engines and, on summary +#' statistics, by \code{lasso}, \code{scad}, \code{mcp} and +#' \code{l0learn}, whose full fit also keeps every candidate's +#' coefficients; every other method keeps its fit whole or not at all. +#' Requesting \code{"full"} for a run where no method can honour it is an +#' error, and a mixed run warns rather than dropping it in silence. #' @param naAction Character. How to handle missing values in the extracted #' data. -#' @param crossValidationArgs Cross-validation settings, built with +#' @param crossValidationParam Cross-validation settings, built with #' \code{\link{CrossValidationParam}}: \code{folds} (default \code{0}, no #' CV), \code{threads}, \code{samplePartition}, \code{maxVariants} (cap -#' on the CV design matrix) and \code{weightMethods} (which methods to -#' cross-validate; unset means every method with non-zero weights). +#' on the CV design matrix), \code{weightMethods} (which methods to +#' cross-validate; unset means every method with non-zero weights) and +#' \code{fitFullData} (\code{FALSE} keeps only the cross-validation +#' results; default \code{TRUE}). #' #' \code{folds} defaulted to \code{5} before, while #' \code{\link{fineMappingPipeline}}'s defaulted to \code{0}. The two now @@ -1211,16 +1248,16 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' Cross-validation holds out \strong{samples}, so it is not possible on #' \code{QtlSumStats} input; that method \strong{errors} if it is set #' rather than returning results that were never cross-validated. -#' @param ensembleArgs SR-TWAS ensemble settings, built with +#' @param ensembleParam SR-TWAS ensemble settings, built with #' \code{\link{EnsembleParam}}: \code{enabled} (default \code{FALSE}), #' \code{r2Threshold}, \code{solver} and \code{alpha}. Stacking reads #' out-of-fold predictions, so \code{enabled = TRUE} requires -#' \code{crossValidation} with \code{folds >= 2} and is an error +#' \code{crossValidationParam} with \code{folds >= 2} and is an error #' otherwise --- it previously returned a result quietly missing its #' ensemble row. #' @param estimatePi If TRUE, estimate spike-and-slab sparsity from mr.ash #' before BGLR / qgg spike-and-slab methods that consume it. -#' @param residualizationArgs Covariate residualization settings, built with +#' @param residualizationParam Covariate residualization settings, built with #' \code{\link{ResidualizationParam}} and forwarded to #' \code{\link{residualizedPhenotypes}} / #' \code{\link{residualizedGenotypes}}: \code{phenotypeCovariates} and @@ -1232,7 +1269,8 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' \code{QtlDataset} / \code{MultiStudyQtlDataset} input only. A #' \code{QtlSumStats} run has no covariates to regress out, so the bundle #' is \strong{ignored} there rather than refused --- unlike -#' \code{crossValidation}, which errors. Residualization is on by default, +#' \code{crossValidationParam}, which errors. Residualization is on by +#' default, #' so refusing a non-default value would reject the default bundle; CV is #' off by default, so a non-default value there is an explicit request for #' something the input cannot do. @@ -1270,8 +1308,8 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' @param ... Reserved for method-specific arguments. #' #' @return A \code{\link{TwasWeights}} collection keyed by \code{(study, -#' context, trait, method)}. The \code{ldSketch} slot is \code{NULL} for -#' individual-level fits and equals the input's \code{ldSketch} for +#' context, trait, method)}. The \code{ldReference} slot is \code{NULL} for +#' individual-level fits and equals the input's \code{ldReference} for #' RSS-derived fits. #' @examples #' data(qtlDatasetExample) @@ -1299,23 +1337,23 @@ setGeneric("twasWeightsPipeline", function(data, ...) { )) } -# Run the multivariate joint TWAS-weight fit over the (context, trait) grid for -# `traits`: dispatch each cis-region through the joint engine and merge -# per-region results. `marker` = the TwasJointPipeline config; `ctx` bundles the -# shared state -# (xRegions, data, norm, useCtx, fineMappingResult, dataDrivenPriorMatricesCv, -# cisWindow, verbose). +# Run joint specs through the engine over every region block of `ctx` and +# merge the per-region results by (study, context, trait, method). Shared by +# the per-tuple multivariate grid (a synthesized context x trait spec) and the +# explicit jointSpecification path, so both fit under the same pipeline +# `marker` and the same engine `args`. `ctx` is .twasJointSetup()'s record. # @noRd -.twasRunMultivariateGrid <- function(traits, marker, ctx) { - synthSpec <- list(list(axes = c("context", "trait"), scope = NULL)) +.twasRunJointSpecGrid <- function(spec, tokens, contexts, traits, marker, ctx) { allLabs <- map_chr(ctx$xRegions, .twasRegionLabel) allRegions <- map( seq_along(ctx$xRegions), - .twasMvGridRegion, - synthSpec = synthSpec, + .twasJointSpecRegion, + spec = spec, + tokens = tokens, + contexts = contexts, + traits = traits, marker = marker, - ctx = ctx, - traits = traits + ctx = ctx ) keep <- !map_lgl(allRegions, is.null) perRegion <- allRegions[keep] @@ -1343,21 +1381,25 @@ setGeneric("twasWeightsPipeline", function(data, ...) { fineMappingResult, dataDrivenPriorMatricesCv, cisWindow, - residualizationArgs, + residualizationParam, verbose ) { - .twasRunMultivariateGrid( - grid$allTraits, + # A per-context selection goes in whole: the joint scope then takes each + # study's union of it and drops the (context, trait) pairs it leaves out. + .twasRunJointSpecGrid( + list(list(axes = c("context", "trait"), scope = NULL)), + norm$tokens, + grid$useCtx, + grid$traitSelection %||% grid$allTraits, marker, list( xRegions = xRegions, data = data, norm = norm, - useCtx = grid$useCtx, fineMappingResult = fineMappingResult, dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, cisWindow = cisWindow, - residualizationArgs = residualizationArgs, + residualizationParam = residualizationParam, verbose = verbose ) ) @@ -1378,7 +1420,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { dataDrivenPriorMatricesCv, cisWindow, naAction, - residualizationArgs, + residualizationParam, usePCA, nPCs, verbose @@ -1393,7 +1435,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { fineMappingResult = fineMappingResult, dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, cisWindow = cisWindow, - residualizationArgs = residualizationArgs, + residualizationParam = residualizationParam, verbose = verbose )) } @@ -1401,6 +1443,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { studyName = grid$study, useCtx = grid$useCtx, allTraits = grid$allTraits, + traitSelection = grid$traitSelection, marker = marker, data = data, xRegions = xRegions, @@ -1410,7 +1453,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, cisWindow = cisWindow, naAction = naAction, - residualizationArgs = residualizationArgs, + residualizationParam = residualizationParam, usePCA = usePCA, nPCs = nPCs, verbose = verbose @@ -1423,20 +1466,27 @@ setGeneric("twasWeightsPipeline", function(data, ...) { .twasQdsAssertParams <- function( methods, fitRetention, - crossValidationArgs, - ensembleArgs + crossValidationParam, + ensembleParam ) { - .twasWarnUnretainableDetail(fitRetention, methods) + .twasWarnUnretainableDetail(fitRetention, methods, "QtlDataset") .assertMethodParam( - crossValidationArgs, - "CrossValidationParam", - "crossValidation" + crossValidationParam, + "CrossValidationParam" ) - .assertMethodParam(ensembleArgs, "EnsembleParam", "ensemble") - .ensembleAssertCv(ensembleArgs, crossValidationArgs) + .assertMethodParam(ensembleParam, "EnsembleParam") + .ensembleAssertCv(ensembleParam, crossValidationParam) invisible(NULL) } +# The QtlDataset method of twasWeightsPipeline(). Each stage returns only the +# values it derives; nothing is grafted onto a captured environment. `cfg` +# (.twasJointCfg()) is the one record of the run's settings, and the pipeline +# marker is built from it BEFORE the joint phase, so explicit joint fits run +# under the same marker and engine args as the per-tuple loop. The joint phase +# consumes the mrmash token; `norm` comes back holding only the methods that +# still have to go through the per-tuple loop. +# @noRd .twasPipelineQtlDataset <- function( data, methods = "default", @@ -1450,14 +1500,13 @@ setGeneric("twasWeightsPipeline", function(data, ...) { fineMappingResult = NULL, twasWeights = NULL, mashPrior = NULL, - crossValidationArgs = CrossValidationParam(), - fitFullData = TRUE, - ensembleArgs = EnsembleParam(), + crossValidationParam = CrossValidationParam(), + ensembleParam = EnsembleParam(), estimatePi = TRUE, usePCA = FALSE, nPCs = 10L, fitRetention = c("slim", "none", "full"), - residualizationArgs = ResidualizationParam(), + residualizationParam = ResidualizationParam(), weightsDataType = NULL, naAction = c("drop", "impute"), verbose = 1, @@ -1465,15 +1514,14 @@ setGeneric("twasWeightsPipeline", function(data, ...) { ) { naAction <- arg_match(naAction) fitRetention <- arg_match(fitRetention) + contexts <- parseContexts(contexts, data) + traitId <- parseTraitIds(traitId, data) .twasQdsAssertParams( methods, fitRetention, - crossValidationArgs, - ensembleArgs + crossValidationParam, + ensembleParam ) - cvCfg <- .cvResolve(crossValidationArgs) - # Each stage returns only the values it derives; nothing is grafted onto a - # captured environment. resolved <- .twasQdsResolveInputs( data = data, region = region, @@ -1482,67 +1530,59 @@ setGeneric("twasWeightsPipeline", function(data, ...) { genotypeFilterParam = genotypeFilterParam ) data <- resolved$data - xRegions <- resolved$xRegions - # One record of the settings the joint phase and the shared dispatcher - # both need, so each names them once. - jointCfg <- list( - data = data, + cfg <- .twasJointCfg( contexts = contexts, traitId = traitId, cisWindow = cisWindow, - dataType = weightsDataType, - verbose = verbose, - xRegions = xRegions, + xRegions = resolved$xRegions, + fineMappingResult = fineMappingResult, + mashPrior = mashPrior, + crossValidationParam = crossValidationParam, + ensembleParam = ensembleParam, + estimatePi = estimatePi, fitRetention = fitRetention, + residualizationParam = residualizationParam, + weightsDataType = weightsDataType, + verbose = verbose, seed = seed ) - joint <- .twasQdsResolveTokens( + resolvedTokens <- .twasQdsResolveTokens( jointSpecification, methods, fineMappingResult, - cvCfg$folds, - fitFullData, - mashPrior, - cvCfg$samplePartition, - jointCfg + .cvResolve(crossValidationParam), + data + ) + setup <- .twasJointSetup(data, resolvedTokens$norm, cfg) + joint <- .twasQdsJointPhase( + resolvedTokens$parsedJointSpec, + setup$marker, + setup$ctx, + contexts, + traitId ) if (joint$done) { return(joint$result) } - # The joint phase consumes the mrmash token; `norm` comes back holding - # only the methods that still have to go through the per-tuple loop. - norm <- joint$norm - samplePartition <- joint$samplePartition - dataDrivenPriorMatricesCv <- joint$dataDrivenPriorMatricesCv - grid <- .twasQdsResolveGrid(data, contexts, traitId, region, norm$tokens) - # The bundles are the user-facing form; below this line the marker and - # the joint engine that reads it keep plain scalars. - marker <- .twasQdsMarker( - crossValidationArgs = list_assign( - cvCfg, - samplePartition = samplePartition - ), - ensembleArgs = .ensembleResolve(ensembleArgs), - fitFullData = fitFullData, - weightsDataType = weightsDataType, - standardized = .qtlScaleResiduals(data, residualizationArgs), - fitRetention = fitRetention, - estimatePi = estimatePi, - verbose = verbose, - seed = seed + grid <- .twasQdsResolveGrid( + data, + contexts, + traitId, + region, + joint$norm$tokens ) tw <- .twasQdsRunGrid( grid, - marker, + setup$marker, data = data, - xRegions = xRegions, - norm = norm, + xRegions = resolved$xRegions, + norm = joint$norm, fineMappingResult = fineMappingResult, twasWeights = twasWeights, - dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + dataDrivenPriorMatricesCv = setup$ctx$dataDrivenPriorMatricesCv, cisWindow = cisWindow, naAction = naAction, - residualizationArgs = residualizationArgs, + residualizationParam = residualizationParam, usePCA = usePCA, nPCs = nPCs, verbose = verbose @@ -1558,40 +1598,6 @@ setMethod( .twasPipelineQtlDataset ) -# `cisWindow` expands a trait's own coordinates; `region` is literal. Supplying -# both signals a misunderstanding -> reject. -# @noRd -.twasQdsCheckRegionCisWindow <- function( - region, - cisWindow -) { - if (!is.null(region) && !is.null(cisWindow)) { - msg <- glue( - "twasWeightsPipeline(QtlDataset): specify either `region` or ", - "`cisWindow`, not both. `cisWindow` expands each trait's own ", - "coordinates, whereas `region` is the literal variant window." - ) - abort(msg) - } - invisible(NULL) -} - -# fitFullData = FALSE (CV-only) is meaningful only with cross-validation. -# @noRd -.twasQdsCheckFitFull <- function( - fitFullData, - cvFolds -) { - if (!isTRUE(fitFullData) && cvFolds <= 1L) { - msg <- glue( - "twasWeightsPipeline: fitFullData = FALSE requires ", - "cross-validation (cvFolds > 1)." - ) - abort(msg) - } - invisible(NULL) -} - # Unpack the MashPrior bundle: route the full-data prior into the mr.mash method # args, the per-fold priors + fold partition into the CV machinery. Returns the # updated parameter bundle. @@ -1650,44 +1656,41 @@ setMethod( jointRegions, genotypeFilterParam ) { - .twasQdsCheckRegionCisWindow(region, cisWindow) + .rejectRegionWithCisWindow( + region, + cisWindow, + "twasWeightsPipeline(QtlDataset)" + ) list( data = .qtlApplyFilterOverrides(data, genotypeFilterParam), xRegions = .makeXRegions(region, jointRegions) ) } -# Run the joint engine for a QtlDataset with the given spec + token set. -# @noRd -.twasQdsJointDispatch <- function(jointSpec, tokens, cfg) { - .twasDispatchJointSpecsQtlDataset( - jointSpec, - cfg$data, - tokens, - cfg$contexts, - cfg$traitId, - cfg$cisWindow, - cfg$dataType, - cfg$verbose, - xRegions = cfg$xRegions, - fitRetention = cfg$fitRetention, - seed = cfg$seed - ) -} # Explicit jointSpecification path: run the per-spec axis dispatcher for # mr.mash. Returns list(done, result, norm): `done` requests an early return # with `result`; otherwise `norm` is the mrmash-stripped normalization for the # per-tuple loop below. # @noRd -.twasQdsJointPhase <- function(parsedJointSpec, norm, cfg) { +.twasQdsJointPhase <- function( + parsedJointSpec, + marker, + ctx, + contexts, + traitId +) { + norm <- ctx$norm if (length(parsedJointSpec) == 0L) { return(list(done = FALSE, result = NULL, norm = norm)) } - jointResult <- .twasQdsJointDispatch( + jointResult <- .twasDispatchJointSpecsQtlDataset( parsedJointSpec, - intersect(norm$tokens, "mrmash"), - cfg + norm$tokens, + marker, + ctx, + contexts, + traitId ) keep <- setdiff(norm$tokens, intersect(norm$tokens, "mrmash")) if (length(keep) == 0L) { @@ -1715,40 +1718,106 @@ setMethod( ) } -# Normalize methods, run the capability / fine-mapping / fit-full gates and the -# mash-prior unpacking, then hand off to the joint phase. Returns the phase -# record extended with the mash-derived sample partition and CV prior matrices -# the per-tuple loop still needs. Mirrors .fmQdsResolveTokens. +# Parse the joint spec and normalize the methods, then run the capability, +# per-input argument and fine-mapping gates. The mash-prior unpacking and the +# joint phase follow once the pipeline marker exists (.twasJointSetup()), so +# that explicit joint fits run under the same marker as everything else. # @noRd .twasQdsResolveTokens <- function( jointSpecification, methods, fineMappingResult, - cvFolds, - fitFullData, - mashPrior, - samplePartition, - cfg + cvCfg, + data ) { - parsedJointSpec <- parseJointSpecification(jointSpecification, cfg$data) - rawNorm <- .twasNormalizeMethods(methods) - .twasCheckMethodCapabilities(rawNorm$tokens, "QtlDataset") + parsedJointSpec <- parseJointSpecification(jointSpecification, data) + norm <- .twasNormalizeMethods(methods) + .twasCheckMethodCapabilities(norm$tokens, "QtlDataset") .twasCheckMethodArgsForInput( - .twasMethodListArgs(rawNorm$methodList), + .twasMethodListArgs(norm$methodList), "QtlDataset" ) .twasCheckFineMappingMethods( - rawNorm$tokens, + norm$tokens, fineMappingResult, "QtlDataset", - cvFolds = cvFolds + cvFolds = cvCfg$folds, + fitFullData = cvCfg$fitFullData ) - .twasQdsCheckFitFull(fitFullData, cvFolds) - mash <- .twasQdsUnpackMash(mashPrior, samplePartition, rawNorm) - list_assign( - .twasQdsJointPhase(parsedJointSpec, mash$norm, cfg), - samplePartition = mash$samplePartition, - dataDrivenPriorMatricesCv = mash$dataDrivenPriorMatricesCv + list(parsedJointSpec = parsedJointSpec, norm = norm) +} + +# The individual-level settings a TWAS run fits under, as one record: built +# once by the QtlDataset method and once by the MultiStudyQtlDataset method, +# with the same builder, so a setting added for one reaches the other. +# @noRd +.twasJointCfg <- function( + contexts, + traitId, + cisWindow, + xRegions, + fineMappingResult, + mashPrior, + crossValidationParam, + ensembleParam, + estimatePi, + fitRetention, + residualizationParam, + weightsDataType, + verbose, + seed +) { + list( + contexts = contexts, + traitId = traitId, + cisWindow = cisWindow, + xRegions = xRegions, + fineMappingResult = fineMappingResult, + mashPrior = mashPrior, + crossValidationParam = crossValidationParam, + ensembleParam = ensembleParam, + estimatePi = estimatePi, + fitRetention = fitRetention, + residualizationParam = residualizationParam, + weightsDataType = weightsDataType, + verbose = verbose, + seed = seed + ) +} + +# Everything an individual-level TWAS fit on `data` needs from the record +# `cfg` (.twasJointCfg()): the mash prior unpacked into the methods, the +# pipeline marker, and the engine-args context. Used for the QtlDataset +# method's own run and for each MultiStudyQtlDataset component's joint fits. +# @noRd +.twasJointSetup <- function(data, norm, cfg) { + cvCfg <- .cvResolve(cfg$crossValidationParam) + mash <- .twasQdsUnpackMash(cfg$mashPrior, cvCfg$samplePartition, norm) + marker <- .twasQdsMarker( + crossValidationParam = list_assign( + cvCfg, + samplePartition = mash$samplePartition + ), + ensembleParam = .ensembleResolve(cfg$ensembleParam), + weightsDataType = cfg$weightsDataType, + standardized = .qtlScaleResiduals(data, cfg$residualizationParam), + fitRetention = cfg$fitRetention, + estimatePi = cfg$estimatePi, + verbose = cfg$verbose, + seed = cfg$seed + ) + list( + marker = marker, + ctx = list( + data = data, + xRegions = cfg$xRegions, + norm = mash$norm, + fineMappingResult = cfg$fineMappingResult, + dataDrivenPriorMatricesCv = mash$dataDrivenPriorMatricesCv, + cisWindow = cfg$cisWindow, + residualizationParam = cfg$residualizationParam, + verbose = cfg$verbose + ) ) } @@ -1770,26 +1839,18 @@ setMethod( study = studyName, useCtx = useCtx, allTraits = allTraits, + # Set only when traits are chosen context by context: the grid spans + # every (context, trait) pair of allTraits, and this drops the pairs + # the selection leaves out. + traitSelection = if (.hasNestedTraitSelection(traitId)) traitId, multivariate = any(map_lgl(tokens, .twasIsMultivariateToken)) ) } -# Selected contexts (all when NULL; else validated against the dataset). +# Selected contexts: those parseContexts() kept for this study, or all. # @noRd .twasQdsResolveContexts <- function(data, contexts) { - allCtx <- contexts(data) - if (is.null(contexts)) { - return(allCtx) - } - bad <- setdiff(contexts, allCtx) - if (length(bad) > 0L) { - badStr <- str_flatten(bad, ", ") - msg <- glue( - "twasWeightsPipeline(QtlDataset): unknown context(s): {badStr}" - ) - abort(msg) - } - contexts + .selectedContexts(contexts, studyName(data)) %||% contexts(data) } # Traits to iterate: traitId when supplied, else per-context region overlap, @@ -1813,9 +1874,8 @@ setMethod( # Joint-pipeline marker carrying the CV / ensemble config for the engine. # @noRd .twasQdsMarker <- function( - crossValidationArgs, - ensembleArgs, - fitFullData, + crossValidationParam, + ensembleParam, weightsDataType, standardized, fitRetention, @@ -1829,9 +1889,8 @@ setMethod( # The two groups travel as records, not as nine loose fields: # this function's only job is to store them, so unrolling them # into its signature would name each one twice for nothing. - crossValidationArgs = crossValidationArgs, - ensembleArgs = ensembleArgs, - fitFullData = fitFullData, + crossValidationParam = crossValidationParam, + ensembleParam = ensembleParam, dataType = weightsDataType, fitRetention = fitRetention, # DERIVED from what the accessors actually do: genotypes reach @@ -1843,7 +1902,7 @@ setMethod( estimatePi = estimatePi, verbose = verbose, seed = seed, - ldSketch = NULL + ldReference = NULL ) ) } @@ -1852,7 +1911,13 @@ setMethod( # adds top-PC rows ALONGSIDE the per-trait ones, matching # fineMappingPipeline's c(univRows, pcaRows). # @noRd -.twasQdsUnivPlan <- function(usePCA, studyName, useCtx, allTraits) { +.twasQdsUnivPlan <- function( + usePCA, + studyName, + useCtx, + allTraits, + traitSelection +) { univCell <- .lookupJointCell("univariate", "individual") list( cells = if (isTRUE(usePCA)) { @@ -1863,7 +1928,8 @@ setMethod( scope = list( studies = studyName, contexts = set_names(list(useCtx), studyName), - traits = set_names(list(allTraits), studyName) + traits = set_names(list(allTraits), studyName), + traitSelection = traitSelection ) ) } @@ -1876,6 +1942,7 @@ setMethod( studyName, useCtx, allTraits, + traitSelection, marker, data, xRegions, @@ -1885,12 +1952,18 @@ setMethod( dataDrivenPriorMatricesCv, cisWindow, naAction, - residualizationArgs, + residualizationParam, usePCA, nPCs, verbose ) { - plan <- .twasQdsUnivPlan(usePCA, studyName, useCtx, allTraits) + plan <- .twasQdsUnivPlan( + usePCA, + studyName, + useCtx, + allTraits, + traitSelection + ) cells <- plan$cells scope <- plan$scope labs <- map_chr(xRegions, .twasRegionLabel) @@ -1908,7 +1981,7 @@ setMethod( dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, cisWindow = cisWindow, naAction = naAction, - residualizationArgs = residualizationArgs, + residualizationParam = residualizationParam, nPCs = nPCs, verbose = verbose ) @@ -1927,7 +2000,7 @@ setMethod( dataDrivenPriorMatricesCv, cisWindow, naAction, - residualizationArgs, + residualizationParam, nPCs, verbose ) { @@ -1941,7 +2014,7 @@ setMethod( regionIndex = bi, nRegions = length(xRegions), naAction = naAction, - residualizationArgs = residualizationArgs, + residualizationParam = residualizationParam, nPCs = nPCs, verbose = verbose ) @@ -1975,7 +2048,7 @@ setMethod( if (is.null(jointResult)) { return(tw) } - .rbindTwasWeights(tw, jointResult, ldSketch = NULL) + .rbindTwasWeights(tw, jointResult, ldReference = NULL) } #' @rdname twasWeightsPipeline @@ -1995,12 +2068,12 @@ setMethod( weightsDataType = NULL, verbose = 1L, panelFilterParam = PanelFilterParam(), - crossValidationArgs = CrossValidationParam() + crossValidationParam = CrossValidationParam() ) { fitRetention <- arg_match(fitRetention) - .twasWarnUnretainableDetail(fitRetention, methods) + .twasWarnUnretainableDetail(fitRetention, methods, "QtlSumStats") .cvRefuseOnSumstats( - crossValidationArgs, + crossValidationParam, "twasWeightsPipeline", "QtlSumStats" ) @@ -2032,12 +2105,10 @@ setMethod( studyCol = part$studyCol, contextCol = part$contextCol, traitCol = part$traitCol, - ldSketch = part$ldSketch, + ldReference = part$ldReference, methodArgs = methodArgs ) c( - # The univariate builder keeps whatever the per-method fit returns, - # so it takes no fitRetention. exec( .twasQssUnivariateRows, !!!rowArgs, @@ -2045,6 +2116,7 @@ setMethod( data = cfg$data, twasWeights = cfg$twasWeights, weightsDataType = cfg$dataType, + fitRetention = cfg$fitRetention, fineMappingResult = cfg$fineMappingResult, panelFilterParam = cfg$panelFilterParam ), @@ -2079,17 +2151,16 @@ setMethod( verbose, panelFilterParam ) { - # summaryStatsQc() is mandatory before twasWeightsPipeline for SumStats - # input; it also drops variants not present in the ldSketch, so every - # entry's SNP set is a subset of the ldSketch panel by the time we get here. .twasAssertQcd(data) + contexts <- parseContexts(contexts, data) + traitId <- parseTraitIds(traitId, data) # One record of the settings the joint phase and the shared dispatcher # both need, so each names them once. jointCfg <- list( data = data, contexts = contexts, traitId = traitId, - dataType = weightsDataType, + weightsDataType = weightsDataType, verbose = verbose, fitRetention = fitRetention, panelFilterParam = panelFilterParam @@ -2149,12 +2220,12 @@ setMethod( panelFilterParam = panelFilterParam ) ) - .twasQssAssemble(rows, joint$result, part$ldSketch) + .twasQssAssemble(rows, joint$result, part$ldReference) } # Normalize the methods argument into (tokens, methodArgs). The default set # excludes fine-mapping methods; those must be requested explicitly together -# with a FineMappingResult passed via `fineMappingResult`. +# with a fine-mapping result passed via `fineMappingResult`. # @noRd .twasSumStatsMethodTokens <- function(methods) { if (is.null(methods)) { @@ -2180,12 +2251,6 @@ setMethod( "QtlSumStats" )) } - if (.isMethodOptions(methods)) { - return(list( - tokens = names(methods), - methodArgs = map(as.list(methods), as.list) - )) - } msg <- glue( "`methods` must be NULL, a character vector, a named list of ", "per-method options, or a TwasWeightsMethodsParam() record." @@ -2199,21 +2264,6 @@ setMethod( set_names(rep(list(list()), length(tokens)), tokens) } -# Run the joint engine for a QtlSumStats with the given spec + token set. -# @noRd -.twasQssJointDispatch <- function(jointSpec, tokens, cfg) { - .twasDispatchJointSpecsQtlSumStats( - jointSpec, - cfg$data, - tokens, - cfg$contexts, - cfg$traitId, - cfg$dataType, - cfg$verbose, - fitRetention = cfg$fitRetention, - panelFilterParam = cfg$panelFilterParam %||% PanelFilterParam() - ) -} # Joint-specification dispatch for mrmash. Returns list(done, result, tokens, # methodArgs): `done` requests an early return with `result`; otherwise the @@ -2228,9 +2278,10 @@ setMethod( methodArgs = methodArgs )) } - jointResult <- .twasQssJointDispatch( + jointResult <- .twasDispatchJointSpecsQtlSumStats( parsedJointSpec, - intersect(tokens, "mrmash"), + tokens, + methodArgs, cfg ) keep <- setdiff(tokens, "mrmash") @@ -2273,13 +2324,7 @@ setMethod( studyCol <- as.character(data$study) contextCol <- as.character(data$context) traitCol <- as.character(data$trait) - selRows <- .twasQssSelectRows( - data, - contextCol, - traitCol, - contexts, - traitId - ) + selRows <- .twasQssSelectRows(data, contexts, traitId) isMv <- map_lgl(tokens, .twasIsMultivariateToken) multivariateTokens <- tokens[isMv] univariateTokens <- tokens[!isMv] @@ -2297,29 +2342,14 @@ setMethod( selRows = selRows, multivariateTokens = multivariateTokens, univariateTokens = univariateTokens, - ldSketch = ldSketch(data) + ldReference = ldReference(data) ) } # Row indices matching the contexts / traitId filters (error if none). # @noRd -.twasQssSelectRows <- function( - data, - contextCol, - traitCol, - contexts, - traitId -) { - byContext <- if (is.null(contexts)) { - seq_len(nrow(data)) - } else { - which(is_in(contextCol, contexts)) - } - selRows <- if (is.null(traitId)) { - byContext - } else { - byContext[is_in(traitCol[byContext], traitId)] - } +.twasQssSelectRows <- function(data, contexts, traitId) { + selRows <- which(.sumStatsRowsSelected(data, contexts, traitId)) if (length(selRows) == 0L) { msg <- glue( "twasWeightsPipeline(QtlSumStats): no entries matched the ", @@ -2376,7 +2406,7 @@ setMethod( # Assemble a TwasWeights collection from a flat list of row records. # @noRd -.twasRowsToWeights <- function(rows, ldSketch) { +.twasRowsToWeights <- function(rows, ldReference) { if (length(rows) == 0L) { return(NULL) } @@ -2386,7 +2416,7 @@ setMethod( trait = map_chr(rows, "trait"), method = map_chr(rows, "method"), entry = map(rows, "entry"), - ldSketch = ldSketch + ldReference = ldReference ) } @@ -2425,16 +2455,29 @@ setMethod( ) } +# The pipeline's fitRetention for a summary-statistics weight function that +# takes one, unless the caller set it for that method; a function without the +# argument keeps no fit. "none" is passed on too, unlike on the +# individual-level path: the fine-mapping adapters here keep a slim fit +# unless told otherwise, so leaving it unset would not drop it. +# @noRd +.twasQssRetainArgs <- function(args, fnName, fitRetention) { + if (!is_in("fitRetention", names(formals(fnName)))) { + return(args) + } + list_assign(args, fitRetention = args$fitRetention %||% fitRetention) +} + # Run a weight function, warning (with `errPrefix`) and returning NULL on error. # @noRd #' @importFrom rlang try_fetch -.twasTryWeights <- function(fn, stat, ldMat, userArgs, errPrefix) { +.twasTryWeights <- function(fn, stat, ldReference, userArgs, errPrefix) { try_fetch( { wfn <- get(fn, mode = "function") wArgs <- .twasWeightCallArgs( fn, - list(stat = stat, LD = ldMat), + list(stat = stat, ldReference = ldReference), userArgs ) exec(wfn, !!!wArgs) @@ -2455,9 +2498,10 @@ setMethod( contextCol, traitCol, data, - ldSketch, + ldReference, twasWeights, weightsDataType, + fitRetention, fineMappingResult, methodArgs, panelFilterParam @@ -2473,9 +2517,10 @@ setMethod( contextCol = contextCol, traitCol = traitCol, data = data, - ldSketch = ldSketch, + ldReference = ldReference, twasWeights = twasWeights, weightsDataType = weightsDataType, + fitRetention = fitRetention, fineMappingResult = fineMappingResult, methodArgs = methodArgs, panelFilterParam = panelFilterParam @@ -2515,9 +2560,10 @@ setMethod( contextCol, traitCol, data, - ldSketch, + ldReference, twasWeights, weightsDataType, + fitRetention, fineMappingResult, methodArgs, panelFilterParam @@ -2536,7 +2582,7 @@ setMethod( st, ctx, tr, - ldSketch, + ldReference, cutoffs = .panelCutoffs(panelFilterParam) ) fitted <- compact(map( @@ -2547,6 +2593,7 @@ setMethod( tr = tr, fitCtx = fitCtx, methodArgs = methodArgs, + fitRetention = fitRetention, fineMappingResult = fineMappingResult, weightsDataType = weightsDataType )) @@ -2613,7 +2660,7 @@ setMethod( st, ctx, tr, - ldSketch, + ldReference, cutoffs = NULL ) { allDf <- as.data.frame( @@ -2632,7 +2679,7 @@ setMethod( "context='{ctx}', trait='{tr}'" ) df <- allDf[ - .panelKeepMask(allDf$variant_id, ldSketch, cutoffs, label), + .panelKeepMask(allDf$variant_id, ldReference, cutoffs, label), , drop = FALSE ] @@ -2644,19 +2691,19 @@ setMethod( varY = varY, variantNames = variantIds ) + # The entry's block of the reference, read once and shared by every + # method fitted to it. list( variantIds = variantIds, stat = stat, - ldMat = .ldFromSketch( - ldSketch, + ldReference = .ldRefInMemory( + ldReference, variantIds, label = "twasWeightsPipeline" ) ) } -# Fit one univariate method for one entry -> a row record, or NULL on skip. -# @noRd # The weight function's arguments for one tuple: the user's args and, when the # token is a fine-mapping method, the precomputed fit threaded into its # dedicated *Fit argument. NULL when such a token has no fit to thread. @@ -2688,6 +2735,8 @@ setMethod( list_assign(baseArgs, !!!set_names(list(fit), spec$adapter$rssFitArg)) } +# Fit one univariate method for one entry -> a row record, or NULL on skip. +# @noRd .twasQssUnivariateFitOne <- function( tk, st, @@ -2695,6 +2744,7 @@ setMethod( tr, fitCtx, methodArgs, + fitRetention, fineMappingResult, weightsDataType ) { @@ -2716,8 +2766,8 @@ setMethod( weights <- .twasTryWeights( spec$fn, fitCtx$stat, - fitCtx$ldMat, - userArgs, + fitCtx$ldReference, + .twasQssRetainArgs(userArgs, spec$fn, fitRetention), .twasFitErrUniv(tk, st, ctx, tr) ) if (is.null(weights)) { @@ -2783,7 +2833,7 @@ setMethod( contextCol, traitCol, data, - ldSketch, + ldReference, methodArgs, fitRetention, fineMappingResult, @@ -2809,7 +2859,7 @@ setMethod( contextCol = contextCol, traitCol = traitCol, data = data, - ldSketch = ldSketch, + ldReference = ldReference, methodArgs = methodArgs, fitRetention = fitRetention, fineMappingResult = fineMappingResult, @@ -2827,7 +2877,7 @@ setMethod( contextCol, traitCol, data, - ldSketch, + ldReference, methodArgs, fitRetention, fineMappingResult, @@ -2846,11 +2896,12 @@ setMethod( st, tr, ctxNames, - ldSketch = ldSketch, + ldReference = ldReference, cutoffs = .panelCutoffs(panelFilterParam) ) - ldMat <- .ldFromSketch( - ldSketch, + # The group's block of the reference, read once and shared by every method. + blockReference <- .ldRefInMemory( + ldReference, mvStat$variantIds, label = "twasWeightsPipeline" ) @@ -2862,7 +2913,7 @@ setMethod( tr = tr, ctxNames = ctxNames, mvStat = mvStat, - ldMat = ldMat, + blockReference = blockReference, methodArgs = methodArgs, fitRetention = fitRetention, fineMappingResult = fineMappingResult, @@ -2879,7 +2930,7 @@ setMethod( st, tr, ctxNames, - ldSketch = NULL, + ldReference = NULL, cutoffs = NULL ) { allDf <- as.data.frame( @@ -2897,7 +2948,7 @@ setMethod( "twasWeightsPipeline(QtlSumStats, multivariate): study='{st}', ", "trait='{tr}'" ) - keep <- .panelKeepMask(allDf$variant_id, ldSketch, cutoffs, label) + keep <- .panelKeepMask(allDf$variant_id, ldReference, cutoffs, label) firstDf <- allDf[keep, , drop = FALSE] variantIds <- firstDf$variant_id filled <- .twasQssFillContexts(data, st, tr, ctxNames, variantIds) @@ -2911,11 +2962,6 @@ setMethod( ) } -# Read each context's z / N into the shared matrix. Every context must present -# the same SNPs in the same order -- the multivariate fitters index z by -# position, not by name, so a differing order would silently pair one context's -# variant with another's. -# @noRd # One context's z column and median N, checked against the shared SNP order. # @noRd .twasQssContextStats <- function(ctx, data, st, tr, variantIds) { @@ -2932,9 +2978,15 @@ setMethod( list(z = kept$z, n = stats::median(kept$N, na.rm = TRUE)) } +# Read each context's z / N into the shared matrix. Every context must present +# the same SNPs in the same order -- the multivariate fitters index z by +# position, not by name, so a differing order would silently pair one context's +# variant with another's. +# # Every context shares one SNP order (asserted per context), which is what # lets the columns simply be laid side by side rather than filled into a # preallocated matrix. +# @noRd .twasQssFillContexts <- function(data, st, tr, ctxNames, variantIds) { stats <- map( ctxNames, @@ -2964,7 +3016,7 @@ setMethod( "twasWeightsPipeline(QtlSumStats, multivariate): every ", "entry for (study='{st}', trait='{tr}') must share an ", "identical SNP order after summaryStatsQc(). Use the same ", - "ldSketch on every entry." + "ldReference on every entry." )) } @@ -2982,10 +3034,14 @@ setMethod( fitRetention, fineMappingResult ) { - baseArgs <- .twasMrmashRetainDefaults( - .twasUserArgs(methodArgs, tk), - spec$adapter, - tk, + baseArgs <- .twasQssRetainArgs( + .twasMrmashRetainDefaults( + .twasUserArgs(methodArgs, tk), + spec$adapter, + tk, + fitRetention + ), + spec$fn, fitRetention ) if (is.null(spec$adapter)) { @@ -3003,7 +3059,8 @@ setMethod( } # Fit one multivariate method for a group -> one row record per context (empty -# list on skip). +# list on skip). `userArgs` is NULL when the pre-fit a fine-mapping token needs +# is missing. # @noRd .twasQssMultivariateFitOne <- function( tk, @@ -3011,7 +3068,7 @@ setMethod( tr, ctxNames, mvStat, - ldMat, + blockReference, methodArgs, fitRetention, fineMappingResult, @@ -3033,22 +3090,43 @@ setMethod( fitRetention = fitRetention, fineMappingResult = fineMappingResult ) - # NULL when the pre-fit a fine-mapping token needs is missing. if (is.null(userArgs)) { return(list()) } weights <- .twasTryWeights( spec$fn, mvStat$stat, - ldMat, + blockReference, userArgs, .twasFitErrMv(tk, st, tr) ) + .twasMvRowsFromWeights( + weights, + ctxNames, + mvStat, + st, + tr, + tk, + weightsDataType + ) +} + +# Per-context row records from one multivariate fit's weights (empty list when +# the fit failed and `weights` is NULL). The fit is hung off the weights as an +# attribute; the rows store the two separately. +# @noRd +.twasMvRowsFromWeights <- function( + weights, + ctxNames, + mvStat, + st, + tr, + tk, + weightsDataType +) { if (is.null(weights)) { return(list()) } - # The fit is hung off the weights as an attribute; the rows store the - # two separately. wMatrix <- if (is.matrix(weights)) weights else as.matrix(weights) fitAttr <- attr(wMatrix, "fit") bare <- `attr<-`(wMatrix, "fit", NULL) @@ -3143,9 +3221,9 @@ setMethod( .twasQssAssemble <- function( rows, jointResult, - ldSketch + ldReference ) { - perTupleResult <- .twasRowsToWeights(rows, ldSketch) + perTupleResult <- .twasRowsToWeights(rows, ldReference) if (is.null(jointResult)) { if (is.null(perTupleResult)) { msg <- glue( @@ -3159,7 +3237,7 @@ setMethod( if (is.null(perTupleResult)) { return(jointResult) } - .rbindTwasWeights(perTupleResult, jointResult, ldSketch = ldSketch) + .rbindTwasWeights(perTupleResult, jointResult, ldReference = ldReference) } # ============================================================================= @@ -3174,24 +3252,28 @@ setMethod( # Per-embedded-study TWAS-weights worker for .multiStudyPipelineDriver: recurse # twasWeightsPipeline on one QtlDataset. `cfg` bundles the parent's forwarded # args. +# +# Every setting is named -- not the `...`/dotArgs channel this once spliced, +# which is what made multi-study TWAS inherit the per-study CV default and +# silently drop residualization / fitRetention. A name this entry point does +# not accept is an "unused argument" error; `cfg`'s panelFilterParam belongs +# to the summary-statistics path and is deliberately not forwarded. # @noRd .twasPerStudy <- function(qd, cfg) { - # Checked forwarding, not the `...`/dotArgs channel this used to splice: - # that is what made multi-study TWAS inherit the per-study CV default and - # silently drop residualization / fitRetention. - # Every setting is named -- NOT the `...`/dotArgs channel this once - # spliced, which is what made multi-study TWAS inherit the per-study CV - # default and silently drop residualization / fitRetention. A name this - # entry point does not accept is an "unused argument" error; `cfg`'s - # panelFilterArgs belongs to the summary-statistics path and is - # deliberately not forwarded. + # `cfg` carries the parsed selection for every study; this study gets its + # own share, and a study with none of its contexts selected sits out. + s <- studyName(qd) + contexts <- .selectedContexts(cfg$contexts, s) + if (!is.null(contexts) && length(contexts) == 0L) { + return(NULL) + } twasWeightsPipeline( data = qd, jointSpecification = NULL, - fitRetention = .twasRetentionEnum(cfg), + fitRetention = cfg$fitRetention, methods = cfg$methods, - contexts = cfg$contexts, - traitId = cfg$traitId, + contexts = contexts, + traitId = .studyTraitIdArg(cfg$traitId, s), region = cfg$region, cisWindow = cfg$cisWindow, jointRegions = cfg$jointRegions, @@ -3199,15 +3281,16 @@ setMethod( twasWeights = cfg$twasWeights, naAction = cfg$naAction, verbose = cfg$verbose, - crossValidationArgs = cfg$crossValidationArgs, - ensembleArgs = cfg$ensembleArgs, + crossValidationParam = cfg$crossValidationParam, + ensembleParam = cfg$ensembleParam, seed = cfg$seed, genotypeFilterParam = cfg$genotypeFilterParam, mashPrior = cfg$mashPrior, - fitFullData = cfg$fitFullData, estimatePi = cfg$estimatePi, - weightsDataType = cfg$dataType, - residualizationArgs = cfg$residualizationArgs + usePCA = cfg$usePCA, + nPCs = cfg$nPCs, + weightsDataType = cfg$weightsDataType, + residualizationParam = cfg$residualizationParam ) } @@ -3218,37 +3301,36 @@ setMethod( # from, residualize, cross-validate, stack or fit on full data. `cfg` # carries those for the individual-level sibling and they are not # forwarded here. + # + # The parsed selection is applied here, to the rows, so the recursion runs + # on what it keeps with nothing left to filter -- and rows it leaves out + # are not an error when another component holds the selected tuples. + keepRows <- .sumStatsRowsSelected(ss, cfg$contexts, cfg$traitId) + if (!any(keepRows)) { + return(NULL) + } twasWeightsPipeline( - data = ss, + data = if (all(keepRows)) ss else ss[which(keepRows)], jointSpecification = NULL, - fitRetention = .twasRetentionEnum(cfg), + fitRetention = cfg$fitRetention, methods = cfg$methods, - contexts = cfg$contexts, - traitId = cfg$traitId, + contexts = NULL, + traitId = NULL, fineMappingResult = cfg$fineMappingResult, twasWeights = cfg$twasWeights, verbose = cfg$verbose, panelFilterParam = cfg$panelFilterParam, - weightsDataType = cfg$dataType + weightsDataType = cfg$weightsDataType ) } -# The config carries the engine-facing pair; the per-study recursion re-enters -# the public method, which takes the single enum. One place converts back. +# Few methods distinguish the retention levels (.twasFullDetailTokens()); +# every other weight method keeps its fit whole or not at all, so "full" is +# the same as "slim" for them. Erroring when NO requested method can honour +# it, and warning when only some can, is the alternative to dropping it in +# silence. Which methods can depends on the input the run reads. # @noRd -.twasRetentionEnum <- function(cfg) { - if (!isTRUE(cfg$fitRetention)) { - return("none") - } - cfg$fitRetention %||% "slim" -} - -# Only the mr.mash engines distinguish the retention levels; every other -# weight method keeps its fit whole or not at all, so "full" is the same as -# "slim" for them. Erroring when NO requested method can honour it, and -# warning when only some can, is the alternative to dropping it in silence. -# @noRd -.twasWarnUnretainableDetail <- function(fitRetention, methods) { +.twasWarnUnretainableDetail <- function(fitRetention, methods, inputKind) { if (!identical(fitRetention, "full")) { return(invisible(NULL)) } @@ -3256,12 +3338,14 @@ setMethod( if (length(tokens) == 0L) { return(invisible(NULL)) } - honours <- str_detect(tokens, regex("mrmash", ignore_case = TRUE)) + honouring <- .twasFullDetailTokens(inputKind) + honours <- is_in(tokens, honouring) if (!any(honours)) { abort(glue( - "twasWeightsPipeline: fitRetention = \"full\" is only honoured ", - "by the mr.mash methods; {str_flatten(tokens, ', ')} cannot vary ", - "the retained detail. Use fitRetention = \"slim\"." + "twasWeightsPipeline: fitRetention = \"full\" is honoured on ", + "{inputKind} input only by {str_flatten(honouring, ', ')}; ", + "{str_flatten(tokens, ', ')} cannot vary the retained detail. ", + "Use fitRetention = \"slim\"." )) } if (!all(honours)) { @@ -3274,6 +3358,18 @@ setMethod( invisible(NULL) } +# The methods whose "full" fit keeps more than their "slim" one, on one input +# path: mr.mash's whole fit, and on summary statistics the shrinkage-grid +# methods' candidate coefficients (lassosumRssWeights() and the penalized +# RSS weights). +# @noRd +.twasFullDetailTokens <- function(inputKind) { + if (identical(inputKind, "QtlSumStats")) { + return(c("mrmash", "lasso", "scad", "mcp", "l0learn")) + } + "mrmash" +} + # ---- MultiStudyQtlDataset pipeline worker + phase helpers ------------------ # Method tokens from a `methods` arg: a character vector as-is; a named list -> @@ -3283,7 +3379,6 @@ setMethod( if (.twasMethodsIsParam(methods)) { return(.methodsParamTokens(methods)) } - methods <- .twasMethodsAsList(methods) if (is.character(methods)) { methods } else if (is.list(methods)) { @@ -3293,16 +3388,6 @@ setMethod( } } -# Drop mrmash (handled by the joint dispatcher) from a `methods` arg. -# @noRd -# A methods argument as an ordinary named list, whatever form it arrived in. -# A MethodOptions record is a SimpleList, so `is.list()` is FALSE for it and the -# helpers below would otherwise fall through to their "leave it alone" branch. -# @noRd -.twasMethodsAsList <- function(methods) { - if (.isMethodOptions(methods)) as.list(methods) else methods -} - # A MethodsSelectionParam keeps its structure through these helpers: the # token questions read across all three slots, and dropping a method drops # it from each, so the per-component recursion still receives a Param that @@ -3312,11 +3397,12 @@ setMethod( is(methods, "MethodsSelectionParam") } +# Drop mrmash (handled by the joint dispatcher) from a `methods` arg. +# @noRd .twasMsStripMrmash <- function(methods) { if (.twasMethodsIsParam(methods)) { return(.methodsParamDrop(methods, "mrmash")) } - methods <- .twasMethodsAsList(methods) if (is.character(methods)) { setdiff(methods, "mrmash") } else if (is.list(methods)) { @@ -3335,29 +3421,14 @@ setMethod( if (.twasMethodsIsParam(methods)) { return(length(.methodsParamTokens(methods)) == 0L) } - methods <- .twasMethodsAsList(methods) (is.character(methods) || is.list(methods)) && length(methods) == 0L } -# Resolve the MultiStudyQtlDataset inputs: the region/cisWindow guard, the -# naAction choice and the joint-region spec. Mirrors .fmMsResolveInputs so -# both MultiStudy workers read the same way, rather than one open-coding -# what the other names. +# The MultiStudyQtlDataset method of twasWeightsPipeline(). `jointCfg` is the +# QtlDataset method's own record (.twasJointCfg()) plus the collection and the +# two filter settings the components apply, so each component's joint fits +# run under the settings its own QtlDataset run would use. # @noRd -.twasMsResolveInputs <- function(naAction, region, cisWindow, jointRegions) { - if (!is.null(region) && !is.null(cisWindow)) { - msg <- glue( - "twasWeightsPipeline(MultiStudyQtlDataset): specify either ", - "`region` or `cisWindow`, not both." - ) - abort(msg) - } - list( - naAction = arg_match(naAction, c("drop", "impute")), - xRegions = .makeXRegions(region, jointRegions) - ) -} - .twasPipelineMultiStudy <- function( data, methods = "default", @@ -3372,33 +3443,55 @@ setMethod( fineMappingResult = NULL, twasWeights = NULL, mashPrior = NULL, - fitFullData = TRUE, estimatePi = TRUE, + usePCA = FALSE, + nPCs = 10L, fitRetention = c("slim", "none", "full"), weightsDataType = NULL, naAction = c("drop", "impute"), verbose = 1, - residualizationArgs = ResidualizationParam(), - crossValidationArgs = CrossValidationParam(), - ensembleArgs = EnsembleParam(), + residualizationParam = ResidualizationParam(), + crossValidationParam = CrossValidationParam(), + ensembleParam = EnsembleParam(), seed = NULL ) { fitRetention <- arg_match(fitRetention) - .twasWarnUnretainableDetail(fitRetention, methods) - inputs <- .twasMsResolveInputs(naAction, region, cisWindow, jointRegions) + # Every collection holds individual-level studies, so their rule applies + # here; a summary-statistic study is checked again by its own route. + .twasWarnUnretainableDetail(fitRetention, methods, "QtlDataset") + inputs <- .msResolveInputs( + naAction, + region, + cisWindow, + jointRegions, + "twasWeightsPipeline(MultiStudyQtlDataset)" + ) naAction <- inputs$naAction - # One record of the settings the joint phase and the shared dispatcher - # both need, so each names them once. - jointCfg <- list( - data = data, - contexts = contexts, - traitId = traitId, + cfg <- .twasMsCfg( + methods = methods, + contexts = parseContexts(contexts, data), + traitId = parseTraitIds(traitId, data), + region = region, cisWindow = cisWindow, + jointRegions = jointRegions, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + naAction = naAction, verbose = verbose, - xRegions = inputs$xRegions, + crossValidationParam = crossValidationParam, + ensembleParam = ensembleParam, + seed = seed, + genotypeFilterParam = genotypeFilterParam, + panelFilterParam = panelFilterParam, + mashPrior = mashPrior, + estimatePi = estimatePi, + usePCA = usePCA, + nPCs = nPCs, fitRetention = fitRetention, - seed = seed + weightsDataType = weightsDataType, + residualizationParam = residualizationParam ) + jointCfg <- .twasMsJointCfg(cfg, data, inputs$xRegions) joint <- .twasMsResolveTokens( jointSpecification, methods, @@ -3408,30 +3501,37 @@ setMethod( if (joint$done) { return(joint$result) } - .twasMsDriver( + .twasMsDriver(data, joint$result, list_assign(cfg, methods = joint$methods)) +} + +# The MultiStudyQtlDataset joint record, derived from the record the +# per-component recursion receives (`cfg`, .twasMsCfg()): the settings each +# component's own QtlDataset run fits under (.twasJointCfg()), plus the +# collection and the two filters the components apply. Deriving it, rather +# than re-listing the settings, keeps the per-study joint fits on exactly the +# settings of the per-study fits. +# @noRd +.twasMsJointCfg <- function(cfg, data, xRegions) { + list_assign( + .twasJointCfg( + contexts = cfg$contexts, + traitId = cfg$traitId, + cisWindow = cfg$cisWindow, + xRegions = xRegions, + fineMappingResult = cfg$fineMappingResult, + mashPrior = cfg$mashPrior, + crossValidationParam = cfg$crossValidationParam, + ensembleParam = cfg$ensembleParam, + estimatePi = cfg$estimatePi, + fitRetention = cfg$fitRetention, + residualizationParam = cfg$residualizationParam, + weightsDataType = cfg$weightsDataType, + verbose = cfg$verbose, + seed = cfg$seed + ), data = data, - contexts = contexts, - traitId = traitId, - cisWindow = cisWindow, - region = region, - jointRegions = jointRegions, - fineMappingResult = fineMappingResult, - twasWeights = twasWeights, - naAction = naAction, - verbose = verbose, - crossValidationArgs = crossValidationArgs, - ensembleArgs = ensembleArgs, - seed = seed, - genotypeFilterParam = genotypeFilterParam, - panelFilterParam = panelFilterParam, - mashPrior = mashPrior, - fitFullData = fitFullData, - estimatePi = estimatePi, - fitRetention = fitRetention, - weightsDataType = weightsDataType, - residualizationArgs = residualizationArgs, - joint$result, - joint$methods + genotypeFilterParam = cfg$genotypeFilterParam, + panelFilterParam = cfg$panelFilterParam ) } @@ -3443,25 +3543,6 @@ setMethod( .twasPipelineMultiStudy ) -# Run the joint engine for a MultiStudyQtlDataset with the given spec + token -# set. The NULL in the dataType slot is deliberate: the per-component -# recursion resolves each study's own data type. -# @noRd -.twasMsJointDispatch <- function(jointSpec, tokens, cfg) { - .twasDispatchJointSpecsMultiStudy( - jointSpec, - cfg$data, - tokens, - cfg$contexts, - cfg$traitId, - cfg$cisWindow, - NULL, - cfg$verbose, - xRegions = cfg$xRegions, - fitRetention = cfg$fitRetention, - seed = cfg$seed - ) -} # Joint-specification dispatch for mrmash. Returns list(done, result, methods) # where `done` requests an early return with `result` and `methods` is the @@ -3477,9 +3558,10 @@ setMethod( ) return(list(done = FALSE, result = NULL, methods = methods)) } - jointResult <- .twasMsJointDispatch( + jointResult <- .twasDispatchJointSpecsMultiStudy( parsedJointSpec, - intersect(.twasMethodTokensFromArg(methods), "mrmash"), + .twasMethodTokensFromArg(methods), + methods, cfg ) stripped <- .twasMsStripMrmash(methods) @@ -3525,39 +3607,59 @@ setMethod( .twasCheckFineMappingMethods( .twasMethodTokensFromArg(methods), fineMappingResult, - "MultiStudyQtlDataset" + "MultiStudyQtlDataset", + fitFullData = .cvResolve(cfg$crossValidationParam)$fitFullData ) .twasMsJointPhase(parsedJointSpec, methods, cfg) } # Run the per-study / per-component recursion via the shared multi-study driver. +# `cfg` is the `.twasMsCfg()` record of the settings each component re-runs +# with. # @noRd -.twasMsDriver <- function( - data, +.twasMsDriver <- function(data, jointResult, cfg) { + .multiStudyPipelineDriver( + data, + jointResult, + .twasPerStudy, + .twasSumStats, + cfg, + .rbindTwasWeights, + TwasWeights, + "twasWeightsPipeline", + noun = "weights" + ) +} + +# The settings the per-study / per-component recursion re-runs each component +# with, as the record .multiStudyPipelineDriver() hands to .twasPerStudy / +# .twasSumStats. +# @noRd +.twasMsCfg <- function( + methods, contexts, traitId, - cisWindow, region, + cisWindow, jointRegions, fineMappingResult, twasWeights, naAction, verbose, - crossValidationArgs, - ensembleArgs, + crossValidationParam, + ensembleParam, seed, genotypeFilterParam, panelFilterParam, mashPrior, - fitFullData, estimatePi, + usePCA, + nPCs, fitRetention, weightsDataType, - residualizationArgs, - jointResult, - methods + residualizationParam ) { - cfg <- list( + list( methods = methods, contexts = contexts, traitId = traitId, @@ -3568,28 +3670,18 @@ setMethod( twasWeights = twasWeights, naAction = naAction, verbose = verbose, - crossValidationArgs = crossValidationArgs, - ensembleArgs = ensembleArgs, + crossValidationParam = crossValidationParam, + ensembleParam = ensembleParam, seed = seed, genotypeFilterParam = genotypeFilterParam, panelFilterParam = panelFilterParam, mashPrior = mashPrior, - fitFullData = fitFullData, estimatePi = estimatePi, + usePCA = usePCA, + nPCs = nPCs, fitRetention = fitRetention, - dataType = weightsDataType, - residualizationArgs = residualizationArgs - ) - .multiStudyPipelineDriver( - data, - jointResult, - .twasPerStudy, - .twasSumStats, - cfg, - .rbindTwasWeights, - TwasWeights, - "twasWeightsPipeline", - noun = "weights" + weightsDataType = weightsDataType, + residualizationParam = residualizationParam ) } @@ -3686,26 +3778,21 @@ setMethod( zetaValid / zetaSum } -# Ensemble stacking objective (sum of squared residuals). `...` absorbs the -# gradient's extra optim args (PtP, Pty). +# Ensemble stacking objective: the sum of squared residuals of the stacked +# prediction `Pvalid %*% z`. `problem` is the record .solveEnsembleLbfgsb() +# builds once -- the predictions, the outcome and their cross-products -- and +# hands optim() as its single extra argument, so the objective and its +# gradient read one shared definition, each taking the part it needs. # @noRd -.ensembleObj <- function(Pvalid, yObs) { - # Captured by name, and forced here so the closure holds values rather - # than promises into a frame that has already returned. - force(Pvalid) - force(yObs) - function(z) sum((yObs - Pvalid %*% z)^2) +.ensembleObj <- function(z, problem) { + sum((problem$yObs - problem$Pvalid %*% z)^2) } -# Gradient of the ensemble stacking objective, same construction. Building -# both as closures of exactly what each needs is what lets optim() be called -# with no `...`: previously it forwarded the union of both callbacks' -# arguments to both, and each absorbed the other's half in a `...` tail. +# Gradient of the stacking objective, 2 (P'P z - P'y), from the +# cross-products in `problem`. # @noRd -.ensembleGrad <- function(PtP, Pty) { - force(PtP) - force(Pty) - function(z) as.vector(2 * (PtP %*% z - Pty)) +.ensembleGrad <- function(z, problem) { + as.vector(2 * (problem$PtP %*% z - problem$Pty)) } # Solve ensemble stacking via L-BFGS-B (box-constrained optimization, then @@ -3717,14 +3804,18 @@ setMethod( # @return Normalized coefficient vector of length Kvalid. # @noRd .solveEnsembleLbfgsb <- function(Pvalid, yObs, Kvalid) { - PtP <- crossprod(Pvalid) - Pty <- as.vector(crossprod(Pvalid, yObs)) - + problem <- list( + Pvalid = Pvalid, + yObs = yObs, + PtP = crossprod(Pvalid), + Pty = as.vector(crossprod(Pvalid, yObs)) + ) fit <- try_fetch( optim( par = rep(1 / Kvalid, Kvalid), - fn = .ensembleObj(Pvalid, yObs), - gr = .ensembleGrad(PtP, Pty), + fn = .ensembleObj, + gr = .ensembleGrad, + problem = problem, method = "L-BFGS-B", lower = rep(0, Kvalid) ), @@ -4153,8 +4244,6 @@ ensembleWeights <- function( invisible(NULL) } -# Assemble one dataset's (samples x methods) prediction matrix. -# @noRd # One method's aligned prediction column for dataset `d`. # @noRd .ensemblePredColumn <- function(k, predsD, nm, aln, contextIndex, d) { @@ -4178,6 +4267,8 @@ ensembleWeights <- function( pCol } +# Assemble one dataset's (samples x methods) prediction matrix. +# @noRd .ensembleBuildPd <- function(predsD, nm, aln, contextIndex, d) { cols <- map( seq_along(nm$predNames), @@ -4324,8 +4415,6 @@ ensembleWeights <- function( if (is.matrix(w)) w else matrix(w, ncol = 1) } -# Zeta-weighted sum of the matched weight matrices; univariate -> named vector. -# @noRd # One method's zeta-scaled contribution, or NULL when its weight matrix does # not line up with the first one's shape. # @noRd @@ -4343,6 +4432,8 @@ ensembleWeights <- function( zeta[i] * wMat } +# Zeta-weighted sum of the matched weight matrices; univariate -> named vector. +# @noRd .ensembleAccumulateWeights <- function(wtList, wtKeys, matched, zeta) { firstWt <- .ensembleAsMatrix(wtList[[wtKeys[which(matched)[1]]]]) shape <- dim(firstWt) @@ -4400,33 +4491,6 @@ ensembleWeights <- function( ) } -# The entry in one region's collection matching a (study, context, trait, -# method) key, or NULL when that region lacks it. -# @noRd -.twasEntryMatchingKey <- function(tw, key) { - hit <- which( - as.character(tw$study) == key[[1L]] & - as.character(tw$context) == key[[2L]] & - as.character(tw$trait) == key[[3L]] & - as.character(tw$method) == key[[4L]] - ) - if (length(hit)) .twrRowParts(tw, hit[[1L]]) else NULL -} - -# The merged entry for base row `r`: gather that key's entry from every region -# and concatenate them. -# @noRd -.twasMergedEntryForRow <- function(r, base, twList, regionLabels) { - key <- c( - as.character(base$study[[r]]), - as.character(base$context[[r]]), - as.character(base$trait[[r]]), - as.character(base$method[[r]]) - ) - perRegion <- map(twList, .twasEntryMatchingKey, key = key) - .twasMergeRegionEntries(perRegion, regionLabels) -} - # Canonical method name for a snake_case token (identity when not in the table). # @noRd .twasCanonicalMethod <- function(s, snakeToCanonical) { @@ -4439,39 +4503,57 @@ ensembleWeights <- function( .twasCapabilityViolation(caps[[tk]], tk, inputKind) } -# One region's multivariate-grid joint fit (region `bi` of ctx$xRegions). +# One region block of .twasRunJointSpecGrid(). # @noRd -.twasMvGridRegion <- function(bi, synthSpec, marker, ctx, traits) { +.twasJointSpecRegion <- function( + bi, + spec, + tokens, + contexts, + traits, + marker, + ctx +) { .runJointSpecs( - synthSpec, + spec, ctx$data, dataForm = "individual", pipeline = marker, - jointMethods = ctx$norm$tokens, - contexts = ctx$useCtx, + jointMethods = tokens, + contexts = contexts, traitIds = traits, - args = list( - methodList = ctx$norm$methodList, - fineMappingResult = ctx$fineMappingResult, - dataDrivenPriorMatricesCv = ctx$dataDrivenPriorMatricesCv, - cisWindow = ctx$cisWindow, - region = ctx$xRegions[[bi]], - regionIndex = bi, - nRegions = length(ctx$xRegions), - residualizationArgs = ctx$residualizationArgs, - verbose = ctx$verbose - ) + args = .twasJointArgs(ctx, bi) + ) +} + +# The engine `args` of an individual-level TWAS joint run over region block +# `bi`. Residualization rides here: the group enumerators read it while +# extracting X and Y. +# @noRd +.twasJointArgs <- function(ctx, bi) { + list( + methodList = ctx$norm$methodList, + fineMappingResult = ctx$fineMappingResult, + dataDrivenPriorMatricesCv = ctx$dataDrivenPriorMatricesCv, + cisWindow = ctx$cisWindow, + region = ctx$xRegions[[bi]], + regionIndex = bi, + nRegions = length(ctx$xRegions), + residualizationParam = ctx$residualizationParam, + verbose = ctx$verbose ) } -# The traits of one context: traitId when supplied, else region overlap, else -# every trait in the context. +# The traits of one context: those traitId selects there, else region +# overlap, else every trait in the context. A traitId that leaves this +# context out keeps all of its traits -- region picks traits only when no +# traitId is given at all. # @noRd .twasQdsCtxTraits <- function(ctx, data, traitId, region) { se <- molecularTraits(data, contexts = ctx) ids <- rownames(se) if (!is.null(traitId)) { - intersect(ids, traitId) + intersect(ids, .selectedTraits(traitId, studyName(data), ctx) %||% ids) } else if (!is.null(region)) { rr <- SummarizedExperiment::rowRanges(se) ids[IRanges::overlapsAny(rr, region)] @@ -4495,7 +4577,7 @@ ensembleWeights <- function( dataDrivenPriorMatricesCv, cisWindow, naAction, - residualizationArgs, + residualizationParam, nPCs, verbose ) { @@ -4510,7 +4592,7 @@ ensembleWeights <- function( dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, cisWindow = cisWindow, naAction = naAction, - residualizationArgs = residualizationArgs, + residualizationParam = residualizationParam, nPCs = nPCs, verbose = verbose ) @@ -4745,26 +4827,26 @@ EnsembleParam <- function( # predictions, so without folds there is nothing to stack -- and the old # behaviour was to return a result silently missing its ensemble row. # @noRd -.ensembleAssertCv <- function(ensembleArgs, crossValidationArgs) { - if (!isTRUE(ensembleArgs$enabled) || .cvEnabled(crossValidationArgs)) { +.ensembleAssertCv <- function(ensembleParam, crossValidationParam) { + if (!isTRUE(ensembleParam$enabled) || .cvEnabled(crossValidationParam)) { return(invisible(NULL)) } abort(glue( "twasWeightsPipeline: EnsembleParam(enabled = TRUE) needs ", "out-of-fold predictions to stack, so it requires ", "CrossValidationParam(folds >= 2); got folds = ", - "{crossValidationArgs$folds %||% 0}." + "{crossValidationParam$folds %||% 0}." )) } # The ensemble settings as a plain list, so a cfg record can carry the group # as one named field instead of four loose ones. # @noRd -.ensembleResolve <- function(ensembleArgs) { +.ensembleResolve <- function(ensembleParam) { list( - enabled = isTRUE(ensembleArgs$enabled), - r2Threshold = ensembleArgs$r2Threshold %||% 0.01, - solver = ensembleArgs$solver %||% "quadprog", - alpha = ensembleArgs$alpha %||% 1 + enabled = isTRUE(ensembleParam$enabled), + r2Threshold = ensembleParam$r2Threshold %||% 0.01, + solver = ensembleParam$solver %||% "quadprog", + alpha = ensembleParam$alpha %||% 1 ) } diff --git a/R/variantId.R b/R/variantId.R index b162df998..42970a797 100644 --- a/R/variantId.R +++ b/R/variantId.R @@ -20,8 +20,10 @@ stripChrPrefix <- function(x) str_remove(x, "^chr") #' Canonicalize chromosome identifiers to a normalized string. #' -#' Strips a leading "chr"/"ch" prefix (case-insensitive), uppercases, and maps -#' common synonyms to a single form (23 -> X, 24 -> Y, M -> MT). Returns a +#' Strips a leading "chr"/"ch" prefix (case-insensitive), uppercases, drops +#' the leading zeros of a numeric label (01 -> 1, as UK Biobank's BGEN files +#' write chromosomes) and maps common synonyms to a single form (23 -> X, +#' 24 -> Y, M -> MT). Returns a #' character vector and never coerces to integer, so non-autosomal chromosomes #' (X, Y, MT) survive instead of collapsing to NA. This is the single chromosome #' normalizer used for variant matching and identity throughout the package; it @@ -34,7 +36,8 @@ canonChrom <- function(x) { bare <- as.character(x) |> str_remove(regex("^chr", ignore_case = TRUE)) |> str_remove(regex("^ch", ignore_case = TRUE)) |> - str_to_upper() + str_to_upper() |> + str_remove("^0+(?=[0-9]+$)") canonChromLabel(bare) } @@ -111,7 +114,7 @@ isSnpAlleles <- function(a1, a2) { #' belongs -- \code{chr21:13988152:INS:T} whose real alleles are #' \code{A}/\code{AT} -- so the id string stops encoding its alleles even #' though the panel's own A1/A2 columns are correct. The id-string matchers -#' (\code{.ldFromSketchMatch}, \code{.subsetSketchToIds}) key on the id and +#' (\code{.ldFromRefMatch}, \code{.subsetLdRefToIds}) key on the id and #' cannot interpret such a record. The allele COLUMNS are authoritative, so the #' id is rebuilt from them; the variant is never dropped for how its id happens #' to spell an allele. @@ -471,16 +474,15 @@ normalizeVariantId <- function(ids, chrPrefix = TRUE, convention = NULL) { #' is `FALSE`. #' @param removeUnmatched Whether to remove unmatched variants. Default is #' `TRUE`. -#' @return An \code{AlleleQcResult} S4 object. Use \code{$harmonizedData} to -#' recover the post-QC variant data.frame and \code{$qcSummary} to inspect the -#' per-variant merge/flip/strand diagnostics. +#' @return A list with \code{harmonizedData}, the post-QC variant +#' data.frame, and \code{qcSummary}, the per-variant merge/flip/strand +#' diagnostics. #' @importFrom dplyr mutate inner_join filter pull select everything row_number #' @importFrom dplyr if_else any_of all_of rename across #' @importFrom purrr partial #' @importFrom vctrs vec_duplicate_detect #' @importFrom tidyr separate #' @keywords internal -#' @noRd #' @details Pure panel-vs-sumstats allele harmonization: match by (chrom, pos), #' detect A1/A2 swap, sign-flip \code{colToFlip} columns and complement #' \code{colToComplement} columns on swap. Variant-allele filters (indels, @@ -488,6 +490,7 @@ normalizeVariantId <- function(ids, chrPrefix = TRUE, convention = NULL) { #' corresponding \code{removeIndels} / \code{removeStrandAmbiguous} / #' \code{removeDups} flags are set; MAF / INFO / N column-numeric filters run #' in \code{.applyContentFilters()} before this function. +#' @noRd harmonizeAlleles <- function( targetData, refVariants, diff --git a/README.md b/README.md index f8b3482e6..d1558c873 100644 --- a/README.md +++ b/README.md @@ -50,8 +50,9 @@ Now you should be able to build `pecotmr` from source. ## Developer's notes + When any changes are made to `roxygen2` markup or the C++ code in -the src directory, run `devtools::document()` to update the -[RcppExports.cpp](src/RcppExports.cpp), the package namespaces (see +the src directory, run `devtools::document()` to update the cpp11 +registration code ([src/cpp11.cpp](src/cpp11.cpp) and +[R/cpp11.R](R/cpp11.R)), the package namespaces (see [NAMESPACE](NAMESPACE)), and the package documentation files (in the "man" subdirectory), diff --git a/_pkgdown.yml b/_pkgdown.yml index 2957dc5d8..f8a5f892f 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -124,8 +124,9 @@ reference: - GwasFineMappingResult-class - GwasSumStats-class - H2Estimate-class - - LdData-class + - GenotypeMixture-class - LdEigen-class + - LdMatrix-class - LdScore-class - LdStatistic-class - MashPrior-class @@ -155,8 +156,9 @@ reference: - fineMappingRow - GwasFineMappingResult - GwasSumStats - - LdData + - GenotypeMixture-constructor - LdEigen + - LdMatrix-constructor - LdScore - MashPrior - MultiStudyQtlDataset @@ -301,7 +303,7 @@ reference: - credibleSetSummary - credibleSets - lbf - - ldSketch + - ldReference - marginalEffects - methodNames - genomicRegion @@ -346,14 +348,14 @@ reference: - colocViews - colocBoostOutcomes - computingTime - - ldSketch + - ldReference - regionVcp - subtitle: "SumStatsBase" contents: - af - coef - - ldSketch + - ldReference - maf - nSamples - variantColumnReplace @@ -393,7 +395,7 @@ reference: - cvResult - weightsDataType - methodFits - - ldSketch + - ldReference - methodNames - genomicRegion - weightStandardized @@ -447,18 +449,13 @@ reference: - annotationJackknifeCoefs - traitNames - - subtitle: "LdData" + - subtitle: "LdMatrix / GenotypeMixture" contents: - - blockMetadata - ldMatrix - - genotypes - mixtureWeights - ldPanelNSamples - - refPanel - - snpIdx - variantIds - - variantInfo - - hasGenotypes + - genotypes - subtitle: "LdEigen" contents: @@ -561,10 +558,9 @@ reference: - title: "LD infrastructure" desc: > - Computing, loading, and manipulating LD matrices, plus - design-matrix conditioning utilities. + Computing and checking LD matrices, plus design-matrix conditioning + utilities. contents: - - loadLdMatrix - computeLd - checkLd - enforceDesignFullRank @@ -647,7 +643,6 @@ reference: - glmnetWeights - lassoWeights - enetWeights - - lassosumRss - lassosumRssWeights - mcpWeights - mcpRssWeights @@ -655,7 +650,6 @@ reference: - scadRssWeights - l0learnWeights - l0learnRssWeights - - penalizedRss - subtitle: "Bayesian alphabet" contents: @@ -667,9 +661,7 @@ reference: - bayesNWeights - bayesRWeights - bLassoWeights - - prsCs - prsCsWeights - - sdpr - sdprWeights - dprWeights diff --git a/data/colocboostResultExample.rda b/data/colocboostResultExample.rda index c08713999..4b8e83739 100644 Binary files a/data/colocboostResultExample.rda and b/data/colocboostResultExample.rda differ diff --git a/data/ctwasEstExample.rda b/data/ctwasEstExample.rda index 2ec972e83..18d676b99 100644 Binary files a/data/ctwasEstExample.rda and b/data/ctwasEstExample.rda differ diff --git a/data/ctwasFinemapExample.rda b/data/ctwasFinemapExample.rda index dfe1d581e..a9e01ef31 100644 Binary files a/data/ctwasFinemapExample.rda and b/data/ctwasFinemapExample.rda differ diff --git a/data/ctwasInputsExample.rda b/data/ctwasInputsExample.rda index 47a5e0674..91e4e1bf3 100644 Binary files a/data/ctwasInputsExample.rda and b/data/ctwasInputsExample.rda differ diff --git a/data/ctwasWeightsExample.rda b/data/ctwasWeightsExample.rda index 3af3a3190..a1fe326a0 100644 Binary files a/data/ctwasWeightsExample.rda and b/data/ctwasWeightsExample.rda differ diff --git a/data/fsusieFineMappingExample.rda b/data/fsusieFineMappingExample.rda index d8bdb7e4a..ed4d2e13c 100644 Binary files a/data/fsusieFineMappingExample.rda and b/data/fsusieFineMappingExample.rda differ diff --git a/data/gwasFineMappingExample.rda b/data/gwasFineMappingExample.rda index 98de86bc8..6eb1977f6 100644 Binary files a/data/gwasFineMappingExample.rda and b/data/gwasFineMappingExample.rda differ diff --git a/data/gwasFineMappingLbfExample.rda b/data/gwasFineMappingLbfExample.rda index 03c961746..19d08d1c1 100644 Binary files a/data/gwasFineMappingLbfExample.rda and b/data/gwasFineMappingLbfExample.rda differ diff --git a/data/gwasSumStatsS4Example.rda b/data/gwasSumStatsS4Example.rda index 447dca842..8a24d9634 100644 Binary files a/data/gwasSumStatsS4Example.rda and b/data/gwasSumStatsS4Example.rda differ diff --git a/data/ldEigenExample.rda b/data/ldEigenExample.rda index 50fc211b2..3701f16ad 100644 Binary files a/data/ldEigenExample.rda and b/data/ldEigenExample.rda differ diff --git a/data/ldScoreExample.rda b/data/ldScoreExample.rda index 69a4e63e6..48e7c2a15 100644 Binary files a/data/ldScoreExample.rda and b/data/ldScoreExample.rda differ diff --git a/data/multiStudyQtlDatasetExample.rda b/data/multiStudyQtlDatasetExample.rda index ca813a210..2587422d1 100644 Binary files a/data/multiStudyQtlDatasetExample.rda and b/data/multiStudyQtlDatasetExample.rda differ diff --git a/data/mvsusieFineMappingExample.rda b/data/mvsusieFineMappingExample.rda index f635b77b9..eeae7d4e6 100644 Binary files a/data/mvsusieFineMappingExample.rda and b/data/mvsusieFineMappingExample.rda differ diff --git a/data/qtlDatasetExample.rda b/data/qtlDatasetExample.rda index b16523eb5..85ee38b0f 100644 Binary files a/data/qtlDatasetExample.rda and b/data/qtlDatasetExample.rda differ diff --git a/data/qtlFineMappingExample.rda b/data/qtlFineMappingExample.rda index 23d588815..10bd11fc7 100644 Binary files a/data/qtlFineMappingExample.rda and b/data/qtlFineMappingExample.rda differ diff --git a/data/qtlFineMappingLbfExample.rda b/data/qtlFineMappingLbfExample.rda index f31dfb7e4..b9a921187 100644 Binary files a/data/qtlFineMappingLbfExample.rda and b/data/qtlFineMappingLbfExample.rda differ diff --git a/data/qtlFineMappingPairedExample.rda b/data/qtlFineMappingPairedExample.rda index 2cb0e1b8f..a44a5a4fd 100644 Binary files a/data/qtlFineMappingPairedExample.rda and b/data/qtlFineMappingPairedExample.rda differ diff --git a/data/qtlSumStatsExample.rda b/data/qtlSumStatsExample.rda index 5f414d649..190200d28 100644 Binary files a/data/qtlSumStatsExample.rda and b/data/qtlSumStatsExample.rda differ diff --git a/data/qtlSumStatsMulticontextExample.rda b/data/qtlSumStatsMulticontextExample.rda index fa5b20a86..28eef0b7b 100644 Binary files a/data/qtlSumStatsMulticontextExample.rda and b/data/qtlSumStatsMulticontextExample.rda differ diff --git a/data/twasWeightsExample.rda b/data/twasWeightsExample.rda index 58422148a..b1abdd58a 100644 Binary files a/data/twasWeightsExample.rda and b/data/twasWeightsExample.rda differ diff --git a/inst/extdata/ld_reference/chr22/protocol_example.LD.chr22.afreq b/inst/extdata/ld_reference/chr22/protocol_example.LD.chr22.afreq index 54ecf1576..6295600da 100644 --- a/inst/extdata/ld_reference/chr22/protocol_example.LD.chr22.afreq +++ b/inst/extdata/ld_reference/chr22/protocol_example.LD.chr22.afreq @@ -1,176 +1,176 @@ -#CHROM ID REF ALT PROVISIONAL_REF? ALT_FREQS OBS_CT -22 chr22:10685239:C:T C T Y 0.509415 2000 -22 chr22:10761227:G:A G A Y 0.498357 2000 -22 chr22:11285239:C:T C T Y 0.526951 2000 -22 chr22:11601805:G:A G A Y 0.464453 2000 -22 chr22:11791698:G:T G T Y 0.459166 2000 -22 chr22:11797697:C:T C T Y 0.461794 2000 -22 chr22:12044872:A:C A C Y 0.481751 2000 -22 chr22:12194389:G:A G A Y 0.502203 2000 -22 chr22:12207043:C:T C T Y 0.523673 2000 -22 chr22:12350816:G:A G A Y 0.500284 2000 -22 chr22:12352464:C:A C A Y 0.55404 2000 -22 chr22:12370627:C:T C T Y 0.512232 2000 -22 chr22:12383838:G:A G A Y 0.546672 2000 -22 chr22:12571373:AGAAAGAAAGAAAGAAAGAAG:* AGAAAGAAAGAAAGAAAGAAG * Y 0.557945 2000 -22 chr22:12571377:AGAAAGAAAGAAAGAAG:* AGAAAGAAAGAAAGAAG * Y 0.582083 2000 -22 chr22:12571385:AGAAAGAAG:* AGAAAGAAG * Y 0.518186 2000 -22 chr22:12571386:GAAAGAAGGA:* GAAAGAAGGA * Y 0.518186 2000 -22 chr22:12571389:AGAAGGAAAGAAGGAAAGAAAGGAAGAAGGAAAGAAG:* AGAAGGAAAGAAGGAAAGAAAGGAAGAAGGAAAGAAG * Y 0.518186 2000 -22 chr22:12576050:T:A T A Y 0.495425 2000 -22 chr22:12640661:G:T G T Y 0.54009 2000 -22 chr22:15574750:C:A C A Y 0.511361 2000 -22 chr22:15635104:C:A C A Y 0.485249 2000 -22 chr22:15689224:A:C A C Y 0.525461 2000 -22 chr22:15773180:G:A G A Y 0.494939 2000 -22 chr22:15837995:CTTTCTTTCTTTCTTTTTCTTT:CTTTTTCTTTCTTTCTTTTTCTTT CTTTCTTTCTTTCTTTTTCTTT CTTTTTCTTTCTTTCTTTTTCTTT Y 0.507872 2000 -22 chr22:15838001:TTCTTTCTTTTTCTTTC:TTTTCTTTTTCTTTC TTCTTTCTTTTTCTTTC TTTTCTTTTTCTTTC Y 0.468291 2000 -22 chr22:15838002:TCTTTCTTTTTCTTTCTTC:* TCTTTCTTTTTCTTTCTTC * Y 0.489486 2000 -22 chr22:15838003:CTTTCTTTTTCTTT:ATTTCTTTTTCTTT CTTTCTTTTTCTTT ATTTCTTTTTCTTT Y 0.53565 2000 -22 chr22:15838003:CTTTCTTTTTCTTT:CTTTTTCTTTTTCTTT CTTTCTTTTTCTTT CTTTTTCTTTTTCTTT Y 0.432622 2000 -22 chr22:15838010:TTTCTTTCTTCCTTCCTTCCTTCCTTCCTTCCTCCCTTCCTTC:TCTTCTTTCTTCCTTCCTTCCTTCCTTCCTTCCTCCCTTCCTTC TTTCTTTCTTCCTTCCTTCCTTCCTTCCTTCCTCCCTTCCTTC TCTTCTTTCTTCCTTCCTTCCTTCCTTCCTTCCTCCCTTCCTTC Y 0.483518 2000 -22 chr22:15839920:G:A G A Y 0.481932 2000 -22 chr22:15919156:A:T A T Y 0.539744 2000 -22 chr22:15927084:C:T C T Y 0.461063 2000 -22 chr22:15947643:T:C T C Y 0.50772 2000 -22 chr22:15984722:T:C T C Y 0.46509 2000 -22 chr22:16073625:G:T G T Y 0.489268 2000 -22 chr22:16102937:C:T C T Y 0.486141 2000 -22 chr22:16111042:C:CA C CA Y 0.485807 2000 -22 chr22:16112049:C:A C A Y 0.514025 2000 -22 chr22:16112091:TG:CG TG CG Y 0.515604 2000 -22 chr22:16115854:C:T C T Y 0.495394 2000 -22 chr22:16124912:C:T C T Y 0.572155 2000 -22 chr22:16132992:A:G A G Y 0.546628 2000 -22 chr22:16187126:A:G A G Y 0.479369 2000 -22 chr22:16207293:A:G A G Y 0.469264 2000 -22 chr22:16214693:C:A C A Y 0.464751 2000 -22 chr22:16217062:A:G A G Y 0.559938 2000 -22 chr22:16224528:T:C T C Y 0.469264 2000 -22 chr22:16234309:C:T C T Y 0.559332 2000 -22 chr22:16244919:T:C T C Y 0.448835 2000 -22 chr22:16254612:GGAAGGAAGGAAGGAAA:AGAAGGAAGGAAGGAAA GGAAGGAAGGAAGGAAA AGAAGGAAGGAAGGAAA Y 0.49685 2000 -22 chr22:16258960:C:A C A Y 0.469264 2000 -22 chr22:16262035:G:A G A Y 0.469264 2000 -22 chr22:16262334:GATTCCATTCGATGATTCCATTCA:G GATTCCATTCGATGATTCCATTCA G Y 0.469264 2000 -22 chr22:16262336:TTCCATTCGATGATTCCATTCAATTCCATTCGATGATGATTCCATTCGAG:* TTCCATTCGATGATTCCATTCAATTCCATTCGATGATGATTCCATTCGAG * Y 0.486177 2000 -22 chr22:16262338:CCATTCGATGATTCCATTCAA:* CCATTCGATGATTCCATTCAA * Y 0.477952 2000 -22 chr22:16386749:TCCGCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCGCCGCCGTGGTTTTTTCCCCCCATCTCACCTCCGCTTTTTGCCCGCCGCGGCTTTTTGCCCCCACCCCGCCTCGGCTTTTTGCCAGCCACGGCTTTTTGCCCCCCGCCACCGCGGCTTTTTGTCCC:* TCCGCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCGCCGCCGTGGTTTTTTCCCCCCATCTCACCTCCGCTTTTTGCCCGCCGCGGCTTTTTGCCCCCACCCCGCCTCGGCTTTTTGCCAGCCACGGCTTTTTGCCCCCCGCCACCGCGGCTTTTTGTCCC * Y 0.486652 2000 -22 chr22:16386751:CGCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCG:* CGCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCG * Y 0.572355 2000 -22 chr22:16386752:GCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCGCCGCCGTGGTTTTTTCCCCCCATCTCACCTCCGCTTTTTGCCCGCCGCGGCTTTTTGCCCCCACCCCGCCTCGGCTTTTTGCCAGCCACGGCTTTTTGCCCC:CCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCGCCGCCGTGGTTTTTTCCCCCCATCTCACCTCCGCTTTTTGCCCGCCGCGGCTTTTTGCCCCCACCCCGCCTCGGCTTTTTGCCAGCCACGGCTTTTTGCCCC GCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCGCCGCCGTGGTTTTTTCCCCCCATCTCACCTCCGCTTTTTGCCCGCCGCGGCTTTTTGCCCCCACCCCGCCTCGGCTTTTTGCCAGCCACGGCTTTTTGCCCC CCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCGCCGCCGTGGTTTTTTCCCCCCATCTCACCTCCGCTTTTTGCCCGCCGCGGCTTTTTGCCCCCACCCCGCCTCGGCTTTTTGCCAGCCACGGCTTTTTGCCCC Y 0.560137 2000 -22 chr22:16400343:T:C T C Y 0.541063 2000 -22 chr22:16427771:T:C T C Y 0.438604 2000 -22 chr22:16439458:A:G A G Y 0.497631 2000 -22 chr22:16442170:G:A G A Y 0.471298 2000 -22 chr22:16549730:A:G A G Y 0.440718 2000 -22 chr22:16560460:ACAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAGGAAAGCCAGCCTGCCAAGCCAGCCAAGCCAGCCAGCCACTCAAGCCAGCCAAGTCAGCGAGCCAACCAAGCCAGCCAACTCAGCCAGCCACCTAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCAAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAAGCCAGGCAGCCAGCCAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCCAGCCAGCCAGCCCACACAGCCAAGC:* ACAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAGGAAAGCCAGCCTGCCAAGCCAGCCAAGCCAGCCAGCCACTCAAGCCAGCCAAGTCAGCGAGCCAACCAAGCCAGCCAACTCAGCCAGCCACCTAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCAAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAAGCCAGGCAGCCAGCCAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCCAGCCAGCCAGCCCACACAGCCAAGC * Y 0.537008 2000 -22 chr22:16560533:TCAAGCCAGCCAAGTCAGCGAGCCAACCAAGCCAGCCAACTCAGCCAGCCACCTAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCAAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAAGCCAGGCAGCCAGC:CCAAGCCAGCCAAGTCAGCGAGCCAACCAAGCCAGCCAACTCAGCCAGCCACCTAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCAAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAAGCCAGGCAGCCAGC TCAAGCCAGCCAAGTCAGCGAGCCAACCAAGCCAGCCAACTCAGCCAGCCACCTAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCAAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAAGCCAGGCAGCCAGC CCAAGCCAGCCAAGTCAGCGAGCCAACCAAGCCAGCCAACTCAGCCAGCCACCTAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCAAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAAGCCAGGCAGCCAGC Y 0.485227 2000 -22 chr22:16566547:ACAGCCAAGACAGCCAGCCAGCCACGCAAGCCAAGCCAGCCAGCCAGGCAAGCCAGGCATGCCAGCCAAGCCATCCAGCCAGCCAAGCCAGGCGGCCAGCCAAGCCAGCCAAGCCACCCGGCCAGCCAAGCCACCCAAGCCACCCGGCCAGCCAGGCATCCAAGCCAGCCAAGT:* ACAGCCAAGACAGCCAGCCAGCCACGCAAGCCAAGCCAGCCAGCCAGGCAAGCCAGGCATGCCAGCCAAGCCATCCAGCCAGCCAAGCCAGGCGGCCAGCCAAGCCAGCCAAGCCACCCGGCCAGCCAAGCCACCCAAGCCACCCGGCCAGCCAGGCATCCAAGCCAGCCAAGT * Y 0.531102 2000 -22 chr22:16566742:CAAGCCAGCCAGCTAGCCAAGCCACCCAGCCAGCCAGCCAGCCAAACCAGCCAAGCCAGCCAGCCAGCCAGCCAAGCCAGCCAAGCAAGCCAGCCAGCCAGCCAAGCCACGCAAGCCAGCCAGCCAGCCATGCCAGCCA:TAAGCCAGCCAGCTAGCCAAGCCACCCAGCCAGCCAGCCAGCCAAACCAGCCAAGCCAGCCAGCCAGCCAGCCAAGCCAGCCAAGCAAGCCAGCCAGCCAGCCAAGCCACGCAAGCCAGCCAGCCAGCCATGCCAGCCA CAAGCCAGCCAGCTAGCCAAGCCACCCAGCCAGCCAGCCAGCCAAACCAGCCAAGCCAGCCAGCCAGCCAGCCAAGCCAGCCAAGCAAGCCAGCCAGCCAGCCAAGCCACGCAAGCCAGCCAGCCAGCCATGCCAGCCA TAAGCCAGCCAGCTAGCCAAGCCACCCAGCCAGCCAGCCAGCCAAACCAGCCAAGCCAGCCAGCCAGCCAGCCAAGCCAGCCAAGCAAGCCAGCCAGCCAGCCAAGCCACGCAAGCCAGCCAGCCAGCCATGCCAGCCA Y 0.484197 2000 -22 chr22:16841646:CAAAAAAAAAAAAAA:AAAAAAAAAAAAAAA CAAAAAAAAAAAAAA AAAAAAAAAAAAAAA Y 0.444382 2000 -22 chr22:16845585:TCA:TCACA TCA TCACA Y 0.504671 2000 -22 chr22:16909478:TCTCTCC:* TCTCTCC * Y 0.534958 2000 -22 chr22:16909479:CTCTCCCTCTCTCTCTCTCTCTCTCCCT:CCCCTCTCTCTCTCTCTCTCTCCCT CTCTCCCTCTCTCTCTCTCTCTCTCCCT CCCCTCTCTCTCTCTCTCTCTCCCT Y 0.535621 2000 -22 chr22:16909480:TCTCCCTCTCTCTCTCTCTCTCTCC:* TCTCCCTCTCTCTCTCTCTCTCTCC * Y 0.542906 2000 -22 chr22:16909481:CTCCCTCTCTCTCTCTCTCTCTCCCT:* CTCCCTCTCTCTCTCTCTCTCTCCCT * Y 0.542906 2000 -22 chr22:16970638:G:A G A Y 0.454476 2000 -22 chr22:16973012:G:A G A Y 0.474585 2000 -22 chr22:17014255:C:T C T Y 0.5282 2000 -22 chr22:17051853:C:T C T Y 0.47066 2000 -22 chr22:17079499:GAAAAAAA:GAAAAAAAA GAAAAAAA GAAAAAAAA Y 0.512123 2000 -22 chr22:17113082:AG:A AG A Y 0.499479 2000 -22 chr22:17136539:C:T C T Y 0.481511 2000 -22 chr22:17154616:CTT:CTTT CTT CTTT Y 0.484142 2000 -22 chr22:17154616:CTTT:CT CTTT CT Y 0.441327 2000 -22 chr22:17157085:TACACACAC:CACACACAC TACACACAC CACACACAC Y 0.465133 2000 -22 chr22:17157085:TACACACAC:T TACACACAC T Y 0.458013 2000 -22 chr22:17157085:TACACACAC:TACACACACACACACAC TACACACAC TACACACACACACACAC Y 0.44657 2000 -22 chr22:17157085:TACACACAC:TACACACACACACACACACAC TACACACAC TACACACACACACACACACAC Y 0.494346 2000 -22 chr22:17157085:TACACACAC:TACACACACACACACACACACACAC TACACACAC TACACACACACACACACACACACAC Y 0.48595 2000 -22 chr22:17168884:C:T C T Y 0.462531 2000 -22 chr22:17172477:C:T C T Y 0.489003 2000 -22 chr22:17187665:TAA:TA TAA TA Y 0.420323 2000 -22 chr22:17187665:TAA:TAAA TAA TAAA Y 0.446908 2000 -22 chr22:17187977:G:GC G GC Y 0.455896 2000 -22 chr22:17209889:AT:ATT AT ATT Y 0.473355 2000 -22 chr22:17216769:AAAAC:ACAAAC AAAAC ACAAAC Y 0.452875 2000 -22 chr22:17216770:AAAC:ACAAC AAAC ACAAC Y 0.508848 2000 -22 chr22:17216771:A:AC A AC Y 0.519489 2000 -22 chr22:17216771:C:A C A Y 0.52526 2000 -22 chr22:17216789:C:CACAT C CACAT Y 0.550742 2000 -22 chr22:17216799:G:T G T Y 0.482748 2000 -22 chr22:17221295:GT:G GT G Y 0.50824 2000 -22 chr22:17302680:G:A G A Y 0.537627 2000 -22 chr22:17303055:C:T C T Y 0.482845 2000 -22 chr22:17326841:T:C T C Y 0.474051 2000 -22 chr22:17327911:TACACAC:TACAC TACACAC TACAC Y 0.520152 2000 -22 chr22:17331260:C:CT C CT Y 0.467575 2000 -22 chr22:17350100:T:C T C Y 0.487738 2000 -22 chr22:17375405:A:G A G Y 0.527487 2000 -22 chr22:17379581:GGTGT:GGT GGTGT GGT Y 0.595416 2000 -22 chr22:17379581:GGTGT:GGTGTGT GGTGT GGTGTGT Y 0.502698 2000 -22 chr22:17379581:GGTGT:GGTGTGTGT GGTGT GGTGTGTGT Y 0.513036 2000 -22 chr22:17379581:GGTGT:GGTGTGTGTGT GGTGT GGTGTGTGTGT Y 0.496143 2000 -22 chr22:17427850:G:T G T Y 0.461924 2000 -22 chr22:17429117:G:A G A Y 0.430614 2000 -22 chr22:17449676:C:A C A Y 0.537885 2000 -22 chr22:17466675:G:T G T Y 0.559762 2000 -22 chr22:17469609:TCCAGTAAGAATCCAGTTCTC:TCAGTAAGAATCCAGTTCTC TCCAGTAAGAATCCAGTTCTC TCAGTAAGAATCCAGTTCTC Y 0.518877 2000 -22 chr22:17469610:TCA:CCA TCA CCA Y 0.503079 2000 -22 chr22:17518422:C:T C T Y 0.434104 2000 -22 chr22:17523010:GAAAAA:AAAAAA GAAAAA AAAAAA Y 0.517682 2000 -22 chr22:17523010:GAAAAA:GA GAAAAA GA Y 0.475324 2000 -22 chr22:17577230:G:A G A Y 0.599718 2000 -22 chr22:17585626:ATTTATT:A ATTTATT A Y 0.494108 2000 -22 chr22:17585630:ATT:* ATT * Y 0.494108 2000 -22 chr22:17658972:T:C T C Y 0.47756 2000 -22 chr22:17667743:T:A T A Y 0.573391 2000 -22 chr22:17683132:CA:C CA C Y 0.56794 2000 -22 chr22:17683132:CA:CAAA CA CAAA Y 0.408623 2000 -22 chr22:17687818:CT:C CT C Y 0.432793 2000 -22 chr22:17706998:A:G A G Y 0.543514 2000 -22 chr22:17721525:AT:ATTTTT AT ATTTTT Y 0.52821 2000 -22 chr22:17721525:ATTTT:AT ATTTT AT Y 0.544052 2000 -22 chr22:17726847:G:A G A Y 0.450793 2000 -22 chr22:17734310:CTT:C CTT C Y 0.435 2000 -22 chr22:17763207:A:G A G Y 0.551591 2000 -22 chr22:17765138:TCAAGACATCCTCCACAGAGGACC:T TCAAGACATCCTCCACAGAGGACC T Y 0.521354 2000 -22 chr22:17768872:CAA:CA CAA CA Y 0.536099 2000 -22 chr22:17768872:CAA:CAAA CAA CAAA Y 0.484971 2000 -22 chr22:17839567:CTTT:CT CTTT CT Y 0.489805 2000 -22 chr22:17839567:CTTT:CTT CTTT CTT Y 0.513998 2000 -22 chr22:17846396:T:TA T TA Y 0.481685 2000 -22 chr22:17860245:C:A C A Y 0.516506 2000 -22 chr22:17876770:AGTTATGGAGGTTAGGGAGGTTAGGGAAGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTAGGGAG:GGTTATGGAGGTTAGGGAGGTTAGGGAAGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTAGGGAG AGTTATGGAGGTTAGGGAGGTTAGGGAAGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTAGGGAG GGTTATGGAGGTTAGGGAGGTTAGGGAAGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTAGGGAG Y 0.528962 2000 -22 chr22:17876799:TTATGGAGGTTAGGGAGGTTAG:* TTATGGAGGTTAGGGAGGTTAG * Y 0.528239 2000 -22 chr22:17876802:TGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTAG:* TGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTAG * Y 0.528239 2000 -22 chr22:17876803:GGAGGTTAGGGAGGTTAGGGAGGTTAT:* GGAGGTTAGGGAGGTTAGGGAGGTTAT * Y 0.455556 2000 -22 chr22:17876805:AGGTT:* AGGTT * Y 0.52747 2000 -22 chr22:17876807:GTTA:* GTTA * Y 0.52747 2000 -22 chr22:17876808:TTAGG:* TTAGG * Y 0.52747 2000 -22 chr22:17876810:AGGGAGGTTAGGGAG:* AGGGAGGTTAGGGAG * Y 0.523929 2000 -22 chr22:17879807:G:A G A Y 0.5295 2000 -22 chr22:17880174:G:A G A Y 0.560698 2000 -22 chr22:17898107:TAA:TA TAA TA Y 0.472884 2000 -22 chr22:17898107:TAA:TAAA TAA TAAA Y 0.443592 2000 -22 chr22:17929265:ATTTTTTTTT:ATTTTTT ATTTTTTTTT ATTTTTT Y 0.46021 2000 -22 chr22:17929265:ATTTTTTTTT:ATTTTTTT ATTTTTTTTT ATTTTTTT Y 0.52214 2000 -22 chr22:17929265:ATTTTTTTTT:ATTTTTTTT ATTTTTTTTT ATTTTTTTT Y 0.473122 2000 -22 chr22:17949102:C:T C T Y 0.509826 2000 -22 chr22:17955812:G:A G A Y 0.499748 2000 -22 chr22:17967486:A:ACACACACC A ACACACACC Y 0.551969 2000 -22 chr22:17967486:A:ACACACC A ACACACC Y 0.557015 2000 -22 chr22:17967492:ACCCACACACACC:ACACACACACC ACCCACACACACC ACACACACACC Y 0.499748 2000 -22 chr22:17967494:C:* C * Y 0.499748 2000 -22 chr22:17977536:TA:TAA TA TAA Y 0.538621 2000 -22 chr22:17998075:G:GTGAA G GTGAA Y 0.522762 2000 -22 chr22:18001877:A:C A C Y 0.485895 2000 -22 chr22:18064272:A:T A T Y 0.438461 2000 -22 chr22:18150441:CA:C CA C Y 0.480298 2000 -22 chr22:18159414:A:G A G Y 0.514596 2000 -22 chr22:18160557:T:C T C Y 0.561571 2000 -22 chr22:18166484:T:TGA T TGA Y 0.474416 2000 -22 chr22:18173426:C:A C A Y 0.55376 2000 -22 chr22:18730960:GTATACATAAGATATATTATATATAATATATTATATAAATGTATTATATATAACATATTATATATAATATATT:* GTATACATAAGATATATTATATATAATATATTATATAAATGTATTATATATAACATATTATATATAATATATT * Y 0.467455 2000 -22 chr22:18731027:T:C T C Y 0.52894 2000 -22 chr22:18850784:T:G T G Y 0.519029 2000 +#CHROM ID REF ALT ALT_FREQS OBS_CT U_MIN U_MAX +chr22 chr22:10685239:C:T C T 0.058333 120 -3.205609 3.067117 +chr22 chr22:10761227:G:A G A 0.150000 120 -3.008123 2.950800 +chr22 chr22:11285239:C:T C T 0.083333 120 -3.126703 2.778228 +chr22 chr22:11601805:G:A G A 0.058333 120 -2.539263 2.868160 +chr22 chr22:11791698:G:T G T 0.050000 120 -2.743094 3.266386 +chr22 chr22:11797697:C:T C T 0.050000 120 -2.842590 3.453395 +chr22 chr22:12044872:A:C A C 0.041667 120 -3.103616 3.393090 +chr22 chr22:12194389:G:A G A 0.058333 120 -3.177496 3.275266 +chr22 chr22:12207043:C:T C T 0.058333 120 -3.142918 2.825395 +chr22 chr22:12350816:G:A G A 0.058333 120 -3.377678 3.441288 +chr22 chr22:12352464:C:A C A 0.125000 120 -3.311683 2.707073 +chr22 chr22:12370627:C:T C T 0.125000 120 -3.420609 3.279629 +chr22 chr22:12383838:G:A G A 0.041667 120 -3.521324 2.816753 +chr22 chr22:12571373:AGAAAGAAAGAAAGAAAGAAG:* AGAAAGAAAGAAAGAAAGAAG * 0.116667 120 -3.676813 2.857238 +chr22 chr22:12571377:AGAAAGAAAGAAAGAAG:* AGAAAGAAAGAAAGAAG * 0.108333 120 -4.099360 2.909775 +chr22 chr22:12571385:AGAAAGAAG:* AGAAAGAAG * 0.091667 120 -2.942760 2.714508 +chr22 chr22:12571386:GAAAGAAGGA:* GAAAGAAGGA * 0.091667 120 -2.942760 2.714508 +chr22 chr22:12571389:AGAAGGAAAGAAGGAAAGAAAGGAAGAAGGAAAGAAG:* AGAAGGAAAGAAGGAAAGAAAGGAAGAAGGAAAGAAG * 0.091667 120 -2.942760 2.714508 +chr22 chr22:12576050:T:A T A 0.125000 120 -2.955190 2.962983 +chr22 chr22:12640661:G:T G T 0.100000 120 -3.334096 2.876735 +chr22 chr22:15574750:C:A C A 0.084746 118 -3.129223 3.055344 +chr22 chr22:15635104:C:A C A 0.075000 120 -3.210387 3.422972 +chr22 chr22:15689224:A:C A C 0.535088 114 -3.144336 2.874810 +chr22 chr22:15773180:G:A G A 0.041667 120 -3.148023 3.176087 +chr22 chr22:15837995:CTTTCTTTCTTTCTTTTTCTTT:CTTTTTCTTTCTTTCTTTTTCTTT CTTTCTTTCTTTCTTTTTCTTT CTTTTTCTTTCTTTCTTTTTCTTT 0.041667 120 -3.567354 3.402717 +chr22 chr22:15838001:TTCTTTCTTTTTCTTTC:TTTTCTTTTTCTTTC TTCTTTCTTTTTCTTTC TTTTCTTTTTCTTTC 0.100000 120 -3.198105 3.549614 +chr22 chr22:15838002:TCTTTCTTTTTCTTTCTTC:* TCTTTCTTTTTCTTTCTTC * 0.100000 120 -3.212995 3.243896 +chr22 chr22:15838003:CTTTCTTTTTCTTT:ATTTCTTTTTCTTT CTTTCTTTTTCTTT ATTTCTTTTTCTTT 0.058333 120 -3.495338 2.970662 +chr22 chr22:15838003:CTTTCTTTTTCTTT:CTTTTTCTTTTTCTTT CTTTCTTTTTCTTT CTTTTTCTTTTTCTTT 0.091667 120 -2.929376 3.812160 +chr22 chr22:15838010:TTTCTTTCTTCCTTCCTTCCTTCCTTCCTTCCTCCCTTCCTTC:TCTTCTTTCTTCCTTCCTTCCTTCCTTCCTTCCTCCCTTCCTTC TTTCTTTCTTCCTTCCTTCCTTCCTTCCTTCCTCCCTTCCTTC TCTTCTTTCTTCCTTCCTTCCTTCCTTCCTTCCTCCCTTCCTTC 0.108333 120 -3.216907 3.442333 +chr22 chr22:15839920:G:A G A 0.108333 120 -3.033592 3.232802 +chr22 chr22:15919156:A:T A T 0.300000 120 -3.370516 2.796047 +chr22 chr22:15927084:C:T C T 0.108333 120 -2.934351 3.354728 +chr22 chr22:15947643:T:C T C 0.058333 120 -3.348082 3.241702 +chr22 chr22:15984722:T:C T C 0.291667 120 -2.842829 3.244504 +chr22 chr22:16073625:G:T G T 0.108333 120 -2.853640 3.048592 +chr22 chr22:16102937:C:T C T 0.308333 120 -2.934622 3.056692 +chr22 chr22:16111042:C:CA C CA 0.475000 120 -2.844216 3.088048 +chr22 chr22:16112049:C:A C A 0.350000 120 -3.437121 3.251906 +chr22 chr22:16112091:TG:CG TG CG 0.133333 120 -3.413548 3.292261 +chr22 chr22:16115854:C:T C T 0.483333 120 -3.004606 3.123001 +chr22 chr22:16124912:C:T C T 0.458333 120 -3.690210 2.734233 +chr22 chr22:16132992:A:G A G 0.441667 120 -3.624825 2.964954 +chr22 chr22:16187126:A:G A G 0.425000 120 -2.800905 3.003121 +chr22 chr22:16207293:A:G A G 0.241667 120 -3.310483 3.852028 +chr22 chr22:16214693:C:A C A 0.050000 120 -2.944874 3.325550 +chr22 chr22:16217062:A:G A G 0.450000 120 -3.531055 2.735769 +chr22 chr22:16224528:T:C T C 0.241667 120 -3.310483 3.852028 +chr22 chr22:16234309:C:T C T 0.449153 118 -3.536133 2.747661 +chr22 chr22:16244919:T:C T C 0.316667 120 -2.922133 3.528822 +chr22 chr22:16254612:GGAAGGAAGGAAGGAAA:AGAAGGAAGGAAGGAAA GGAAGGAAGGAAGGAAA AGAAGGAAGGAAGGAAA 0.077586 116 -3.114077 3.217682 +chr22 chr22:16258960:C:A C A 0.241667 120 -3.310483 3.852028 +chr22 chr22:16262035:G:A G A 0.241667 120 -3.310483 3.852028 +chr22 chr22:16262334:GATTCCATTCGATGATTCCATTCA:G GATTCCATTCGATGATTCCATTCA G 0.241667 120 -3.310483 3.852028 +chr22 chr22:16262336:TTCCATTCGATGATTCCATTCAATTCCATTCGATGATGATTCCATTCGAG:* TTCCATTCGATGATTCCATTCAATTCCATTCGATGATGATTCCATTCGAG * 0.250000 120 -3.129206 3.392338 +chr22 chr22:16262338:CCATTCGATGATTCCATTCAA:* CCATTCGATGATTCCATTCAA * 0.241667 120 -3.008105 3.369859 +chr22 chr22:16386749:TCCGCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCGCCGCCGTGGTTTTTTCCCCCCATCTCACCTCCGCTTTTTGCCCGCCGCGGCTTTTTGCCCCCACCCCGCCTCGGCTTTTTGCCAGCCACGGCTTTTTGCCCCCCGCCACCGCGGCTTTTTGTCCC:* TCCGCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCGCCGCCGTGGTTTTTTCCCCCCATCTCACCTCCGCTTTTTGCCCGCCGCGGCTTTTTGCCCCCACCCCGCCTCGGCTTTTTGCCAGCCACGGCTTTTTGCCCCCCGCCACCGCGGCTTTTTGTCCC * 0.086207 116 -2.862570 3.061623 +chr22 chr22:16386751:CGCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCG:* CGCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCG * 0.059322 118 -3.872885 2.851318 +chr22 chr22:16386752:GCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCGCCGCCGTGGTTTTTTCCCCCCATCTCACCTCCGCTTTTTGCCCGCCGCGGCTTTTTGCCCCCACCCCGCCTCGGCTTTTTGCCAGCCACGGCTTTTTGCCCC:CCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCGCCGCCGTGGTTTTTTCCCCCCATCTCACCTCCGCTTTTTGCCCGCCGCGGCTTTTTGCCCCCACCCCGCCTCGGCTTTTTGCCAGCCACGGCTTTTTGCCCC GCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCGCCGCCGTGGTTTTTTCCCCCCATCTCACCTCCGCTTTTTGCCCGCCGCGGCTTTTTGCCCCCACCCCGCCTCGGCTTTTTGCCAGCCACGGCTTTTTGCCCC CCCGCCGCCGCGGCTTTTTGCCCCCCACCCCCGCCGCCGCGGCTTTTTACCCGCCGCGGCTTTTTGCCCCCCCGCCGCCGTGGTTTTTTCCCCCCATCTCACCTCCGCTTTTTGCCCGCCGCGGCTTTTTGCCCCCACCCCGCCTCGGCTTTTTGCCAGCCACGGCTTTTTGCCCC 0.413793 116 -3.915015 3.054501 +chr22 chr22:16400343:T:C T C 0.125000 120 -3.496987 2.926115 +chr22 chr22:16427771:T:C T C 0.475000 120 -2.675624 3.519506 +chr22 chr22:16439458:A:G A G 0.133333 120 -3.122226 3.205316 +chr22 chr22:16442170:G:A G A 0.050000 120 -3.245831 3.639123 +chr22 chr22:16549730:A:G A G 0.058333 120 -2.827398 3.519503 +chr22 chr22:16560460:ACAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAGGAAAGCCAGCCTGCCAAGCCAGCCAAGCCAGCCAGCCACTCAAGCCAGCCAAGTCAGCGAGCCAACCAAGCCAGCCAACTCAGCCAGCCACCTAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCAAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAAGCCAGGCAGCCAGCCAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCCAGCCAGCCAGCCCACACAGCCAAGC:* ACAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAGGAAAGCCAGCCTGCCAAGCCAGCCAAGCCAGCCAGCCACTCAAGCCAGCCAAGTCAGCGAGCCAACCAAGCCAGCCAACTCAGCCAGCCACCTAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCAAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAAGCCAGGCAGCCAGCCAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCCAGCCAGCCAGCCCACACAGCCAAGC * 0.449153 118 -3.588305 3.149814 +chr22 chr22:16560533:TCAAGCCAGCCAAGTCAGCGAGCCAACCAAGCCAGCCAACTCAGCCAGCCACCTAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCAAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAAGCCAGGCAGCCAGC:CCAAGCCAGCCAAGTCAGCGAGCCAACCAAGCCAGCCAACTCAGCCAGCCACCTAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCAAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAAGCCAGGCAGCCAGC TCAAGCCAGCCAAGTCAGCGAGCCAACCAAGCCAGCCAACTCAGCCAGCCACCTAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCAAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAAGCCAGGCAGCCAGC CCAAGCCAGCCAAGTCAGCGAGCCAACCAAGCCAGCCAACTCAGCCAGCCACCTAAGCCAGCCAAGCCAGCCAGCCAGCCAAGCAAGCCAGCCAGCCAAGCCAGCCAAGCCAGCCAAGCCAGGCAGCCAGC 0.050000 120 -2.939817 3.147050 +chr22 chr22:16566547:ACAGCCAAGACAGCCAGCCAGCCACGCAAGCCAAGCCAGCCAGCCAGGCAAGCCAGGCATGCCAGCCAAGCCATCCAGCCAGCCAAGCCAGGCGGCCAGCCAAGCCAGCCAAGCCACCCGGCCAGCCAAGCCACCCAAGCCACCCGGCCAGCCAGGCATCCAAGCCAGCCAAGT:* ACAGCCAAGACAGCCAGCCAGCCACGCAAGCCAAGCCAGCCAGCCAGGCAAGCCAGGCATGCCAGCCAAGCCATCCAGCCAGCCAAGCCAGGCGGCCAGCCAAGCCAGCCAAGCCACCCGGCCAGCCAAGCCACCCAAGCCACCCGGCCAGCCAGGCATCCAAGCCAGCCAAGT * 0.152542 118 -3.498549 2.976745 +chr22 chr22:16566742:CAAGCCAGCCAGCTAGCCAAGCCACCCAGCCAGCCAGCCAGCCAAACCAGCCAAGCCAGCCAGCCAGCCAGCCAAGCCAGCCAAGCAAGCCAGCCAGCCAGCCAAGCCACGCAAGCCAGCCAGCCAGCCATGCCAGCCA:TAAGCCAGCCAGCTAGCCAAGCCACCCAGCCAGCCAGCCAGCCAAACCAGCCAAGCCAGCCAGCCAGCCAGCCAAGCCAGCCAAGCAAGCCAGCCAGCCAGCCAAGCCACGCAAGCCAGCCAGCCAGCCATGCCAGCCA CAAGCCAGCCAGCTAGCCAAGCCACCCAGCCAGCCAGCCAGCCAAACCAGCCAAGCCAGCCAGCCAGCCAGCCAAGCCAGCCAAGCAAGCCAGCCAGCCAGCCAAGCCACGCAAGCCAGCCAGCCAGCCATGCCAGCCA TAAGCCAGCCAGCTAGCCAAGCCACCCAGCCAGCCAGCCAGCCAAACCAGCCAAGCCAGCCAGCCAGCCAGCCAAGCCAGCCAAGCAAGCCAGCCAGCCAGCCAAGCCACGCAAGCCAGCCAGCCAGCCATGCCAGCCA 0.091667 120 -3.084260 3.340726 +chr22 chr22:16841646:CAAAAAAAAAAAAAA:AAAAAAAAAAAAAAA CAAAAAAAAAAAAAA AAAAAAAAAAAAAAA 0.041667 120 -2.875431 3.685478 +chr22 chr22:16845585:TCA:TCACA TCA TCACA 0.241667 120 -3.330419 3.241529 +chr22 chr22:16909478:TCTCTCC:* TCTCTCC * 0.050847 118 -3.732750 3.276258 +chr22 chr22:16909479:CTCTCCCTCTCTCTCTCTCTCTCTCCCT:CCCCTCTCTCTCTCTCTCTCTCCCT CTCTCCCTCTCTCTCTCTCTCTCTCCCT CCCCTCTCTCTCTCTCTCTCTCCCT 0.059322 118 -3.545125 3.072889 +chr22 chr22:16909480:TCTCCCTCTCTCTCTCTCTCTCTCC:* TCTCCCTCTCTCTCTCTCTCTCTCC * 0.050000 120 -3.799124 3.228895 +chr22 chr22:16909481:CTCCCTCTCTCTCTCTCTCTCTCCCT:* CTCCCTCTCTCTCTCTCTCTCTCCCT * 0.050000 120 -3.799124 3.228895 +chr22 chr22:16970638:G:A G A 0.066667 120 -2.910069 3.414633 +chr22 chr22:16973012:G:A G A 0.075000 120 -3.563433 3.965891 +chr22 chr22:17014255:C:T C T 0.291667 120 -3.284238 2.873363 +chr22 chr22:17051853:C:T C T 0.216667 120 -2.917465 3.347496 +chr22 chr22:17079499:GAAAAAAA:GAAAAAAAA GAAAAAAA GAAAAAAAA 0.258333 120 -3.533586 3.327402 +chr22 chr22:17113082:AG:A AG A 0.058333 120 -2.972764 2.892405 +chr22 chr22:17136539:C:T C T 0.114035 114 -3.086712 3.397090 +chr22 chr22:17154616:CTT:CTTT CTT CTTT 0.258333 120 -3.218153 3.382598 +chr22 chr22:17154616:CTTT:CT CTTT CT 0.083333 120 -2.638894 3.397823 +chr22 chr22:17157085:TACACACAC:CACACACAC TACACACAC CACACACAC 0.059322 118 -3.097862 3.430012 +chr22 chr22:17157085:TACACACAC:T TACACACAC T 0.262712 118 -2.964346 3.527682 +chr22 chr22:17157085:TACACACAC:TACACACACACACACAC TACACACAC TACACACACACACACAC 0.313559 118 -2.882377 3.590802 +chr22 chr22:17157085:TACACACAC:TACACACACACACACACACAC TACACACAC TACACACACACACACACACAC 0.093220 118 -3.259253 3.398953 +chr22 chr22:17157085:TACACACAC:TACACACACACACACACACACACAC TACACACAC TACACACACACACACACACACACAC 0.076271 118 -3.890379 4.162233 +chr22 chr22:17168884:C:T C T 0.350000 120 -3.151556 3.700766 +chr22 chr22:17172477:C:T C T 0.250000 120 -3.352638 3.465570 +chr22 chr22:17187665:TAA:TA TAA TA 0.075000 120 -3.046619 4.195791 +chr22 chr22:17187665:TAA:TAAA TAA TAAA 0.250000 120 -2.974156 3.781563 +chr22 chr22:17187977:G:GC G GC 0.091667 120 -3.089166 3.702388 +chr22 chr22:17209889:AT:ATT AT ATT 0.116667 120 -3.263374 3.622323 +chr22 chr22:17216769:AAAAC:ACAAAC AAAAC ACAAAC 0.075000 120 -3.161802 3.795697 +chr22 chr22:17216770:AAAC:ACAAC AAAC ACAAC 0.100000 120 -3.141232 3.058244 +chr22 chr22:17216771:A:AC A AC 0.127119 118 -3.353556 3.104494 +chr22 chr22:17216771:C:A C A 0.364407 118 -3.354336 2.977146 +chr22 chr22:17216789:C:CACAT C CACAT 0.096491 114 -3.486023 2.836467 +chr22 chr22:17216799:G:T G T 0.091667 120 -3.477711 3.638458 +chr22 chr22:17221295:GT:G GT G 0.250000 120 -3.241571 3.160720 +chr22 chr22:17302680:G:A G A 0.458333 120 -3.311081 2.955872 +chr22 chr22:17303055:C:T C T 0.475000 120 -2.927855 3.248290 +chr22 chr22:17326841:T:C T C 0.233333 120 -2.957881 3.346703 +chr22 chr22:17327911:TACACAC:TACAC TACACAC TACAC 0.316667 120 -3.491494 3.267514 +chr22 chr22:17331260:C:CT C CT 0.108333 120 -2.965429 3.379113 +chr22 chr22:17350100:T:C T C 0.450000 120 -3.056168 3.285574 +chr22 chr22:17375405:A:G A G 0.050000 120 -3.006483 2.724790 +chr22 chr22:17379581:GGTGT:GGT GGTGT GGT 0.058333 120 -3.666061 2.550484 +chr22 chr22:17379581:GGTGT:GGTGTGT GGTGT GGTGTGT 0.241667 120 -2.910204 2.880715 +chr22 chr22:17379581:GGTGT:GGTGTGTGT GGTGT GGTGTGTGT 0.175000 120 -3.440267 3.318373 +chr22 chr22:17379581:GGTGT:GGTGTGTGTGT GGTGT GGTGTGTGTGT 0.066667 120 -3.466722 3.399527 +chr22 chr22:17427850:G:T G T 0.483333 120 -2.586669 3.158238 +chr22 chr22:17429117:G:A G A 0.508333 120 -2.746038 3.784401 +chr22 chr22:17449676:C:A C A 0.150000 120 -3.359335 2.982116 +chr22 chr22:17466675:G:T G T 0.141667 120 -3.683858 2.906509 +chr22 chr22:17469609:TCCAGTAAGAATCCAGTTCTC:TCAGTAAGAATCCAGTTCTC TCCAGTAAGAATCCAGTTCTC TCAGTAAGAATCCAGTTCTC 0.175000 120 -3.450543 3.319580 +chr22 chr22:17469610:TCA:CCA TCA CCA 0.391667 120 -2.634955 2.638616 +chr22 chr22:17518422:C:T C T 0.175000 120 -2.721625 3.567812 +chr22 chr22:17523010:GAAAAA:AAAAAA GAAAAA AAAAAA 0.100000 120 -3.657245 3.364633 +chr22 chr22:17523010:GAAAAA:GA GAAAAA GA 0.183333 120 -2.897955 3.228043 +chr22 chr22:17577230:G:A G A 0.050000 120 -4.100469 2.826907 +chr22 chr22:17585626:ATTTATT:A ATTTATT A 0.150000 120 -3.384738 3.427270 +chr22 chr22:17585630:ATT:* ATT * 0.150000 120 -3.384738 3.427270 +chr22 chr22:17658972:T:C T C 0.094828 116 -2.942223 3.204339 +chr22 chr22:17667743:T:A T A 0.041667 120 -3.564001 2.552163 +chr22 chr22:17683132:CA:C CA C 0.083333 120 -3.788241 2.907954 +chr22 chr22:17683132:CA:CAAA CA CAAA 0.183333 120 -2.621058 3.779652 +chr22 chr22:17687818:CT:C CT C 0.254237 118 -2.979391 3.972145 +chr22 chr22:17706998:A:G A G 0.066667 120 -3.313658 2.751425 +chr22 chr22:17721525:AT:ATTTTT AT ATTTTT 0.068966 116 -3.884105 3.503871 +chr22 chr22:17721525:ATTTT:AT ATTTT AT 0.250000 116 -3.719667 3.120347 +chr22 chr22:17726847:G:A G A 0.450000 120 -3.391584 4.114864 +chr22 chr22:17734310:CTT:C CTT C 0.183333 120 -2.842432 3.635271 +chr22 chr22:17763207:A:G A G 0.475000 120 -3.680202 3.019858 +chr22 chr22:17765138:TCAAGACATCCTCCACAGAGGACC:T TCAAGACATCCTCCACAGAGGACC T 0.091667 120 -3.044846 2.867190 +chr22 chr22:17768872:CAA:CA CAA CA 0.068966 116 -3.779893 3.270947 +chr22 chr22:17768872:CAA:CAAA CAA CAAA 0.137931 116 -3.049741 3.274096 +chr22 chr22:17839567:CTTT:CT CTTT CT 0.250000 120 -3.246014 3.336396 +chr22 chr22:17839567:CTTT:CTT CTTT CTT 0.050000 120 -3.472959 3.237302 +chr22 chr22:17846396:T:TA T TA 0.200000 120 -2.840878 2.992208 +chr22 chr22:17860245:C:A C A 0.366667 120 -3.196736 2.905937 +chr22 chr22:17876770:AGTTATGGAGGTTAGGGAGGTTAGGGAAGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTAGGGAG:GGTTATGGAGGTTAGGGAGGTTAGGGAAGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTAGGGAG AGTTATGGAGGTTAGGGAGGTTAGGGAAGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTAGGGAG GGTTATGGAGGTTAGGGAGGTTAGGGAAGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTAGGGAG 0.043103 116 -3.021483 2.710103 +chr22 chr22:17876799:TTATGGAGGTTAGGGAGGTTAG:* TTATGGAGGTTAGGGAGGTTAG * 0.058333 120 -3.816427 3.394593 +chr22 chr22:17876802:TGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTAG:* TGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTATGGAGGTTAGGGAGGTTAGGGAGGTTAG * 0.058333 120 -3.816427 3.394593 +chr22 chr22:17876803:GGAGGTTAGGGAGGTTAGGGAGGTTAT:* GGAGGTTAGGGAGGTTAGGGAGGTTAT * 0.075000 120 -3.119382 3.644493 +chr22 chr22:17876805:AGGTT:* AGGTT * 0.066667 120 -3.831167 3.385172 +chr22 chr22:17876807:GTTA:* GTTA * 0.066667 120 -3.831167 3.385172 +chr22 chr22:17876808:TTAGG:* TTAGG * 0.066667 120 -3.831167 3.385172 +chr22 chr22:17876810:AGGGAGGTTAGGGAG:* AGGGAGGTTAGGGAG * 0.059322 118 -3.753418 3.390164 +chr22 chr22:17879807:G:A G A 0.075000 120 -3.539726 3.083011 +chr22 chr22:17880174:G:A G A 0.216667 120 -3.721571 2.850228 +chr22 chr22:17898107:TAA:TA TAA TA 0.133333 120 -3.175113 3.498415 +chr22 chr22:17898107:TAA:TAAA TAA TAAA 0.333333 120 -2.799656 3.425567 +chr22 chr22:17929265:ATTTTTTTTT:ATTTTTT ATTTTTTTTT ATTTTTT 0.050000 120 -2.851722 3.442430 +chr22 chr22:17929265:ATTTTTTTTT:ATTTTTTT ATTTTTTTTT ATTTTTTT 0.258333 120 -3.373254 3.063437 +chr22 chr22:17929265:ATTTTTTTTT:ATTTTTTTT ATTTTTTTTT ATTTTTTTT 0.441667 120 -2.716016 3.053709 +chr22 chr22:17949102:C:T C T 0.066667 120 -3.421571 3.247033 +chr22 chr22:17955812:G:A G A 0.200000 120 -3.042460 2.998437 +chr22 chr22:17967486:A:ACACACACC A ACACACACC 0.158333 120 -3.768974 3.032912 +chr22 chr22:17967486:A:ACACACC A ACACACC 0.050000 120 -3.526178 2.828782 +chr22 chr22:17967492:ACCCACACACACC:ACACACACACC ACCCACACACACC ACACACACACC 0.200000 120 -3.042460 2.998437 +chr22 chr22:17967494:C:* C * 0.200000 120 -3.042460 2.998437 +chr22 chr22:17977536:TA:TAA TA TAA 0.233333 120 -3.754350 3.212340 +chr22 chr22:17998075:G:GTGAA G GTGAA 0.233333 120 -3.210571 2.884211 +chr22 chr22:18001877:A:C A C 0.541667 120 -2.763273 2.988475 +chr22 chr22:18064272:A:T A T 0.191667 120 -2.786614 3.633529 +chr22 chr22:18150441:CA:C CA C 0.133333 120 -3.101005 3.282066 +chr22 chr22:18159414:A:G A G 0.175000 120 -3.385007 3.168964 +chr22 chr22:18160557:T:C T C 0.225000 120 -3.655766 2.809528 +chr22 chr22:18166484:T:TGA T TGA 0.050000 120 -3.553404 3.884128 +chr22 chr22:18173426:C:A C A 0.133333 120 -3.352547 2.601712 +chr22 chr22:18730960:GTATACATAAGATATATTATATATAATATATTATATAAATGTATTATATATAACATATTATATATAATATATT:* GTATACATAAGATATATTATATATAATATATTATATAAATGTATTATATATAACATATTATATATAATATATT * 0.086207 116 -2.782364 3.251320 +chr22 chr22:18731027:T:C T C 0.042373 118 -3.507869 3.157315 +chr22 chr22:18850784:T:G T G 0.066667 120 -3.236300 2.990415 diff --git a/inst/scripts/build_bgen_fixtures.R b/inst/scripts/build_bgen_fixtures.R new file mode 100644 index 000000000..f2626b2ee --- /dev/null +++ b/inst/scripts/build_bgen_fixtures.R @@ -0,0 +1,45 @@ +# ============================================================================= +# Copy the BGEN reader's test fixtures from bgen's own examples. +# ----------------------------------------------------------------------------- +# complex.bgen and haplotypes.bgen are the bgen project's example files +# (github.com/gavinband/bgen), distributed under the Boost Software License +# 1.0, whose text is copied beside them. +# +# complex.bgen haploid and diploid samples, phased and unphased +# records, multi-allelic records and ploidy above 2; +# complex.vcf holds its probabilities as text, the truth +# the tests compare against. +# haplotypes.bgen phased haplotypes, with haplotypes.haps as its truth. +# +# The other BGEN fixtures -- each compression, odd bit depths, missing +# samples, a file without sample ids, layout 1 -- are written by the tests +# themselves (tests/testthat/helper-bgen.R). +# +# Run from the package root, with the bgen repository checked out at +# $BGEN_REPO (default ~/ghq/github.com/gavinband/bgen): +# Rscript inst/scripts/build_bgen_fixtures.R +# ============================================================================= + +bgenRepo <- Sys.getenv( + "BGEN_REPO", + file.path(Sys.getenv("HOME"), "ghq", "github.com", "gavinband", "bgen") +) +source <- file.path(bgenRepo, "example") +dest <- file.path("tests", "testthat", "test_data", "bgen") +files <- c( + "complex.bgen", + "complex.bgen.bgi", + "complex.sample", + "complex.vcf", + "haplotypes.bgen", + "haplotypes.bgen.bgi", + "haplotypes.haps" +) +stopifnot(dir.exists(source), all(file.exists(file.path(source, files)))) +dir.create(dest, showWarnings = FALSE, recursive = TRUE) +stopifnot(all(file.copy(file.path(source, files), dest, overwrite = TRUE))) +stopifnot(file.copy( + file.path(bgenRepo, "LICENSE_1_0.txt"), + dest, + overwrite = TRUE +)) diff --git a/inst/scripts/build_ctwas_examples.R b/inst/scripts/build_ctwas_examples.R index fe8a54f5f..682dff726 100644 --- a/inst/scripts/build_ctwas_examples.R +++ b/inst/scripts/build_ctwas_examples.R @@ -40,7 +40,7 @@ asBundledResource <- function(stem) { # A GenotypeHandle for `stem`, carrying the portable reference rather than # the concrete path it had to be read from. .portableHandle <- function(stem) { - handle <- pecotmr:::.ldSketchHandle(readGenotypes(plink2Prefix = stem)) + handle <- pecotmr:::.ldRefHandle(readGenotypes(plink2Prefix = stem)) handle@path <- asBundledResource(stem) handle } @@ -69,13 +69,13 @@ blocks <- GenomicRanges::GRanges( gwasSumStats <- loadGwasSumStatsFromManifest( manifest = data.frame(study = "gwas1", sumStatsPath = gwasTsv), genome = "hg38", - ldSketch = ldStem, + ldReference = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks ) gwasByRegion <- summaryStatsQc( gwasSumStats, - panelFilterArgs = PanelFilterParam(mafCutoff = 0.0025) + panelFilterParam = PanelFilterParam(mafCutoff = 0.0025) ) data(ctwasWeightsExample) @@ -97,13 +97,14 @@ data(ctwasWeightsExample) # back into a real path at read time, on whatever machine has the package. ctwasWeightsExample <- methods::initialize( ctwasWeightsExample, - ldSketch = pecotmr:::.asLdSketch(.portableHandle(ldStem)) + ldReference = pecotmr:::.asLdRef(.portableHandle(ldStem)) ) stopifnot( - path(pecotmr:::.ldSketchHandle( - ldSketch(ctwasWeightsExample) - )) == asBundledResource(ldStem) + path(pecotmr:::.ldRefHandle( + ldReference(ctwasWeightsExample) + )) == + asBundledResource(ldStem) ) # ----------------------------------------------------------------------------- @@ -116,13 +117,19 @@ ctwasInputsExample <- assembleCtwasInputs( ctwasEstExample <- estCtwasGroupPriors( ctwasInputsExample, - ctwasPriorArgs = CtwasPriorParam( + ctwasPriorParam = CtwasPriorParam( thin = 1, niterPrefit = 3, niter = 10, fallbackToPrefit = TRUE ), - methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0) + methodArgs = CtwasOptions( + regionData = CtwasRegionDataOptions(min_group_size = 1), + estParam = CtwasEstParamOptions( + min_group_size = 1, + min_p_single_effect = 0 + ) + ) ) # The toy GWAS carries no genome-wide-significant signal, so the default @@ -130,7 +137,9 @@ ctwasEstExample <- estCtwasGroupPriors( # empty result. Keep every region so the finemap payload is populated. screened <- screenCtwasRegions( ctwasEstExample, - methodArgs = CtwasOptions(min_nonSNP_PIP = 0) + methodArgs = CtwasOptions( + screen = CtwasScreenOptions(min_nonSNP_PIP = 0) + ) ) ctwasFinemapExample <- finemapCtwasRegions(screened) @@ -172,11 +181,13 @@ ctwasEstExample <- materializeLd(ctwasEstExample) ctwasFinemapExample <- materializeLd(ctwasFinemapExample) stopifnot( - all(!vapply( - pecotmr:::.ctwasCachedPanels(ctwasInputsExample), - function(p) is.null(p$R) || !is.null(p$sketch), - logical(1) - )) + all( + !vapply( + pecotmr:::.ctwasCachedPanels(ctwasInputsExample), + function(p) is.null(p$R) || !is.null(p$sketch), + logical(1) + ) + ) ) # ----------------------------------------------------------------------------- @@ -215,18 +226,26 @@ unlink(unique(c( invisible(estCtwasGroupPriors( ctwasInputsExample, - ctwasPriorArgs = CtwasPriorParam( + ctwasPriorParam = CtwasPriorParam( thin = 1, niterPrefit = 3, niter = 10, fallbackToPrefit = TRUE ), - methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0) + methodArgs = CtwasOptions( + regionData = CtwasRegionDataOptions(min_group_size = 1), + estParam = CtwasEstParamOptions( + min_group_size = 1, + min_p_single_effect = 0 + ) + ) )) invisible(finemapCtwasRegions( screenCtwasRegions( ctwasEstExample, - methodArgs = CtwasOptions(min_nonSNP_PIP = 0) + methodArgs = CtwasOptions( + screen = CtwasScreenOptions(min_nonSNP_PIP = 0) + ) ) )) invisible(asCtwasResult(ctwasFinemapExample)) diff --git a/inst/scripts/build_examples.R b/inst/scripts/build_examples.R index 2ad31cf55..d6ca6d0ee 100644 --- a/inst/scripts/build_examples.R +++ b/inst/scripts/build_examples.R @@ -2,7 +2,7 @@ # Build canonical S4 example objects for vignettes. # # Sources `inst/extdata/toy_ref.{bed,bim,fam}` (165 samples x 17,421 chr22 -# variants) for a real GenotypeHandle backing, then constructs synthetic +# variants) for a real PLINK1 genotype panel, then constructs synthetic # phenotypes / sumstats so the vignettes can demonstrate every S4 input # class with a single `data()` call. # @@ -22,17 +22,19 @@ library(purrr) set.seed(20260620L) # ----------------------------------------------------------------------------- -# 1. Build a GenotypeHandle from the bundled toy PLINK1 reference and pick a -# small contiguous window for fast vignette builds. +# 1. Read the bundled toy PLINK1 reference as a panel and pick a small +# contiguous window for fast vignette builds. # ----------------------------------------------------------------------------- toyBed <- system.file("extdata", "toy_ref.bed", package = "pecotmr") toyStem <- sub("\\.bed$", "", toyBed) -toyRef <- GenotypeHandle(plink1Prefix = toyStem) +toyRef <- readGenotypes(plink1Prefix = toyStem) # Pick the first 200 variants in a contiguous chr22 window for a small # but realistic LD block. snpIdx <- seq_len(200L) -windowSnpInfo <- toyRef@snpInfo[snpIdx, ] +windowSnpInfo <- pecotmr:::.rangesSnpInfo( + SummarizedExperiment::rowRanges(toyRef) +)[snpIdx, ] region <- sprintf("chr22:%d-%d", min(windowSnpInfo$BP), max(windowSnpInfo$BP)) # Build a small canonical-ID PLINK1 fileset in inst/extdata so the @@ -74,18 +76,19 @@ snpStats::write.plink( snp.major = TRUE, na.code = 0L ) -gh <- GenotypeHandle(plink1Prefix = smallStem) -windowSnpInfo <- gh@snpInfo +gh <- readGenotypes(plink1Prefix = smallStem) +windowSnpInfo <- pecotmr:::.rangesSnpInfo(SummarizedExperiment::rowRanges(gh)) # Materialise the dosage matrix once for synthetic-phenotype generation. -block <- extractBlockGenotypes(gh, snpIdx, meanImpute = TRUE) -X <- t(SummarizedExperiment::assay(block, "dosage")) # samples x variants +X <- pecotmr:::.meanImputeGeno( + t(as.matrix(SummarizedExperiment::assay(gh, "dosage")[snpIdx, ])) +) # samples x variants # ----------------------------------------------------------------------------- # 2. Synthesise a phenotype with two causal variants. # ----------------------------------------------------------------------------- nSample <- nrow(X) -sampleIds <- gh@sampleIds +sampleIds <- colnames(gh) causalIdx <- c(50L, 130L) beta <- numeric(ncol(X)) beta[causalIdx] <- c(0.7, -0.5) @@ -154,7 +157,7 @@ qtlSumStatsExample <- QtlSumStats( trait = "ENSG_example", entry = list(qtlGr), genome = "hg19", - ldSketch = gh, + ldReference = gh, qcInfo = list(prebuilt = "synthetic example data; QC bypassed") ) @@ -188,7 +191,7 @@ gwasSumStatsS4Example <- GwasSumStats( study = "trait1", entry = list(gwasGr), genome = "hg19", - ldSketch = gh, + ldReference = gh, qcInfo = list(prebuilt = "synthetic example data; QC bypassed") ) @@ -285,40 +288,51 @@ qtlSumStatsMulticontextExample <- QtlSumStats( trait = rep("ENSG_example", length(multiCtxNames)), entry = multiCtxEntries, genome = "hg19", - ldSketch = gh, + ldReference = gh, qcInfo = list(prebuilt = "synthetic multi-context example; QC bypassed") ) # ----------------------------------------------------------------------------- -# 7. Rewrite the GenotypeHandle paths to a portable bundled-resource reference +# 7. Point the PLINK1 panels at a portable bundled-resource reference # ("pecotmr://extdata/") so the .rda objects carry no source-tree -# absolute path. The genotype readers resolve this via system.file() at -# extraction time, so no user-facing fixup step is required. +# absolute path. The panel's seed resolves it via system.file() when it +# reads, so no user-facing fixup step is required. # ----------------------------------------------------------------------------- asResource <- function(p) paste0("pecotmr://extdata/", basename(p)) -# A QtlDataset holds its handle twice: as a slot and inside the lazy dosage -# assay's seed. Repointing only the slot would leave the assay reading the -# build machine's absolute path, so both move together. -repointHandle <- function(x) { - handle <- genotypeHandle(x) - handle@path <- asResource(handle@path) - pecotmr:::.qtlWithGenotypeHandle(x, handle) +# A PLINK1 panel records its stem twice: as its seed's backend, which reads +# the file, and as its genotype source, which says where it came from. Both +# move together. +asPortablePanel <- function(panel) { + seed <- pecotmr:::.panelSeed(panel) + ref <- asResource(pecotmr:::.gdSeedBackend(seed)) + SummarizedExperiment::assay(panel, "dosage", withDimnames = FALSE) <- + DelayedArray::DelayedArray(methods::initialize(seed, backend = ref)) + md <- S4Vectors::metadata(panel) + md$genotypeSource$path <- ref + S4Vectors::metadata(panel) <- md + panel +} +repointDataset <- function(x) { + pecotmr:::.qtlWithGenotypeHandle( + x, + asPortablePanel(pecotmr:::.qtlGenotypeSe(x)) + ) } -qtlDatasetExample <- repointHandle(qtlDatasetExample) -qtlSumStatsExample@ldSketch@path <- asResource( - qtlSumStatsExample@ldSketch@path +qtlDatasetExample <- repointDataset(qtlDatasetExample) +qtlSumStatsExample@ldReference <- asPortablePanel( + qtlSumStatsExample@ldReference ) -qtlSumStatsMulticontextExample@ldSketch@path <- asResource( - qtlSumStatsMulticontextExample@ldSketch@path +qtlSumStatsMulticontextExample@ldReference <- asPortablePanel( + qtlSumStatsMulticontextExample@ldReference ) -gwasSumStatsS4Example@ldSketch@path <- asResource( - gwasSumStatsS4Example@ldSketch@path +gwasSumStatsS4Example@ldReference <- asPortablePanel( + gwasSumStatsS4Example@ldReference ) multiStudyQtlDatasetExample@qtlDatasets <- map( multiStudyQtlDatasetExample@qtlDatasets, - repointHandle + repointDataset ) # ----------------------------------------------------------------------------- diff --git a/inst/scripts/build_h2_examples.R b/inst/scripts/build_h2_examples.R index ba9f278bb..a18826c7f 100644 --- a/inst/scripts/build_h2_examples.R +++ b/inst/scripts/build_h2_examples.R @@ -1,20 +1,29 @@ # ============================================================================= -# Rebuild ldEigenExample / ldScoreExample from a real LD reference. +# Rebuild ldEigenExample / ldScoreExample: LD references for estimateH2(). # ----------------------------------------------------------------------------- -# These two objects feed estimateH2(). The versions they replace were 20 SNPs -# in 2 blocks -- enough to demonstrate the accessors, but far too small to run -# a heritability estimator: every method returned a boundary value near zero, -# and two blocks cannot support the delete-one-block jackknife the standard -# errors come from. +# These two objects feed estimateH2(). An h2 estimator's reference panel has +# to be large: ldsc's unbiased r^2 and HDL's finite-reference term both +# correct for LD estimated from n samples, and at the size of the panel the +# package can ship (the xqtl-protocol MWE's 60 people) those corrections swamp +# the signal. What the examples hold is LD, not samples, so their size does +# not grow with n -- the panel can be large without being shipped. # -# They are now built from the xqtl-protocol MWE's chr22 LD reference: real -# genotype-derived LD over the same de-identified `protocol_example` panel the -# package already ships a slice of, using the LD blocks the protocol defines. -# `buildLdEigen()` / `buildLdScore()` do the work, so this script doubles as a -# worked example of them. +# So the reference is SIMULATED from real LD: +# +# 1. The population LD is the xqtl-protocol MWE's chr22 LD, block by block +# over the LD blocks the protocol defines (the first N_BLOCKS of them). +# 2. A panel of N_SIM people is drawn from that population: multivariate +# normal genotypes with that correlation. +# 3. Each block's LD is that panel's sample correlation, wrapped in an +# LdMatrix that records N_SIM and the variants' real allele frequencies, +# and buildLdEigen() / buildLdScore() do the rest -- so this script +# doubles as a worked example of them. # # Requires the MWE checkout; set MWE_DIR to point at it: # MWE_DIR=/path/to/xqtl-protocol Rscript inst/scripts/build_h2_examples.R +# +# The parity tests in test_h2EstimationWrappers.R do not read these objects +# (they hold their own frozen LD), so rebuilding them moves no pinned value. # ============================================================================= devtools::load_all(".", quiet = TRUE) @@ -24,10 +33,8 @@ mweDir <- Sys.getenv( "MWE_DIR", "/Users/danielnachun/Downloads/fungen_xqtl/xqtl-protocol" ) -metaPath <- file.path( - mweDir, - "input/ld_reference/protocol_example.ld_meta_file.tsv" -) +refDir <- file.path(mweDir, "input/ld_reference") +metaPath <- file.path(refDir, "protocol_example.ld_meta_file.tsv") if (!file.exists(metaPath)) { stop("Set MWE_DIR to an xqtl-protocol checkout; not found: ", metaPath) } @@ -36,24 +43,60 @@ if (!file.exists(metaPath)) { # a real LD block compress poorly, so the pair costs ~2.4 MB at 20 against # ~1.2 MB at 14 -- and 14 blocks still leaves a usable jackknife. N_BLOCKS <- 14L +# The simulated reference panel's size: large enough that LD-estimation noise +# is small next to the signal, as in a real biobank-scale reference. +N_SIM <- 20000L blocks <- read.delim(metaPath, check.names = FALSE) names(blocks)[1] <- "chr" chr22 <- blocks[blocks$chr == "chr22", ] chr22 <- head(chr22[order(chr22$start), ], N_BLOCKS) -regions <- sprintf("chr22:%d-%d", chr22$start, chr22$end) -message("Loading ", length(regions), " chr22 LD blocks...") +message("Reading the chr22 population LD over ", nrow(chr22), " blocks...") + +# The MWE reference is a stochastic sketch of 60 people; readGenotypes() +# records their real allele frequencies on the panel from its .afreq. +panel <- readGenotypes( + plink2Prefix = file.path(refDir, "chr22", "protocol_example.LD.chr22") +) +gr <- SummarizedExperiment::rowRanges(panel) + +# The panel rows inside one block. Blocks share their boundary coordinate, so +# each is taken half-open, [start, end), to give every variant one block. +blockIdx <- function(start, end) { + which(GenomicRanges::start(gr) >= start & GenomicRanges::start(gr) < end) +} +idxList <- compact(map2(chr22$start, chr22$end, function(s, e) { + idx <- blockIdx(s, e) + if (length(idx) >= 2L) idx +})) + +# Draw N_SIM people with correlation R (PSD, possibly rank-deficient: the MWE +# LD comes from 60 people) and return their sample correlation. +simulatedLd <- function(R) { + e <- eigen((R + t(R)) / 2, symmetric = TRUE) + keep <- e$values > 1e-10 + loadings <- e$vectors[, keep, drop = FALSE] %*% + diag(sqrt(e$values[keep]), sum(keep)) + Z <- matrix(rnorm(N_SIM * sum(keep)), N_SIM) %*% t(loadings) + cor(Z) +} -# One LdData per block: buildLd*() takes the list and gives one LD block per -# element. Loading the whole span at once would instead return a single dense -# matrix, i.e. one block, which no jackknife can work with. -ldList <- map(regions, function(r) loadLdMatrix(metaPath, region = r)) +set.seed(2026) +popLd <- map(idxList, function(idx) unname(computeLd(panel, snpIdx = idx))) +ldList <- map2(idxList, popLd, function(idx, R) { + LdMatrix( + simulatedLd(R), + variants = as(gr[idx], "GRanges"), + nSamples = N_SIM + ) +}) message( " ", sum(map_int(ldList, length)), " variants across ", length(ldList), - " blocks" + " blocks, reference n = ", + N_SIM ) ldEigenExample <- buildLdEigen(ldList, genome = "hg38") @@ -61,9 +104,10 @@ ldScoreExample <- buildLdScore(ldList, genome = "hg38") stopifnot( length(ldEigenExample) == length(ldScoreExample), - length(eigenList(ldEigenExample)) == N_BLOCKS, - length(ldMatrixList(ldScoreExample)) == N_BLOCKS, - identical(names(ldEigenExample), names(ldScoreExample)) + length(eigenList(ldEigenExample)) == length(ldList), + length(ldMatrixList(ldScoreExample)) == length(ldList), + identical(names(ldEigenExample), names(ldScoreExample)), + ldPanelNSamples(ldScoreExample) == N_SIM ) # The two routes to an LD score must agree, or one of them has drifted. @@ -73,20 +117,24 @@ stopifnot(all.equal( )) # ----------------------------------------------------------------------------- -# Confirm every estimator recovers a known h2 on this reference before saving. -# z is simulated under the standard model z ~ N(0, N R diag(v) R + R). +# Confirm every estimator recovers a known h2 before saving. The GWAS is drawn +# from the POPULATION LD, z ~ N(0, N R diag(v) R + R), and estimated against +# the simulated reference -- a finite sample of that population, as a real +# reference is. # ----------------------------------------------------------------------------- M <- length(ldEigenExample) N <- 1e5 h2True <- 0.4 perSnpVar <- rep(h2True / M, M) +snpIdx <- map(eigenList(ldEigenExample), "snpIdx") simZ <- function() { z <- numeric(M) - for (block in ldMatrixList(ldScoreExample)) { - idx <- block$snpIdx + for (b in seq_along(popLd)) { + R <- popLd[[b]] + idx <- snpIdx[[b]] p <- length(idx) - sigma <- N * (block$R %*% diag(perSnpVar[idx], p) %*% block$R) + block$R + sigma <- N * (R %*% diag(perSnpVar[idx], p) %*% R) + R sigma <- (sigma + t(sigma)) / 2 e <- eigen(sigma, symmetric = TRUE) z[idx] <- as.vector(e$vectors %*% (sqrt(pmax(e$values, 0)) * rnorm(p))) @@ -100,16 +148,15 @@ recovered <- replicate(5, { c( sldsc = pecotmr:::sldscUnivariate(z, N, ldScoreExample)$h2, gldsc = pecotmr:::gldscUnivariate(z, N, ldScoreExample)$h2, - lder = pecotmr:::lderUnivariate(z, N, ldEigenExample)$h2 + lder = pecotmr:::lderUnivariate(z, N, ldEigenExample)$h2, + hdl = suppressWarnings( + pecotmr:::hdlUnivariate(z, N, ldEigenExample)$h2 + ) ) }) message("h2 recovery (true 0.4):") print(round(rowMeans(recovered), 3)) stopifnot(all(abs(rowMeans(recovered) - h2True) < 0.15)) -# HDL is deliberately excluded from that check: it models reference-panel -# noise, and this panel's nRef is 1000, so it correctly shrinks hard. That is -# the estimator working, not failing -- see the heritability vignette. - usethis::use_data(ldEigenExample, overwrite = TRUE, compress = "xz") usethis::use_data(ldScoreExample, overwrite = TRUE, compress = "xz") diff --git a/inst/scripts/build_h2_parity_z.R b/inst/scripts/build_h2_parity_z.R new file mode 100644 index 000000000..b44ea924f --- /dev/null +++ b/inst/scripts/build_h2_parity_z.R @@ -0,0 +1,80 @@ +# ============================================================================= +# Rebuild tests/testthat/test_data/h2ParityZ.rds -- the z-scores the tests in +# test_h2EstimationWrappers.R compare against the original ldsc, HDL, LDER +# and gLDSC implementations. +# ----------------------------------------------------------------------------- +# These are stored rather than re-simulated inside the test because the draw +# uses eigen(), and eigen() fixes eigenvectors only up to SIGN. The sign a +# given LAPACK build returns is arbitrary, so regenerating from a seed +# produced different data on linux-64 than on osx-arm64 / linux-aarch64 -- +# and the expected numbers came from running the original implementations +# (ldsc's ldscore.regressions.Hsq, HDL, LDER, gldsc) on one platform's +# realization. That made three of those tests fail on linux-64 only. +# +# The draw is over the LD in tests/testthat/test_data/h2ParityLd.rds: the 14 +# chr22 blocks the bundled ldScoreExample held until 2026-10-20, frozen there +# so the bundled examples can be rebuilt without touching the parity tests. +# +# Rerunning this script invalidates the expected values in +# test_h2EstimationWrappers.R. Re-derive them on the NEW vectors at the same +# time: the data and the expected numbers are a matched pair. +# ============================================================================= + +library(purrr) + +fixture <- readRDS("tests/testthat/test_data/h2ParityLd.rds") + +# Each block's correlation matrix, rebuilt from its stored strict upper +# triangle. +blockR <- function(b) { + R <- diag(length(b$snpIdx)) + R[upper.tri(R)] <- b$upper + R[lower.tri(R)] <- t(R)[lower.tri(R)] + R +} + +# EXACT copy of the generator the pinned values were produced from. +simZ <- function(fixture, h2, n, seed) { + M <- nrow(fixture$snpInfo) + perSnpVar <- rep(h2 / M, M) + set.seed(seed) + z <- numeric(M) + for (b in fixture$blocks) { + R <- blockR(b) + idx <- b$snpIdx + p <- length(idx) + sigma <- n * (R %*% diag(perSnpVar[idx], p) %*% R) + R + e <- eigen((sigma + t(sigma)) / 2, symmetric = TRUE) + z[idx] <- as.vector(e$vectors %*% (sqrt(pmax(e$values, 0)) * rnorm(p))) + } + z +} + +# Every (h2, n, seed) the test file asks for. Keep in step with the call +# sites of .h2ParityZ() in test_h2EstimationWrappers.R -- a missing entry is +# a hard error there, not a silent re-simulation. +cases <- c( + list( + c(0.4, 1e4, 42), + c(0.15, 4e3, 7), + c(0.6, 2.5e4, 99), + c(0.3, 1e4, 5), + c(0.6, 5e4, 9), + c(0.4, 5e4, 3) + ), + # the HDL recovery test sweeps seeds 1:5 at (h2 = 0.4, n = 1e5) + map(1:5, function(s) c(0.4, 1e5, s)) +) +out <- list() +for (cs in cases) { + key <- paste(cs[[1]], cs[[2]], cs[[3]], sep = "_") + out[[key]] <- simZ(fixture, cs[[1]], cs[[2]], cs[[3]]) +} +saveRDS(out, "tests/testthat/test_data/h2ParityZ.rds", compress = "xz") +cat("keys:", paste(names(out), collapse = " | "), "\n") +cat("length each:", unique(lengths(out)), "\n") +cat( + "file size:", + file.size("tests/testthat/test_data/h2ParityZ.rds"), + "bytes\n" +) diff --git a/inst/scripts/build_sldsc_upstream_z.R b/inst/scripts/build_sldsc_upstream_z.R deleted file mode 100644 index 334e04518..000000000 --- a/inst/scripts/build_sldsc_upstream_z.R +++ /dev/null @@ -1,69 +0,0 @@ -# ============================================================================= -# Rebuild tests/testthat/test_data/sldscUpstreamZ.rds -- the z-scores the -# upstream-parity tests in test_h2EstimationWrappers.R are compared against. -# ----------------------------------------------------------------------------- -# These are stored rather than re-simulated inside the test because the draw -# uses eigen(), and eigen() fixes eigenvectors only up to SIGN. The sign a -# given LAPACK build returns is arbitrary, so regenerating from a seed -# produced different data on linux-64 than on osx-arm64 / linux-aarch64 -- -# and the expected numbers came from running upstream (ldsc's -# ldscore.regressions.Hsq, HDL, LDER, gldsc) on one platform's realization. -# That made three of those tests fail on linux-64 only. -# -# Two things must move together, or the tests silently stop meaning anything: -# -# 1. Rerunning this script invalidates the expected values in -# test_h2EstimationWrappers.R. Re-derive them from upstream on the NEW -# vectors at the same time. -# 2. These vectors are drawn over ldScoreExample's LD blocks, so rebuilding -# that object (build_h2_examples.R) requires rebuilding these too. -# ============================================================================= - -suppressMessages(devtools::load_all(".", quiet = TRUE, export_all = FALSE)) -library(purrr) -data(ldScoreExample) - -# EXACT copy of the in-test generator, so the captured z is the one the -# pinned upstream values were produced from. -simZ <- function(ref, h2, n, seed) { - M <- length(ref) - perSnpVar <- rep(h2 / M, M) - set.seed(seed) - z <- numeric(M) - for (b in pecotmr:::ldMatrixList(ref)) { - idx <- b$snpIdx - p <- length(idx) - sigma <- n * (b$R %*% diag(perSnpVar[idx], p) %*% b$R) + b$R - e <- eigen((sigma + t(sigma)) / 2, symmetric = TRUE) - z[idx] <- as.vector(e$vectors %*% (sqrt(pmax(e$values, 0)) * rnorm(p))) - } - z -} -# Every (h2, n, seed) the test file asks for. Keep in step with the call -# sites of .sldscUpstreamZ() in test_h2EstimationWrappers.R -- a missing -# entry is a hard error there, not a silent re-simulation. -cases <- c( - list( - c(0.4, 1e4, 42), - c(0.15, 4e3, 7), - c(0.6, 2.5e4, 99), - c(0.3, 1e4, 5), - c(0.6, 5e4, 9), - c(0.4, 5e4, 3) - ), - # the HDL recovery test sweeps seeds 1:5 at (h2 = 0.4, n = 1e5) - map(1:5, function(s) c(0.4, 1e5, s)) -) -out <- list() -for (cs in cases) { - key <- paste(cs[[1]], cs[[2]], cs[[3]], sep = "_") - out[[key]] <- simZ(ldScoreExample, cs[[1]], cs[[2]], cs[[3]]) -} -saveRDS(out, "tests/testthat/test_data/sldscUpstreamZ.rds", compress = "xz") -cat("keys:", paste(names(out), collapse = " | "), "\n") -cat("length each:", unique(lengths(out)), "\n") -cat( - "file size:", - file.size("tests/testthat/test_data/sldscUpstreamZ.rds"), - "bytes\n" -) diff --git a/inst/scripts/prepare_example_data.R b/inst/scripts/prepare_example_data.R index 58ce22119..926850d2a 100644 --- a/inst/scripts/prepare_example_data.R +++ b/inst/scripts/prepare_example_data.R @@ -176,7 +176,7 @@ qtlPost <- postprocessFinemappingFits( fits = list(susie = qtlFit), dataX = X, dataY = yRes, - minAbsCorr = qtlMinAbsCorr + credibleSetParam = CredibleSetParam(minAbsCorr = qtlMinAbsCorr) ) qtlRow <- qtlPost$finemappingResults$susie$finemappingEntry @@ -186,7 +186,7 @@ qtlFineMappingExample <- QtlFineMappingResult( trait = "gene_1", method = "susie", entry = list(qtlRow), - ldSketch = NULL + ldReference = NULL ) # --------------------------------------------------------------------------- @@ -238,7 +238,7 @@ gwasPost <- postprocessFinemappingFits( gwasRow <- gwasPost$finemappingResults$susieRss$finemappingEntry # qtlEnrichmentPipeline() requires the GWAS collection to carry a non-NULL -# ldSketch: that is its "this fit is RSS-derived" marker. It checks the +# ldReference: that is its "this fit is RSS-derived" marker. It checks the # handle's presence, and that it agrees with the QTL side when that one is also # non-NULL (here it is NULL, so the check is skipped) -- the panel itself is # never read. No genotype file for this CLU region is shipped, and the LD @@ -247,19 +247,23 @@ gwasRow <- gwasPost$finemappingResults$susieRss$finemappingEntry # shipped fixture. Note it spans chr22:14.5-15.8Mb and so shares no variant # with this chr22:32.1-33.1Mb fit; it satisfies the marker, nothing more. ldStem <- file.path("inst", "extdata", "toy_canonical") -gwasLdSketch <- GenotypeHandle(plink1Prefix = ldStem) -# Portable bundled-resource path, so the .rda carries no source-tree path. -gwasLdSketch@path <- paste0( - "pecotmr://extdata/", - basename(gwasLdSketch@path) -) +gwasLdReference <- readGenotypes(plink1Prefix = ldStem) +# Portable bundled-resource path, so the .rda carries no source-tree path: +# the panel's seed reads through it and its genotype source records it. +ldRef <- "pecotmr://extdata/toy_canonical" +ldSeed <- pecotmr:::.panelSeed(gwasLdReference) +SummarizedExperiment::assay(gwasLdReference, "dosage", withDimnames = FALSE) <- + DelayedArray::DelayedArray(methods::initialize(ldSeed, backend = ldRef)) +ldMeta <- S4Vectors::metadata(gwasLdReference) +ldMeta$genotypeSource$path <- ldRef +S4Vectors::metadata(gwasLdReference) <- ldMeta gwasFineMappingExample <- GwasFineMappingResult( study = "study_1", method = "susie", entry = list(gwasRow), blockId = "region_1", - ldSketch = gwasLdSketch + ldReference = gwasLdReference ) # --------------------------------------------------------------------------- @@ -313,7 +317,10 @@ for (nm in c("qtlFineMappingExample", "gwasFineMappingExample")) { nrow(summ) )) if (nrow(cs) == 0L) { - stop(nm, ": credibleSets() is empty, which is the defect this build fixes") + stop( + nm, + ": credibleSets() is empty, which is the defect this build fixes" + ) } } @@ -330,7 +337,7 @@ if (nShared != sum(lengths(qtlFineMappingExample))) { } # qtlEnrichmentPipeline() is what these two fixtures are documented for, and -# its non-NULL ldSketch requirement bites only at call time: a GWAS fixture +# its non-NULL ldReference requirement bites only at call time: a GWAS fixture # built without one still constructs, still validates, and still saves. Run it # here so that gap fails the build instead of the vignette. invisible(capture.output( diff --git a/inst/scripts/prepare_paired_finemapping_example.R b/inst/scripts/prepare_paired_finemapping_example.R index fe77df8c1..09f464fa9 100644 --- a/inst/scripts/prepare_paired_finemapping_example.R +++ b/inst/scripts/prepare_paired_finemapping_example.R @@ -72,7 +72,7 @@ qtlFineMappingPairedExample <- QtlFineMappingResult( trait = "gene1", method = "susie", entry = list(entry), - ldSketch = NULL + ldReference = NULL ) save( diff --git a/man/ColocBoostResult.Rd b/man/ColocBoostResult.Rd index 32f8cc162..d7d5e1ddf 100644 --- a/man/ColocBoostResult.Rd +++ b/man/ColocBoostResult.Rd @@ -9,7 +9,7 @@ ColocBoostResult( analysis, gwasStudy = NA_character_, outcomeInfo = NULL, - ldSketch = NULL, + ldReference = NULL, computingTime = list(), includeUncolocalized = TRUE ) @@ -29,7 +29,7 @@ naming the GWAS study for the per-study \code{separate_gwas} runs.} \item{outcomeInfo}{Data frame mapping outcome \code{name} to \code{study}, \code{context}, \code{trait} and \code{dataForm}.} -\item{ldSketch}{Optional genotype panel (see +\item{ldReference}{Optional genotype panel (see \code{\link{readGenotypes}}).} \item{computingTime}{Optional list of per-analysis timings.} diff --git a/man/ColocResult-class.Rd b/man/ColocResult-class.Rd index 0a37190ec..a1eb4c4f9 100644 --- a/man/ColocResult-class.Rd +++ b/man/ColocResult-class.Rd @@ -11,7 +11,7 @@ A collection of colocalization results, one element per tested \code{\link{colocCredibleSets}} and \code{\link{colocGenes}}. } \details{ -The inherited \code{ldSketch} is what +The inherited \code{ldReference} is what \code{colocCredibleSets()} uses to compute credible-set purity. } \seealso{ diff --git a/man/ColocResult.Rd b/man/ColocResult.Rd index fe97f3646..e20eaf187 100644 --- a/man/ColocResult.Rd +++ b/man/ColocResult.Rd @@ -4,7 +4,7 @@ \alias{ColocResult} \title{Build a ColocResult} \usage{ -ColocResult(pairs, variants, ldSketch = NULL) +ColocResult(pairs, variants, ldReference = NULL) } \arguments{ \item{pairs}{A data frame with one row per tested pair, carrying at least @@ -18,7 +18,7 @@ columns are \code{NA} for it.} \item{variants}{A list, parallel to \code{pairs}' rows, of per-pair data frames with a \code{variant_id} column and a \code{SNP.PP.H4} column.} -\item{ldSketch}{Optional genotype panel (see \code{\link{readGenotypes}}) +\item{ldReference}{Optional genotype panel (see \code{\link{readGenotypes}}) for the LD reference, used by \code{\link{colocCredibleSets}} to compute purity.} } diff --git a/man/ColocResultBase-class.Rd b/man/ColocResultBase-class.Rd index 3acd7a4a3..3c4e20acb 100644 --- a/man/ColocResultBase-class.Rd +++ b/man/ColocResultBase-class.Rd @@ -21,9 +21,10 @@ Virtual base shared by \code{\linkS4class{ColocResult}} (from \section{Slots}{ \describe{ -\item{\code{ldSketch}}{The LD reference panel the underlying fits were computed -against, or \code{NULL}. Shared by both subclasses: coloc and ColocBoost -report different statistics, but both are computed against a panel and -both are asked for it the same way.} +\item{\code{ldReference}}{The LD reference the underlying fits were computed +against (a genotype panel, a \code{GenotypeMixture} or an +\code{LdMatrix}), or \code{NULL}. Shared by both subclasses: coloc and +ColocBoost report different statistics, but both are computed against a +reference and both are asked for it the same way.} }} diff --git a/man/CredibleSetParam.Rd b/man/CredibleSetParam.Rd index d26a8ab90..a2dd06b03 100644 --- a/man/CredibleSetParam.Rd +++ b/man/CredibleSetParam.Rd @@ -18,6 +18,8 @@ \alias{perCsColumns<-} \alias{maxNumSingleEffects} \alias{maxNumSingleEffectsGreedy} +\alias{CredibleSetParam-class} +\alias{CredibleSetParam} \alias{csCoverage,CredibleSetParam-method} \alias{csCoverage<-,CredibleSetParam-method} \alias{secondaryCoverage,CredibleSetParam-method} @@ -34,8 +36,6 @@ \alias{perCsColumns<-,CredibleSetParam-method} \alias{maxNumSingleEffects,CredibleSetParam-method} \alias{maxNumSingleEffectsGreedy,CredibleSetParam-method} -\alias{CredibleSetParam-class} -\alias{CredibleSetParam} \title{Credible-Set Construction And Reporting} \usage{ csCoverage(x, ...) @@ -70,6 +70,18 @@ maxNumSingleEffects(x, ...) maxNumSingleEffectsGreedy(x, ...) +CredibleSetParam( + coverage = 0.95, + secondaryCoverage = c(0.7, 0.5), + signalCutoff = 0.025, + minAbsCorr = 0.8, + medianAbsCorr = NULL, + includeAllCs = FALSE, + perCsColumns = c("none", "alpha", "full"), + maxNumSingleEffects = 10L, + maxNumSingleEffectsGreedy = NULL +) + \S4method{csCoverage}{CredibleSetParam}(x) \S4method{csCoverage}{CredibleSetParam}(x) <- value @@ -101,18 +113,6 @@ maxNumSingleEffectsGreedy(x, ...) \S4method{maxNumSingleEffects}{CredibleSetParam}(x) \S4method{maxNumSingleEffectsGreedy}{CredibleSetParam}(x) - -CredibleSetParam( - coverage = 0.95, - secondaryCoverage = c(0.7, 0.5), - signalCutoff = 0.025, - minAbsCorr = 0.8, - medianAbsCorr = NULL, - includeAllCs = FALSE, - perCsColumns = c("none", "alpha", "full"), - maxNumSingleEffects = 10L, - maxNumSingleEffectsGreedy = NULL -) } \arguments{ \item{x}{A \code{CredibleSetParam}.} diff --git a/man/CrossValidationParam.Rd b/man/CrossValidationParam.Rd index 7dbdaf8cd..6ee6ac4cd 100644 --- a/man/CrossValidationParam.Rd +++ b/man/CrossValidationParam.Rd @@ -11,7 +11,8 @@ CrossValidationParam( numThreads = 1, samplePartition = NULL, maxVariants = NULL, - weightMethods = NULL + weightMethods = NULL, + fitFullData = TRUE ) } \arguments{ @@ -39,6 +40,13 @@ Unset cross-validates every method that produced non-zero weights. \strong{\code{twasWeightsPipeline} only} --- \code{fineMappingPipeline} ignores it, because its \code{methods=} are fine-mapping methods and its CV refits all of them.} + +\item{fitFullData}{Logical. \code{TRUE} (default) fits the final model on +the full data as well as cross-validating it; \code{FALSE} keeps only +the cross-validation results, and requires \code{folds >= 2}. A row +from such a run carries its \code{cvResult} and nothing else, so it +cannot be exported and cannot supply full-data weights or fits +downstream.} } \value{ A \code{CrossValidationParam} object, a \code{\link{MethodParam}}. @@ -47,12 +55,13 @@ A \code{CrossValidationParam} object, a \code{\link{MethodParam}}. How cross-validation runs, shared by \code{\link{fineMappingPipeline}} and \code{\link{twasWeightsPipeline}}. - \code{folds}, \code{numThreads} and \code{samplePartition} mean the same - thing in both. \code{maxVariants} and \code{weightMethods} are honoured - by \code{\link{twasWeightsPipeline}} only and are \strong{ignored} by - \code{\link{fineMappingPipeline}}, so one bundle can be handed to - either pipeline unchanged. + \code{folds}, \code{numThreads}, \code{samplePartition} and + \code{fitFullData} mean the same thing in both. \code{maxVariants} and + \code{weightMethods} are honoured by \code{\link{twasWeightsPipeline}} + only and are \strong{ignored} by \code{\link{fineMappingPipeline}}, so + one bundle can be handed to either pipeline unchanged. } \examples{ CrossValidationParam(folds = 10, numThreads = 4) +CrossValidationParam(folds = 5, fitFullData = FALSE) } diff --git a/man/FineMappingResultBase-class.Rd b/man/FineMappingResultBase-class.Rd index 60e582c61..f41dc3a6f 100644 --- a/man/FineMappingResultBase-class.Rd +++ b/man/FineMappingResultBase-class.Rd @@ -7,7 +7,7 @@ \description{ Virtual base class for fine-mapping result collections. Concrete subclasses (\code{QtlFineMappingResult}, \code{GwasFineMappingResult}) - carry a \code{DFrame} of per-fit rows and a shared \code{ldSketch} slot. + carry a \code{DFrame} of per-fit rows and a shared \code{ldReference} slot. Downstream pipelines should dispatch on \code{FineMappingResultBase} for behaviors that apply to either flavour, and on the concrete subclass when the tuple shape matters. @@ -15,9 +15,10 @@ Virtual base class for fine-mapping result collections. Concrete \section{Slots}{ \describe{ -\item{\code{ldSketch}}{The LD reference \code{GenotypeHandle} the fits were computed -against, or \code{NULL} when the fits were derived from individual-level -data (no LD reference). Used downstream for cross-pipeline LD-sketch -identity validation.} +\item{\code{ldReference}}{The LD reference the fits were computed against (a +genotype panel, a \code{GenotypeMixture} or an \code{LdMatrix}), or +\code{NULL} when the fits were derived from individual-level data. Used +downstream to check that pipelines combining results share one LD +reference.} }} diff --git a/man/GenotypeDosageSeed-class.Rd b/man/GenotypeDosageSeed-class.Rd new file mode 100644 index 000000000..96c89ebff --- /dev/null +++ b/man/GenotypeDosageSeed-class.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/GenotypeDosageSeed.R +\docType{class} +\name{GenotypeDosageSeed-class} +\alias{GenotypeDosageSeed-class} +\alias{dim,GenotypeDosageSeed-method} +\alias{dimnames,GenotypeDosageSeed-method} +\alias{extract_array,GenotypeDosageSeed-method} +\title{DelayedArray seed over a VCF, GDS or PLINK1 file} +\usage{ +\S4method{dim}{GenotypeDosageSeed}(x) + +\S4method{dimnames}{GenotypeDosageSeed}(x) + +\S4method{extract_array}{GenotypeDosageSeed}(x, index) +} +\description{ +Lets the dosages of a VCF, GDS or PLINK1 file back a \code{DelayedArray} +that reads the file a block at a time, as \code{GhSeed} does for the +formats a \code{GenotypeHandle} reads. +} +\section{Slots}{ + +\describe{ +\item{\code{backend}}{What the file is read through: a +\code{VariantAnnotation::VcfFile}, the \code{GDSArray} seed of the +GDS node holding the field, or the stem of a PLINK1 fileset, which +\code{PlinkMatrix::read_bed_subset()} reads.} + +\item{\code{field}}{Which field is read, and so how it becomes a dosage: +\code{"vcfGt"}, \code{"vcfDs"}, \code{"snpGdsSnpOrder"}, +\code{"snpGdsSampleOrder"}, \code{"seqArrayGt"}, +\code{"seqArrayDs"} or \code{"plinkBed"}.} + +\item{\code{rowRecord}}{Integer; for each row, the element of \code{records} it +reads.} + +\item{\code{rowAllele}}{Integer; for each row, the ALT allele it counts, 1 for a +record's first ALT allele.} + +\item{\code{records}}{Where each record is in the file. For a VCF, a +\code{GRanges} of each record's REF allele, with \code{posRank}, the +record's rank among those starting at its position; for a GDS, an +\code{IRanges} of the columns (or SeqArray's 2-bit planes) of the node +holding it; for a PLINK1 fileset, an \code{IRanges} of each variant's +position in the \code{.bed}.} + +\item{\code{dn}}{List of dimnames (variant ids, sample ids).} +}} + +\keyword{internal} diff --git a/man/GenotypeHandle-class.Rd b/man/GenotypeHandle-class.Rd index b7d253019..6bf821782 100644 --- a/man/GenotypeHandle-class.Rd +++ b/man/GenotypeHandle-class.Rd @@ -8,11 +8,7 @@ \usage{ GenotypeHandle( path = NULL, - plink1Prefix = NULL, plink2Prefix = NULL, - bed = NULL, - bim = NULL, - fam = NULL, pgen = NULL, pvar = NULL, psam = NULL, @@ -20,20 +16,14 @@ GenotypeHandle( region = NULL, genoMeta = NULL, chroms = NULL, - format = NULL, - vcfArgs = list() + format = NULL ) } \arguments{ -\item{path}{Single file path (.vcf/.vcf.gz/.vcf.bgz/.bcf/.gds), or -\code{NULL}.} - -\item{plink1Prefix}{Path prefix for a PLINK1 triplet, or \code{NULL}.} +\item{path}{Single file path (.bgen/.pgen), or \code{NULL}.} \item{plink2Prefix}{Path prefix for a PLINK2 triplet, or \code{NULL}.} -\item{bed, bim, fam}{Explicit paths to the PLINK1 triplet, or all \code{NULL}.} - \item{pgen, pvar, psam}{Explicit paths to the PLINK2 triplet, or all \code{NULL}.} @@ -41,10 +31,11 @@ GenotypeHandle( \code{start}, \code{end}, \code{path}; the \code{path} column may be comma-separated as \code{ld_file,bim_file}). Requires \code{region}. The constructor resolves the row covering \code{region}, then delegates to the -appropriate file-based handler. When the resolved row points at PLINK1 / -PLINK2 / VCF / GDS files, the corresponding reader is used; \code{.cor.xz} -(pre-computed LD-matrix) rows are not supported here -- use -\code{\link{loadLdMatrix}} for that case.} +appropriate file-based handler. When the resolved row points at PLINK2 +or BGEN files, the corresponding reader is used; a row pointing +at a pre-computed LD matrix (\code{.cor.xz}) is refused, as pecotmr reads +no pre-computed LD from disk -- wrap such a matrix in an +\code{\link{LdMatrix}} instead.} \item{region}{Region specification for \code{ldMeta} lookup: \code{"chr:start-end"} string or a one-row data.frame with \code{chrom}, @@ -53,7 +44,7 @@ PLINK2 / VCF / GDS files, the corresponding reader is used; \code{.cor.xz} \item{genoMeta}{One-file-per-chromosome specification: a path to a \code{#chr,path} meta file or a named character vector (names = chromosomes, values = payload paths/prefixes). Optionally pass -\code{format} via \code{...} to force a single backend for every shard.} +\code{format} to force a single backend for every shard.} \item{chroms}{Optional character vector of chromosomes. With \code{genoMeta} (a sharded, one-file-per-chromosome panel) only the shards whose chromosome @@ -65,42 +56,43 @@ shard is read (so the caller's own absence check can report the mismatch). Only meaningful with \code{genoMeta}; supplying it with any other source is an error (a single-file panel has no per-chromosome shards to skip).} -\item{vcfArgs}{Optional named list of arguments forwarded to -\code{VariantAnnotation::readVcf} when the source is a VCF.} +\item{format}{Character, \code{"plink2"} or \code{"bgen"}, forcing the +backend of \code{path} or of every \code{genoMeta} shard. If NULL, +inferred from the file extension.} } \value{ A \code{GenotypeHandle} object. } \description{ S4 container holding a path + format + metadata for lazy - genotype access. Supports PLINK1 (.bed/.bim/.fam), PLINK2 - (.pgen/.pvar/.psam), VCF/BCF, and GDS. + genotype access. Supports PLINK2 (.pgen/.pvar/.psam) and BGEN (.bgen + with its .bgi index); a VCF, GDS or PLINK1 file is read as a panel by + \code{readGenotypes()} without one. Construct a \code{GenotypeHandle} from one of several input forms. Exactly one of the following must be specified: \describe{ \item{\code{path}}{A single file path with a recognized extension: - \code{.vcf}, \code{.vcf.gz}, \code{.vcf.bgz}, \code{.bcf}, or - \code{.gds}. Format is auto-detected from the extension.} - \item{\code{plink1Prefix}}{A path prefix; the constructor appends - \code{.bed}, \code{.bim}, and \code{.fam} to locate the triplet.} + \code{.bgen} or \code{.pgen}. Format is auto-detected from the + extension. A BGEN file needs its \code{.bgi} index beside it, and + its sample ids in the file or in a \code{.sample} file beside it. A + VCF, GDS or PLINK1 file is refused: it is read as a panel by + \code{readGenotypes()}.} \item{\code{plink2Prefix}}{A path prefix; the constructor appends \code{.pgen}, \code{.pvar} (or \code{.pvar.zst}), and \code{.psam} to locate the triplet.} - \item{\code{bed} + \code{bim} + \code{fam}}{Explicit PLINK1 triplet. - The three files must share a stem; if they don't, use - \code{plink1Prefix} or arrange symlinks at a common stem.} \item{\code{pgen} + \code{pvar} + \code{psam}}{Explicit PLINK2 - triplet. Same shared-stem requirement.} + triplet. The three files must share a stem; if they don't, use + \code{plink2Prefix} or arrange symlinks at a common stem.} \item{\code{genoMeta}}{One genotype file per chromosome. Either a path to a whitespace/TSV meta file whose first column is the chromosome (\code{#chr}) and second column the per-chromosome payload - (a \code{.bed}/\code{.pgen}/\code{.vcf[.gz]}/\code{.bcf}/\code{.gds} - file or a PLINK prefix; relative paths resolve against the meta - file's directory), or a named character vector mapping chromosome to - payload. All shards must share one format and identical sample IDs in - the same order. Extraction is routed to the correct file by the - requested region's chromosome.} + (a \code{.pgen}/\code{.bgen} file or a PLINK2 prefix; + relative paths resolve against the meta file's directory), or a + named character vector mapping chromosome to payload. All shards + must share one format and identical sample IDs in the same order. + Extraction is routed to the correct file by the requested region's + chromosome.} } The constructor opens the file for metadata only (sample IDs and SNP info); dosage extraction is deferred until \code{extractBlockGenotypes()} @@ -118,8 +110,7 @@ Internal: the handle is the seed layer behind a genotype the chrom-meta file path (a display/provenance value); the per-chromosome payload files live in \code{chromPaths}.} -\item{\code{format}}{Character, one of \code{"plink1"}, \code{"plink2"}, -\code{"vcf"}, \code{"gds"}.} +\item{\code{format}}{Character, \code{"plink2"} or \code{"bgen"}.} \item{\code{snpInfo}}{data.frame, SNP metadata read from the index/sidecar. For a sharded handle this is the union across chromosomes (row-bound in the order diff --git a/man/GenotypeMixture-class.Rd b/man/GenotypeMixture-class.Rd new file mode 100644 index 000000000..f569ded8c --- /dev/null +++ b/man/GenotypeMixture-class.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/GenotypeMixture.R +\docType{class} +\name{GenotypeMixture-class} +\alias{GenotypeMixture-class} +\alias{show,GenotypeMixture-method} +\title{Mixture of Genotype Panels} +\usage{ +\S4method{show}{GenotypeMixture}(object) +} +\arguments{ +\item{object}{A \code{GenotypeMixture}.} +} +\description{ +A \code{GenotypeMixture} uses several genotype panels (see + \code{\link{readGenotypes}}) as one LD reference whose LD is the + weighted average of theirs, \eqn{\sum_k w_k R_k}. That is the LD of + summary statistics meta-analysed across cohorts, with each cohort's + weight its share of the GWAS sample size. + + Unlike an \code{\link{LdMatrix}} mixture, which is combined once when it + is built, the panels stay lazy and on disk: LD is read from each and + combined only for the variants a step asks about, and every panel keeps + answering for its own samples. A step that needs allele frequencies, + missingness or minor-allele counts judges each panel on its own and + drops a variant that fails in any of them. + + It \strong{is} a \code{MultiAssayExperiment} with one experiment per + cohort: that cohort's genotype panel, cut to the variants every panel + carries, in the first panel's order. The mixture's variants, as + \code{\link{variantIds}} gives them, are the first panel's. Each panel + keeps its own samples and allele coding, and its \code{rowData} column + \code{mixtureSign} is \code{1} where it codes a variant's alleles as the + first panel does and \code{-1} where it codes them the other way round. + The \code{sampleMap} names each sample \code{_}, since + cohorts can reuse sample ids, and the weights are + \code{metadata(x)$mixtureWeights} (see \code{\link{mixtureWeights}}). + + Row subsetting, \code{x[i, ]} by position, variant id or \code{GRanges}, + cuts every panel to the same variants, and column subsetting narrows + the panels' samples. A panel cannot be dropped, since the weights + describe all of them: build a new \code{GenotypeMixture} over the panels + wanted instead. +} +\seealso{ +\code{\link{GenotypeMixture}} to build one, \code{\link{LdMatrix}}. +} diff --git a/man/GenotypeMixture-constructor.Rd b/man/GenotypeMixture-constructor.Rd new file mode 100644 index 000000000..5b305b7f5 --- /dev/null +++ b/man/GenotypeMixture-constructor.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/GenotypeMixture.R +\name{GenotypeMixture} +\alias{GenotypeMixture} +\title{Build a GenotypeMixture} +\usage{ +GenotypeMixture(panels, mixtureWeights) +} +\arguments{ +\item{panels}{A named list of at least two genotype panels (see +\code{\link{readGenotypes}}). The names are the cohorts: they name the +mixture's experiments and prefix its samples.} + +\item{mixtureWeights}{One non-negative weight per panel, summing to 1; +typically each cohort's share of the GWAS sample size. Matched to the +panels by name when named, by position otherwise.} +} +\value{ +A \code{GenotypeMixture}. +} +\description{ +Combine genotype panels into one LD reference whose LD is + the weighted average of theirs. See \code{\link{GenotypeMixture-class}}. + + The panels are matched by position and alleles and put into the first + panel's allele coding, so they need not share variant ids or allele + orientation. The mixture covers the variants every panel carries; a + variant some panel lacks is left out, with a message. +} +\examples{ +panel <- readGenotypes(plink2Prefix = file.path(system.file("extdata", + "ld_reference", "chr22", package = "pecotmr"), + "protocol_example.LD.chr22")) +half <- seq_len(ncol(panel) / 2) +mix <- GenotypeMixture(list(EUR = panel[, half], AFR = panel[, -half]), + mixtureWeights = c(EUR = 0.7, AFR = 0.3)) +mix +} diff --git a/man/GwasFineMappingParam.Rd b/man/GwasFineMappingParam.Rd index eafabfd94..bcb5a1ea9 100644 --- a/man/GwasFineMappingParam.Rd +++ b/man/GwasFineMappingParam.Rd @@ -134,8 +134,8 @@ How \code{\link{colocPipeline}} fine-maps \code{gwasInput} \code{\link{fineMappingPipeline}}; the settings that pipeline exposes but that cannot apply here are deliberately absent: \code{fineMappingResult} (the pipeline is being asked to produce one), - \code{crossValidation} (refused on summary statistics) and - \code{residualization} (nothing to regress out). + \code{crossValidationParam} (refused on summary statistics) and + \code{residualizationParam} (nothing to regress out). The whole bundle is inert when \code{gwasInput} is already a fine-mapping result, since no fit is run. diff --git a/man/GwasFineMappingResult.Rd b/man/GwasFineMappingResult.Rd index 19af42fb3..4ce6f0508 100644 --- a/man/GwasFineMappingResult.Rd +++ b/man/GwasFineMappingResult.Rd @@ -14,7 +14,7 @@ GwasFineMappingResult( dataType = NULL, dataSource = NULL, weightStandardized = NULL, - ldSketch = NULL + ldReference = NULL ) } \arguments{ @@ -47,7 +47,7 @@ one per row; \code{NULL} (default) omits the column.} \item{dataSource}{Optional per-row label for the kind of input the fit saw, \code{"individual"} or \code{"sumstat"}. Recorded rather than derived: a combined collection can hold rows of both kinds, and its single -\code{ldSketch} cannot say which row came from which.} +\code{ldReference} cannot say which row came from which.} \item{weightStandardized}{Optional per-row flag: whether the posterior effect is on the STANDARDIZED genotype scale. The posterior effect IS the @@ -57,7 +57,7 @@ it standardizes genotypes before fitting, and the posterior mean is reported on the scale of the \code{X} the fit was given. The argument exists for a collection assembled by hand, where only the caller knows.} -\item{ldSketch}{An optional genotype panel (see +\item{ldReference}{An optional genotype panel (see \code{\link{readGenotypes}}).} } \value{ diff --git a/man/GwasSumStats-class.Rd b/man/GwasSumStats-class.Rd index c48e31e23..c3980a986 100644 --- a/man/GwasSumStats-class.Rd +++ b/man/GwasSumStats-class.Rd @@ -13,7 +13,7 @@ S4 collection of GWAS summary statistics keyed by the identity \details{ Required column: \code{study}, unique across rows. The class-level slots inherited from \code{\linkS4class{SumStatsBase}} -- - \code{ldSketch}, \code{genome} and \code{qcInfo} -- apply uniformly to + \code{ldReference}, \code{genome} and \code{qcInfo} -- apply uniformly to every row. } \seealso{ diff --git a/man/GwasSumStats.Rd b/man/GwasSumStats.Rd index 702189f04..f0d578fc2 100644 --- a/man/GwasSumStats.Rd +++ b/man/GwasSumStats.Rd @@ -8,7 +8,7 @@ GwasSumStats( studyName, entry, genome, - ldSketch = NULL, + ldReference = NULL, varY = NA_real_, nCase = NULL, nControl = NULL, @@ -27,10 +27,11 @@ study.} \item{genome}{Single character string giving the genome build (e.g., \code{"hg19"}, \code{"hg38"}). Uniform across the collection because all -entries share the same LD sketch.} +entries share the same LD reference.} -\item{ldSketch}{A genotype panel (see \code{\link{readGenotypes}}) -carrying the LD reference.} +\item{ldReference}{The LD reference: a genotype panel (see +\code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +\code{\link{LdMatrix}}.} \item{varY}{Optional numeric vector of per-study phenotype variances (\code{NA_real_} entries allowed). Used by the sufficient-statistic @@ -56,10 +57,9 @@ on construction; populated by \code{summaryStatsQc()} with a per-step audit record. Fine-mapping / TWAS pipelines reject inputs where \code{length(qcInfo(x)) == 0}.} -\item{ldBlocks}{Optional LD-block specification: an \code{LdBlocks}, a -\code{GRanges}, a data.frame with \code{chrom}/\code{start}/\code{end} -(plus an optional \code{blockId}), or a path to such a table. When -supplied, each +\item{ldBlocks}{Optional LD-block specification: a \code{GRanges}, a +data.frame with \code{chrom}/\code{start}/\code{end} (plus an optional +\code{blockId}), or a path to such a table. When supplied, each study's variants are split into one element per block rather than one per chromosome, and \code{blockId} takes the block's key (its \code{names}, else a \code{blockId} metadata column, else its coordinates). cTWAS needs @@ -86,7 +86,7 @@ A \code{GwasSumStats} object. \description{ Construct a \code{GwasSumStats} S4 DFrame-subclass collection from per-study tuple vectors and a list of \code{GRanges} entries (one per - study), plus a single LD sketch handle and a single genome build that apply + study), plus a single LD reference and a single genome build that apply to the whole collection. Each \code{GRanges} entry must carry per-variant statistics in its mcols (at @@ -100,5 +100,5 @@ gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100 * 1:3, width = 1)) S4Vectors::mcols(gr) <- S4Vectors::DataFrame(SNP = paste0("rs", 1:3), A1 = "A", A2 = "G", Z = rnorm(3), N = 100L) GwasSumStats(studyName = "t1", entry = list(gr), genome = "hg38", - ldSketch = panel) + ldReference = panel) } diff --git a/man/LdData-class.Rd b/man/LdData-class.Rd deleted file mode 100644 index 86f4e44a6..000000000 --- a/man/LdData-class.Rd +++ /dev/null @@ -1,77 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/LdData.R -\docType{class} -\name{LdData-class} -\alias{LdData-class} -\alias{[,LdData,ANY,ANY,ANY-method} -\title{LD Data Container} -\usage{ -\S4method{[}{LdData,ANY,ANY,ANY}(x, i, j, ..., drop = TRUE) -} -\arguments{ -\item{x}{An \code{LdData}.} - -\item{i, j, ...}{Subscripts; any use is an error.} - -\item{drop}{Ignored.} -} -\value{ -Nothing: this method always signals an error. -} -\description{ -S4 container for LD information. Stores either a pre-computed - correlation matrix or a \code{GenotypeHandle} (or list of handles for - mixture panels) for lazy genotype/correlation access. - - An \code{LdData} \strong{is} a \code{GRanges} over the variants it - covers -- carrying A1, A2, variant_id and optionally allele_freq, - variance and n_nomiss as metadata columns -- so \code{length()}, - \code{seqnames()} and \code{start()} answer directly, as they do for - \code{\link{LdScore}} and \code{\link{LdEigen}}. The correlation may - be NULL, in which case those ranges are the object's only record of which - variants it describes. -} -\section{Functions}{ -\itemize{ -\item \code{x = LdData[i = ANY, j = ANY, drop = ANY]}: Refused. Subsetting would narrow the variants -while \code{correlation} -- variant-by-variant, and \code{snpIdx}, which -indexes the reference panel -- stayed as they were, leaving an LD matrix -describing variants the object no longer has. Build the LdData over the -variant set you want instead. - -}} -\section{Slots}{ - -\describe{ -\item{\code{correlation}}{A correlation matrix, a list of per-block matrices -(block-diagonal LD), or NULL if genotypes are available and R should be -computed on demand.} - -\item{\code{genotypeHandle}}{Where genotypes are read from: a genotype handle, a -list of them (for mixture panels), a matrix of dosages already extracted -and filtered, or NULL when only pre-computed R is available. Pass a -genotype panel (see \code{\link{readGenotypes}}) to the constructor and -it is unwrapped to its handle.} - -\item{\code{snpIdx}}{Integer vector of 1-based SNP indices into the handle's -\code{snpInfo}. NULL when correlation is pre-computed, or when the -source is a matrix (which is already the subset).} - -\item{\code{blockMetadata}}{A \code{GRanges} with one range per block: its -\code{seqnames} and range are the block's chromosome and genomic span, -and \code{mcols} carry \code{blockId}, \code{size}, \code{startIdx} -and \code{endIdx} -- the index range into the correlation matrix the -block addresses. Extra columns the caller supplied are kept as mcols. -A block whose index range is out of bounds has no span to derive and -gets a width-0 range.} - -\item{\code{nSamples}}{Integer, reference panel sample size.} - -\item{\code{mixtureWeights}}{NULL when \code{genotypeHandle} is a single -\code{GenotypeHandle}; a numeric vector of mixing proportions (one per -panel, summing to 1) when \code{genotypeHandle} is a list of -\code{GenotypeHandle}s. Used by \code{ldMatrix()} to compute a -weighted-average mixture LD matrix; required whenever \code{genotypeHandle} -is a list and \code{ldMatrix()} will be called.} -}} - diff --git a/man/LdData.Rd b/man/LdData.Rd deleted file mode 100644 index a491ecdbd..000000000 --- a/man/LdData.Rd +++ /dev/null @@ -1,59 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/LdData.R -\name{LdData} -\alias{LdData} -\title{Create an LdData Object} -\usage{ -LdData( - correlation = NULL, - genotypeHandle = NULL, - snpIdx = NULL, - variants, - blockMetadata, - nSamples = 0L, - mixtureWeights = NULL -) -} -\arguments{ -\item{correlation}{A correlation matrix, list of matrices, or NULL.} - -\item{genotypeHandle}{A genotype panel (see -\code{\link{readGenotypes}}), a list of panels for a mixture reference, -a matrix of already-extracted dosages, or NULL.} - -\item{snpIdx}{Vector of 1-based SNP indices, coerced to integer, or NULL.} - -\item{variants}{A GRanges with variant metadata (must have variant_id in -mcols, plus A1, A2).} - -\item{blockMetadata}{Block boundaries: a \code{GRanges}, a -\code{data.frame} or a \code{DataFrame}. Whatever is absent for a -single block is derived from \code{variants}, so a bare genomic span --- or nothing at all -- is enough; with several blocks either the index -columns or \code{size} must be supplied. Normalised on the way in and -stored as a \code{GRanges} (see the \code{blockMetadata} slot).} - -\item{nSamples}{Integer, reference panel sample size.} - -\item{mixtureWeights}{Optional numeric vector of mixing proportions, one per -panel in \code{genotypeHandle} when it is a list. Must be non-negative and -sum to 1. Required whenever \code{genotypeHandle} is a list and downstream -code will call \code{ldMatrix()}.} -} -\value{ -An \code{LdData} object. -} -\description{ -Construct an \code{LdData} from a correlation matrix and/or - genotype handle, plus variant metadata as a GRanges. -} -\examples{ -data(eqtlRegionExample) -X <- eqtlRegionExample$X[, 1:8] -gr <- GenomicRanges::GRanges("22", - IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -ld <- LdData(correlation = cor(X), variants = gr, - blockMetadata = S4Vectors::DataFrame( - chrom = "22", start = 1L, end = 1000L)) -ld -} diff --git a/man/LdEigen-class.Rd b/man/LdEigen-class.Rd index 29c5c9a44..2304067d2 100644 --- a/man/LdEigen-class.Rd +++ b/man/LdEigen-class.Rd @@ -28,6 +28,14 @@ Pre-computed per-block eigendecompositions of the LD narrow when the ranges do, subsetting an \code{LdEigen} is refused rather than allowed to produce an object whose decompositions no longer describe its variants. + + An \code{LdEigen} built from a genotype panel stores no + decompositions: each block's is computed from the panel's factor (its + standardized genotypes) when an estimator reaches the block. That gives + the block's nonzero eigenvalues and their eigenvectors; when the panel + has fewer samples than the block has variants, the block's remaining + eigenvalues are exactly zero, and the estimators account for those + directions without listing them. } \section{Functions}{ \itemize{ @@ -40,7 +48,8 @@ variants the object no longer has. Recompute over the subset instead. \section{Slots}{ \describe{ -\item{\code{eigenList}}{A list of length \code{nBlocks}, each element a list with +\item{\code{eigenList}}{A list of length \code{nBlocks} (empty for an +\code{LdEigen} built from a genotype panel), each element a list with components: \describe{ \item{values}{Numeric vector of eigenvalues} diff --git a/man/LdMatrix-class.Rd b/man/LdMatrix-class.Rd new file mode 100644 index 000000000..bbcffe7cb --- /dev/null +++ b/man/LdMatrix-class.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/LdMatrix.R +\docType{class} +\name{LdMatrix-class} +\alias{LdMatrix-class} +\alias{show,LdMatrix-method} +\title{LD Correlation Matrix} +\usage{ +\S4method{show}{LdMatrix}(object) +} +\arguments{ +\item{object}{An \code{LdMatrix}.} +} +\description{ +An \code{LdMatrix} carries one LD correlation matrix together + with the variants it describes, and can stand wherever pecotmr takes an + LD reference (the \code{ldReference} of a summary-statistics collection, + \code{\link{raiss}}, the heritability builders). It \strong{is} a + \code{GRanges} over those variants, in the order of the matrix's rows, + with metadata columns \code{SNP} (the variant id), \code{A1} (the allele + whose dosage the correlations are signed by), \code{A2} and, optionally, + \code{AF} (the frequency of \code{A1}). + + The other kind of LD reference is a genotype panel (see + \code{\link{readGenotypes}}), which pecotmr reads from disk on demand. A + matrix carries no genotypes, so the steps that need them are not + available with one: the panel missingness filter, and RAiSS's + singular-value route (RAiSS falls back to the matrix itself). Steps that + need the panel's sample size or allele frequencies -- MAF / MAC panel + filters, DENTIST, ldsc's unbiased \eqn{r^2}, HDL -- use \code{nSamples} + and \code{AF} when they are supplied and refuse otherwise. + + Validity checks the matrix's shape and labels, that its diagonal is 1, + that its entries lie in \eqn{[-1, 1]}, and its symmetry on an evenly + spaced subset of entries. It does not check positive semi-definiteness, + which costs an eigendecomposition; run \code{\link{checkLd}} for that. +} +\section{Slots}{ + +\describe{ +\item{\code{correlation}}{The correlation matrix, its dimnames the variant ids.} + +\item{\code{nSamples}}{Integer, the number of independent samples the LD is +worth, or \code{NA} when unknown. For one panel this is its sample size. +For a mixture it is \eqn{1 / \sum_k w_k^2 / n_k}, the size of a single +panel whose LD would be as noisy.} + +\item{\code{mixtureWeights}}{The weights a mixture's components were combined +with; empty for a single panel's LD.} +}} + +\seealso{ +\code{\link{LdMatrix}} to build one, \code{\link{checkLd}}. +} diff --git a/man/LdMatrix-constructor.Rd b/man/LdMatrix-constructor.Rd new file mode 100644 index 000000000..73fdbaa45 --- /dev/null +++ b/man/LdMatrix-constructor.Rd @@ -0,0 +1,65 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/LdMatrix.R +\name{LdMatrix} +\alias{LdMatrix} +\title{Build an LdMatrix} +\usage{ +LdMatrix( + correlation, + variants = NULL, + nSamples = NA_integer_, + mixtureWeights = NULL +) +} +\arguments{ +\item{correlation}{A numeric correlation matrix, or a list of +\code{LdMatrix} objects to combine into a mixture.} + +\item{variants}{The variants the matrix covers, in its row order: a +\code{GRanges} or a data frame (see Description), or \code{NULL} to +parse them from the matrix's dimnames. Not used for a mixture.} + +\item{nSamples}{The size of the panel the LD was estimated from, or +\code{NA} when unknown. Not used for a mixture.} + +\item{mixtureWeights}{For a mixture, one non-negative weight per +component, summing to 1.} +} +\value{ +An \code{LdMatrix}. +} +\description{ +Wrap an LD correlation matrix, or combine several into a + mixture, for use as an LD reference. See \code{\link{LdMatrix-class}}. + + \strong{One panel's LD.} Pass the matrix and the variants it covers. + The variants may be given as a \code{GRanges} (metadata columns + \code{A1}, \code{A2}, and optionally \code{SNP} and \code{AF}), as a + data frame with columns \code{chrom}, \code{pos}, \code{A1}, \code{A2} + (and optionally \code{SNP}, \code{AF}), or omitted when the matrix's + dimnames are \code{chrom:pos:A2:A1} ids, from which they are parsed. The + correlations must be signed by the dosage of \code{A1}. + + \strong{A mixture.} Pass a list of \code{LdMatrix} objects and their + \code{mixtureWeights}. The result is their weighted average + \eqn{\sum_k w_k R_k}, computed once here, over the variants every + component covers; a variant some component lacks is left out, with a + message. Components are matched by position and alleles and put into + the first component's allele coding, so they need not share variant ids + or allele orientation. The mixture's \code{AF} is \eqn{\sum_k w_k AF_k} + when every component records \code{AF}, and its \code{nSamples} is + \eqn{1 / \sum_k w_k^2 / n_k} when every component records a size. +} +\examples{ +data(eqtlRegionExample) +X <- eqtlRegionExample$X[, 1:8] +ld <- LdMatrix(cor(X), nSamples = nrow(X)) +ld +ldMatrix(ld)[1:3, 1:3] + +# A mixture of two panels' LD, weighted 3:1. +half <- seq_len(nrow(X) / 2) +ldA <- LdMatrix(cor(X[half, ]), nSamples = length(half)) +ldB <- LdMatrix(cor(X[-half, ]), nSamples = nrow(X) - length(half)) +LdMatrix(list(ldA, ldB), mixtureWeights = c(0.75, 0.25)) +} diff --git a/man/LdScore-class.Rd b/man/LdScore-class.Rd index db9258ff7..54a587ef3 100644 --- a/man/LdScore-class.Rd +++ b/man/LdScore-class.Rd @@ -12,11 +12,20 @@ Pre-computed LD scores for each SNP. Used by S-LDSC and slots, because they are parallel to the variants: as slots they would survive a subset unchanged while the ranges narrowed, leaving scores describing variants that are no longer there. + + An \code{LdScore} storing per-block LD matrices (\code{ldMatrixList}) + cannot be subset or reordered: each block's matrix indexes its variants + by position, so narrowing the variants would leave it describing other + variants. A scores-only object, or one reading its LD from a genotype + panel, subsets freely. } \section{Slots}{ \describe{ -\item{\code{ldMatrixList}}{For g-LDSC: a list of per-block LD (R^2) matrices used to -compute the FGLS residual covariance. Empty for S-LDSC.} +\item{\code{ldMatrixList}}{For g-LDSC: a list of per-block LD correlation (R) +matrices used to compute the FGLS residual covariance, kept when the +scores were built from \code{LdMatrix} blocks. Empty for a scores-only +object, and for one built from a genotype panel, which reads each +block's LD from the panel instead (see \code{\linkS4class{LdStatistic}}).} }} diff --git a/man/LdScore.Rd b/man/LdScore.Rd index 6b9f1a18c..500cab4a8 100644 --- a/man/LdScore.Rd +++ b/man/LdScore.Rd @@ -20,7 +20,8 @@ LdScore( \code{BP}, \code{A1}, \code{A2} (and optionally \code{MAF}).} \item{ldScores}{A numeric matrix, one row per variant. The first column is -the base LD score (sum of r^2); further columns are +the base LD score (sum of r^2, which \code{\link{buildLdScore}} takes as +ldsc's unbiased r^2, as ldsc's own score files do); further columns are annotation-stratified scores.} \item{ldScoreWeights}{Numeric regression weights, one per variant.} diff --git a/man/LdStatistic-class.Rd b/man/LdStatistic-class.Rd index 723fbded1..a504ce726 100644 --- a/man/LdStatistic-class.Rd +++ b/man/LdStatistic-class.Rd @@ -15,6 +15,14 @@ Abstract container for pre-computed LD statistics. Subclasses live in \code{mcols} too, so subsetting narrows the ranges and the statistics together. The genome build comes from \code{seqinfo()} rather than a slot of its own. + + A statistic built from a genotype panel (or a + \code{\link{GenotypeMixture}}) keeps that reference rather than its + blocks' LD: each block's LD is read from the panel when an estimator + reaches the block, so only one block's is ever in memory, and + \code{mcols()} records each variant's row in the panel as + \code{panelRow}. One built from \code{\link{LdMatrix}} blocks stores + what it needs of their LD instead. } \section{Slots}{ @@ -25,5 +33,9 @@ Abstract container for pre-computed LD statistics. Subclasses \item{\code{inSample}}{Logical, whether the LD reference is from the same cohort as the GWAS (affects bias correction).} + +\item{\code{ldReference}}{The genotype panel or \code{GenotypeMixture} the +statistic reads its blocks' LD from, or \code{NULL} when it was built +from \code{LdMatrix} blocks.} }} diff --git a/man/PanelFilterParam.Rd b/man/PanelFilterParam.Rd index 9617a26b0..cad48d006 100644 --- a/man/PanelFilterParam.Rd +++ b/man/PanelFilterParam.Rd @@ -12,8 +12,9 @@ PanelFilterParam(mafCutoff = 0, macCutoff = 0, imissCutoff = 1) \item{mafCutoff}{Minor-allele-frequency floor. Default \code{0}.} \item{macCutoff}{Minor-allele-count floor; the stricter of this and -\code{mafCutoff} applies, using the panel's own sample count. Default -\code{0}.} +\code{mafCutoff} applies, using the panel's real sample count -- for a +stochastic LD sketch, the one its \code{.afreq} records, not its +pseudo-samples. Default \code{0}.} \item{imissCutoff}{Per-variant missingness ceiling. Default \code{1}, which filters nothing and lets the allele-frequency sidecar be read instead of diff --git a/man/PoolrOptions.Rd b/man/PoolrOptions.Rd index 3a033b936..439218156 100644 --- a/man/PoolrOptions.Rd +++ b/man/PoolrOptions.Rd @@ -12,7 +12,12 @@ correlation adjustment; pecotmr defaults it to \code{"generalized"}), \code{m}, \code{size}, \code{threshold}, \code{side}, \code{batchsize} and \code{nearpd}. The \pkg{poolr} signatures end in \code{...}, so names cannot be checked here and a misspelling is passed through. -\code{p} and \code{R} are supplied by pecotmr and refused.} +\code{p} and \code{R} are supplied by pecotmr and refused: \code{R} is +the caller's correlation among the test statistics, which pecotmr +converts with \code{poolr::mvnconv()} into the form the adjustment +reads (the covariances of each test's transformed statistic for +\code{"generalized"}, the correlations among the p-values for the +effective-number adjustments, unchanged for \code{"empirical"}).} } \value{ A \code{MethodOptions} record for diff --git a/man/QtlDataset-class.Rd b/man/QtlDataset-class.Rd index bbe982360..f2773105f 100644 --- a/man/QtlDataset-class.Rd +++ b/man/QtlDataset-class.Rd @@ -88,7 +88,7 @@ than one of the things being chosen between, so it is always retained. \describe{ \item{\code{studyName}}{Character (length 1). Study identifier; used in collection -classes to tag downstream \code{FineMappingResult} / \code{TwasWeights} +classes to tag downstream \code{QtlFineMappingResult} / \code{TwasWeights} entries. The \code{genotype} experiment's assay reads through this handle; the extraction accessors read it directly, so that QC can be applied per diff --git a/man/QtlFineMappingResult.Rd b/man/QtlFineMappingResult.Rd index ed2ccc4c3..c48c3593f 100644 --- a/man/QtlFineMappingResult.Rd +++ b/man/QtlFineMappingResult.Rd @@ -18,7 +18,7 @@ QtlFineMappingResult( dataType = NULL, dataSource = NULL, weightStandardized = NULL, - ldSketch = NULL + ldReference = NULL ) } \arguments{ @@ -63,7 +63,7 @@ one per row; \code{NULL} (default) omits the column.} \item{dataSource}{Optional per-row label for the kind of input the fit saw, \code{"individual"} or \code{"sumstat"}. Recorded rather than derived: a combined collection can hold rows of both kinds, and its single -\code{ldSketch} cannot say which row came from which.} +\code{ldReference} cannot say which row came from which.} \item{weightStandardized}{Optional per-row flag: whether the posterior effect is on the STANDARDIZED genotype scale. The posterior effect IS the @@ -73,9 +73,9 @@ it standardizes genotypes before fitting, and the posterior mean is reported on the scale of the \code{X} the fit was given. The argument exists for a collection assembled by hand, where only the caller knows.} -\item{ldSketch}{An optional genotype panel (see \code{\link{readGenotypes}}) -(the LD reference for RSS-derived fits), or \code{NULL} for -individual-level fits.} +\item{ldReference}{An optional genotype panel (see +\code{\link{readGenotypes}}) (the LD reference for RSS-derived fits), or +\code{NULL} for individual-level fits.} } \value{ A \code{QtlFineMappingResult} object. @@ -83,8 +83,8 @@ A \code{QtlFineMappingResult} object. \description{ Construct a \code{QtlFineMappingResult} DFrame-subclass collection from per-tuple vectors and a list of \code{FineMappingRow} - payloads (one per tuple). The optional \code{ldSketch} slot records the LD - reference used for RSS-derived fits; pass \code{NULL} (the default) for + payloads (one per tuple). The optional \code{ldReference} slot records the + LD reference used for RSS-derived fits; pass \code{NULL} (the default) for individual-level fits. } \examples{ diff --git a/man/QtlSumStats-class.Rd b/man/QtlSumStats-class.Rd index c909f8f12..eb172937a 100644 --- a/man/QtlSumStats-class.Rd +++ b/man/QtlSumStats-class.Rd @@ -13,7 +13,7 @@ S4 collection of QTL summary statistics keyed by the identity \details{ Required columns: \code{study}, \code{context} and \code{trait}; the 3-tuple is unique. The class-level slots inherited from - \code{\linkS4class{SumStatsBase}} -- \code{ldSketch}, \code{genome} and + \code{\linkS4class{SumStatsBase}} -- \code{ldReference}, \code{genome} and \code{qcInfo} -- apply uniformly to every row, and \code{qcInfo} records which \code{\link{summaryStatsQc}} passes have run. } diff --git a/man/QtlSumStats.Rd b/man/QtlSumStats.Rd index 5408fde15..f817cffd2 100644 --- a/man/QtlSumStats.Rd +++ b/man/QtlSumStats.Rd @@ -10,7 +10,7 @@ QtlSumStats( trait, entry, genome, - ldSketch = NULL, + ldReference = NULL, varY = NA_real_, nSample = NULL, qcInfo = list(), @@ -30,10 +30,11 @@ Same length as \code{study}, \code{context}, and \code{trait}.} \item{genome}{Single character string giving the genome build (e.g., \code{"hg19"}, \code{"hg38"}). Uniform across the collection because all -entries share the same LD sketch.} +entries share the same LD reference.} -\item{ldSketch}{A genotype panel (see \code{\link{readGenotypes}}) -carrying the LD reference.} +\item{ldReference}{The LD reference: a genotype panel (see +\code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +\code{\link{LdMatrix}}.} \item{varY}{Optional numeric vector of per-tuple phenotype variances (\code{NA_real_} entries allowed).} @@ -67,7 +68,7 @@ A \code{QtlSumStats} object. \description{ Construct a \code{QtlSumStats} S4 DFrame-subclass collection from per-tuple vectors and a list of \code{GRanges} entries (one per - tuple), plus a single LD sketch handle and a single genome build that apply + tuple), plus a single LD reference and a single genome build that apply to the whole collection. Each \code{GRanges} entry must carry per-variant statistics in its mcols (\code{SNP}, \code{A1}, \code{A2}, \code{Z}, \code{N}; plus optional \code{MAF}, \code{INFO}, \code{BETA}, \code{SE}, @@ -80,5 +81,5 @@ gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100 * 1:3, width = 1)) S4Vectors::mcols(gr) <- S4Vectors::DataFrame(SNP = paste0("rs", 1:3), A1 = "A", A2 = "G", Z = rnorm(3), N = 100L) QtlSumStats(studyName = "s1", context = "brain", trait = "g1", entry = - list(gr), genome = "hg38", ldSketch = panel) + list(gr), genome = "hg38", ldReference = panel) } diff --git a/man/RaissParam.Rd b/man/RaissParam.Rd index f8e26f9a7..80ad15a78 100644 --- a/man/RaissParam.Rd +++ b/man/RaissParam.Rd @@ -8,6 +8,7 @@ \usage{ RaissParam( lamb = 0.01, + rcond = 0.01, svdTol = 1e-12, r2Threshold = 0.6, minimumLd = 5, @@ -21,9 +22,15 @@ RaissParam( \item{lamb}{Regularization term added to the LD diagonal. Default \code{0.01}.} -\item{svdTol}{Singular-value cutoff for the pseudo-inverse. Default -\code{1e-12}. Note this is tighter than \code{\link{raiss}}'s own -\code{1e-8} default.} +\item{rcond}{Eigenvalue cutoff for the pseudo-inverse of the known +variants' LD: directions whose ridged eigenvalue is below \code{rcond} +times the largest are dropped. Default \code{0.01}, as +\code{\link{raiss}}'s own.} + +\item{svdTol}{Relative tolerance below which singular values of the +standardized genotypes are treated as numerically zero, used when the LD +reference is a genotype panel. Default \code{1e-12}. Note this is +tighter than \code{\link{raiss}}'s own \code{1e-8} default.} \item{r2Threshold}{Imputation \eqn{R^2} below which a variant is dropped from the output. Default \code{0.6}.} @@ -47,15 +54,15 @@ A \code{RaissParam} object, a \code{\link{MethodParam}}. } \description{ The settings \code{\link{summaryStatsQc}} uses when - \code{impute = TRUE}. Four are forwarded to \code{\link{raiss}}; the + \code{impute = TRUE}. Five are forwarded to \code{\link{raiss}}; the other four are pecotmr's own, bounding which panel variants RAISS is asked to impute and how wide a window it reads. - \code{\link{raiss}} also takes an \code{rcond}, but only on its - LD-matrix path. QC always hands it a genotype matrix, which routes - through the SVD solver and uses \code{svdTol} instead, so \code{rcond} - is not offered here --- naming it is an error rather than a setting that - silently does nothing. + \code{rcond} applies whatever the collection's LD reference is: QC hands + RAISS a genotype panel's dosages, which route through the SVD solver, or + an \code{\link{LdMatrix}}'s correlations, which are inverted directly, + and both drop the same weak directions. \code{svdTol} only matters on + the genotype route. } \examples{ RaissParam(mafCutoff = 0.01, flank = 5e5) diff --git a/man/SumStatsBase-class.Rd b/man/SumStatsBase-class.Rd index f433c1523..fa0adeb12 100644 --- a/man/SumStatsBase-class.Rd +++ b/man/SumStatsBase-class.Rd @@ -8,7 +8,7 @@ Virtual base class for QTL and GWAS summary statistics collections. Concrete subclasses (\code{QtlSumStats}, \code{GwasSumStats}) inherit from \code{\linkS4class{RangedTupleList}} and share the - \code{ldSketch} / \code{qcInfo} slots, and the genome build in + \code{ldReference} / \code{qcInfo} slots, and the genome build in \code{seqinfo()}. Each element is the per-variant \code{GRanges} of one tuple, so @@ -19,10 +19,13 @@ Virtual base class for QTL and GWAS summary statistics \section{Slots}{ \describe{ -\item{\code{ldSketch}}{The \code{GenotypeHandle} the QC pipeline harmonized against, -or \code{NULL}. Optional: LD-free workflows (e.g. mash, which operates -across conditions per variant) carry \code{NULL}; pipelines that need LD -validate its presence when they consume the collection.} +\item{\code{ldReference}}{The LD reference the collection was harmonized against +and every pipeline reads LD from: a genotype panel (see +\code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +\code{\link{LdMatrix}}, or \code{NULL}. Optional: LD-free workflows +(e.g. mash, which operates across conditions per variant) carry +\code{NULL}; pipelines that need LD validate its presence when they +consume the collection.} \item{\code{qcInfo}}{A \code{list} recording which QC steps ran. Empty \code{list()} on construction; populated by \code{summaryStatsQc()} with a per-step audit diff --git a/man/TwasWeights-class.Rd b/man/TwasWeights-class.Rd index 16a6d6452..575ddc2e5 100644 --- a/man/TwasWeights-class.Rd +++ b/man/TwasWeights-class.Rd @@ -25,9 +25,10 @@ jointly across the identity-tuple columns and any present joint columns. \section{Slots}{ \describe{ -\item{\code{ldSketch}}{The LD reference genotype panel the weights were -derived against, or \code{NULL} when the weights were learned from -individual-level data. Used downstream for cross-pipeline LD-sketch -identity validation.} +\item{\code{ldReference}}{The LD reference the weights were derived against (a +genotype panel, a \code{GenotypeMixture} or an \code{LdMatrix}), or +\code{NULL} when the weights were learned from individual-level data. +Used downstream to check that pipelines combining results share one LD +reference.} }} diff --git a/man/TwasWeights.Rd b/man/TwasWeights.Rd index f6c03e753..e69a95605 100644 --- a/man/TwasWeights.Rd +++ b/man/TwasWeights.Rd @@ -15,7 +15,7 @@ TwasWeights( jointTraits = NULL, traitPos = NULL, region = NULL, - ldSketch = NULL + ldReference = NULL ) } \arguments{ @@ -53,7 +53,7 @@ forward as provenance; not part of the identity key. \code{NULL} (default) omits the column, and \code{\link{genomicRegion}} then derives the window from the span of the variants present.} -\item{ldSketch}{An optional genotype panel (see +\item{ldReference}{An optional genotype panel (see \code{\link{readGenotypes}}), or \code{NULL} for individual-level fits.} } \value{ diff --git a/man/af.Rd b/man/af.Rd index 8551debce..0bd8a5820 100644 --- a/man/af.Rd +++ b/man/af.Rd @@ -1,13 +1,17 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, R/QtlDataset.R +% Please edit documentation in R/AllGenerics.R, R/LdMatrix.R, R/AllClasses.R, +% R/QtlDataset.R \name{af} \alias{af} +\alias{af,LdMatrix-method} \alias{af,SumStatsBase-method} \alias{af,QtlDataset-method} \title{Get Effect-Allele Frequencies} \usage{ af(x, ...) +\S4method{af}{LdMatrix}(x, ...) + \S4method{af}{SumStatsBase}( x, studyName = NULL, @@ -20,8 +24,8 @@ af(x, ...) \S4method{af}{QtlDataset}(x, traitId = NULL, region = NULL, cisWindow = NULL, samples = NULL) } \arguments{ -\item{x}{A \code{QtlDataset}, \code{GwasSumStats} or \code{QtlSumStats} -object.} +\item{x}{A \code{QtlDataset}, \code{LdMatrix}, \code{GwasSumStats} or +\code{QtlSumStats} object.} \item{...}{Class-specific selection arguments (e.g., \code{traitId}, \code{region}, \code{cisWindow}, \code{samples} for \code{QtlDataset}).} @@ -60,12 +64,13 @@ Named numeric vector of effect-allele frequencies (names are variant } \description{ Extract the directional effect-allele (A1) frequency vector - for a \code{QtlDataset}, or for one entry of a \code{GwasSumStats} / - \code{QtlSumStats} collection. Unlike \code{\link{maf}}, the value is - \emph{not} folded to the minor allele: it is the frequency of the - dosage-counted allele (A1, the effect allele), matching the allele the - marginal effect sizes and the fine-mapping \code{af} column report. For - a summary-statistic collection this is \code{NULL} when the source + for a \code{QtlDataset}, an \code{\link{LdMatrix}}, or one entry of a + \code{GwasSumStats} / \code{QtlSumStats} collection. Unlike + \code{\link{maf}}, the value is \emph{not} folded to the minor allele: it + is the frequency of the dosage-counted allele (A1, the effect allele), + matching the allele the marginal effect sizes and the fine-mapping + \code{af} column report. For a summary-statistic collection this is + \code{NULL} when the source carried no frequency column -- see \code{\link{variantColumnReplace}} for supplying one afterwards. } diff --git a/man/assembleCtwasInputs.Rd b/man/assembleCtwasInputs.Rd index 608970bb8..b871e86a0 100644 --- a/man/assembleCtwasInputs.Rd +++ b/man/assembleCtwasInputs.Rd @@ -10,7 +10,7 @@ assembleCtwasInputs( twasZ = NULL, fineMappingResult = NULL, method = NULL, - variantPruningArgs = VariantPruningParam() + variantPruningParam = VariantPruningParam() ) } \arguments{ @@ -53,7 +53,7 @@ present; otherwise run \strong{every} method as an independent cTWAS run (one \code{CtwasResult} row-set per method). Passing the name explicitly (e.g. \code{"mrash"}) restricts the run to that single method.} -\item{variantPruningArgs}{Which variants survive into each gene's weight +\item{variantPruningParam}{Which variants survive into each gene's weight matrix, built with \code{\link{VariantPruningParam}}: \code{weightCutoff}, \code{csMinCor}, \code{pipRescue} and \code{maxVariants}. Handed whole to @@ -92,7 +92,8 @@ blocks <- GenomicRanges::GRanges("chr22", IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000)), blockId = c("chr22_1", "chr22_2")) gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", - ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) + ldReference = ldStem, region = "chr22:10000000-19000000", + ldBlocks = blocks) gwasByRegion <- summaryStatsQc(gss, panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) assembleCtwasInputs(gwasSumStats = gwasByRegion, diff --git a/man/blockMetadata.Rd b/man/blockMetadata.Rd deleted file mode 100644 index a210d0a43..000000000 --- a/man/blockMetadata.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/LdData.R -\name{blockMetadata} -\alias{blockMetadata} -\alias{blockMetadata,LdData-method} -\title{Get Block Metadata} -\usage{ -blockMetadata(x) - -\S4method{blockMetadata}{LdData}(x) -} -\arguments{ -\item{x}{An \code{LdData}.} -} -\value{ -A \code{GRanges} or \code{data.frame}. -} -\description{ -Return the block metadata (\code{GRanges} or \code{data.frame}) - carried by an \code{LdData}. -} -\examples{ -data(eqtlRegionExample) -X <- eqtlRegionExample$X[, 1:8] -gr <- GenomicRanges::GRanges("22", - IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -ld <- LdData(correlation = cor(X), variants = gr, - blockMetadata = S4Vectors::DataFrame( - chrom = "22", start = 1L, end = 1000L)) -blockMetadata(ld) -} diff --git a/man/bplapplyBlocks.Rd b/man/bplapplyBlocks.Rd deleted file mode 100644 index 2939856f1..000000000 --- a/man/bplapplyBlocks.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/h2EstimationWrappers.R -\name{bplapplyBlocks} -\alias{bplapplyBlocks} -\title{Apply Function Per Block with BiocParallel} -\usage{ -bplapplyBlocks(blockIndices, FUN, BPPARAM = NULL, ...) -} -\arguments{ -\item{blockIndices}{List of SNP index vectors per block.} - -\item{FUN}{Function to apply to each block's indices.} - -\item{BPPARAM}{BiocParallel parameter object.} - -\item{...}{Additional arguments passed to FUN.} -} -\value{ -A list of results, one per block. -} -\description{ -Apply a function to each LD block in parallel. -} -\keyword{internal} diff --git a/man/buildLdEigen.Rd b/man/buildLdEigen.Rd index 10a885e82..817975529 100644 --- a/man/buildLdEigen.Rd +++ b/man/buildLdEigen.Rd @@ -2,10 +2,11 @@ % Please edit documentation in R/LdEigen.R \name{buildLdEigen} \alias{buildLdEigen} -\title{Build an LdEigen from loaded LD} +\title{Build an LdEigen from an LD reference} \usage{ buildLdEigen( - ldBlockData, + ldReference, + ldBlocks = NULL, nSamples = NULL, inSample = FALSE, genome = NA_character_, @@ -13,56 +14,62 @@ buildLdEigen( ) } \arguments{ -\item{ldBlockData}{An \code{\link{LdData}}, or a list of them, covering - the reference variants. An \code{LdData} whose correlation is a list of - per-block matrices contributes one LD block per matrix; one whose - correlation is a single matrix contributes one block. Blocks are kept in - the order given, and that order defines the variant order of the result. +\item{ldReference}{The LD reference, block by block: a list of + \code{\link{LdMatrix}} objects, one per LD block (a single + \code{LdMatrix} is one block), or a genotype panel (see + \code{\link{readGenotypes}}) together with \code{ldBlocks}. Blocks are + kept in the order given, and that order defines the variant order of the + result. Block structure matters downstream: \code{\link{estimateH2}} takes its standard error from a delete-one-block jackknife, so it requires at - least two blocks and wants many more. Loading a whole region as one - dense matrix yields a single block.} + least two blocks and wants many more.} -\item{nSamples}{Integer, the LD reference panel sample size. Defaults to the -size recorded by the supplied \code{LdData}; required when they record -none, and an error when they disagree.} +\item{ldBlocks}{With a genotype panel, the LD blocks to cut it into: a +\code{GRanges}, or a data frame with columns \code{chrom}, \code{start} +and \code{end}. Each block's LD is computed from the panel variants +inside it; variants outside every block are left out. Not used with +\code{LdMatrix} blocks.} + +\item{nSamples}{Integer, the number of samples the reference's LD was +estimated from. Defaults to a panel's sample count (a stochastic +sketch's effective size), or the size the \code{LdMatrix} blocks record; +required when they record none, and an error when they disagree.} \item{inSample}{Logical, whether the reference is the GWAS cohort itself. Selects LDER's weighting and HDL's finite-reference correction.} \item{genome}{Character, genome build. Defaults to the build recorded by -the supplied \code{LdData}, which \code{\link{loadLdMatrix}} leaves -unset.} +the reference's variants.} \item{eigenvalueTruncation}{Numeric in (0, 1]; the proportion of each block's eigenvalue mass to retain. \code{1} (the default) keeps every component; HDL conventionally uses \code{0.9}.} } \value{ -An \code{LdEigen} over every variant in \code{ldBlockData}. +An \code{LdEigen} over every variant in the reference's blocks. + One built from a genotype panel keeps the panel and decomposes each + block when it is needed, rather than storing the decompositions. } \description{ -Eigendecompose already-loaded LD, block by block, into the +Eigendecompose an LD reference, block by block, into the \code{LdEigen} that \code{\link{estimateH2}} consumes for \code{method = "lder"} and \code{method = "hdl"}. This is the supported route from an LD reference to an h2 input: \code{\link{LdEigen}} itself is the low-level constructor and expects the decompositions to have been computed already. - - No file I/O happens here. Read the LD first with - \code{\link{loadLdMatrix}} -- passing a vector of regions returns one - \code{LdData} per block -- then pass the result in. } \examples{ -meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", - package = "pecotmr") -ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") -ldEigen <- buildLdEigen(ld, genome = "hg38") +panel <- readGenotypes(plink2Prefix = file.path(system.file("extdata", + "ld_reference", "chr22", package = "pecotmr"), + "protocol_example.LD.chr22")) +blocks <- data.frame(chrom = "chr22", start = c(10000000, 15000001), + end = c(15000000, 19000000)) +ldEigen <- buildLdEigen(panel, ldBlocks = blocks, genome = "hg38") ldEigen length(eigenList(ldEigen)) } \seealso{ \code{\link{buildLdScore}} for the g-LDSC input, - \code{\link{estimateH2}}, \code{\link{loadLdMatrix}} + \code{\link{estimateH2}}, \code{\link{LdMatrix}} } diff --git a/man/buildLdScore.Rd b/man/buildLdScore.Rd index 42c490010..44a83dcc2 100644 --- a/man/buildLdScore.Rd +++ b/man/buildLdScore.Rd @@ -2,10 +2,11 @@ % Please edit documentation in R/LdScore.R \name{buildLdScore} \alias{buildLdScore} -\title{Build an LdScore from loaded LD} +\title{Build an LdScore from an LD reference} \usage{ buildLdScore( - ldBlockData, + ldReference, + ldBlocks = NULL, nSamples = NULL, inSample = FALSE, genome = NA_character_, @@ -14,58 +15,72 @@ buildLdScore( ) } \arguments{ -\item{ldBlockData}{An \code{\link{LdData}}, or a list of them, covering - the reference variants. An \code{LdData} whose correlation is a list of - per-block matrices contributes one LD block per matrix; one whose - correlation is a single matrix contributes one block. Blocks are kept in - the order given, and that order defines the variant order of the result. +\item{ldReference}{The LD reference, block by block: a list of + \code{\link{LdMatrix}} objects, one per LD block (a single + \code{LdMatrix} is one block), or a genotype panel (see + \code{\link{readGenotypes}}) together with \code{ldBlocks}. Blocks are + kept in the order given, and that order defines the variant order of the + result. Block structure matters downstream: \code{\link{estimateH2}} takes its standard error from a delete-one-block jackknife, so it requires at - least two blocks and wants many more. Loading a whole region as one - dense matrix yields a single block.} + least two blocks and wants many more.} -\item{nSamples}{Integer, the LD reference panel sample size. Defaults to the -size recorded by the supplied \code{LdData}; required when they record -none, and an error when they disagree.} +\item{ldBlocks}{With a genotype panel, the LD blocks to cut it into: a +\code{GRanges}, or a data frame with columns \code{chrom}, \code{start} +and \code{end}. Each block's LD is computed from the panel variants +inside it; variants outside every block are left out. Not used with +\code{LdMatrix} blocks.} + +\item{nSamples}{Integer, the number of samples the reference's LD was +estimated from. Defaults to a panel's sample count (a stochastic +sketch's effective size), or the size the \code{LdMatrix} blocks record; +required when they record none, and an error when they disagree. It is +also the \code{n} of the unbiased \eqn{r^2}, and it must exceed 2.} \item{inSample}{Logical, whether the reference is the GWAS cohort itself.} \item{genome}{Character, genome build. Defaults to the build recorded by -the supplied \code{LdData}, which \code{\link{loadLdMatrix}} leaves -unset.} +the reference's variants.} \item{ldScoreWeights}{Optional numeric regression weights, one per variant. Defaults to the conventional \eqn{1/\max(\ell_j, 1)}.} -\item{keepLdMatrices}{Logical. Keep each block's LD matrix on the result. -\code{TRUE} (the default) is required for \code{method = "gldsc"}, -which forms its FGLS residual covariance from them and errors without -them. \code{FALSE} drops them, leaving a scores-only object.} +\item{keepLdMatrices}{Logical, for \code{LdMatrix} blocks: keep each +block's LD matrix on the result. \code{TRUE} (the default) is required +for \code{method = "gldsc"} and for annotation-stratified scores, which +need each block's LD. \code{FALSE} drops them, leaving a scores-only +object. A genotype panel is never copied into matrices: the result keeps +the panel and reads each block's LD from it when it is needed, so it +serves every method either way.} } \value{ -An \code{LdScore} over every variant in \code{ldBlockData}. +An \code{LdScore} over every variant in the reference's blocks. } \description{ -Compute per-variant LD scores from already-loaded LD, block by +Compute per-variant LD scores from an LD reference, block by block, into the \code{LdScore} that \code{\link{estimateH2}} consumes for \code{method = "gldsc"}. This is the supported route from an LD reference to an h2 input: \code{\link{LdScore}} itself is the low-level constructor and expects the scores to have been computed already. - The score is \eqn{\ell_j = \sum_k r^2_{jk}} within each block, the same - quantity \code{\link{computeLdScores}} reconstructs from an - \code{\link{LdEigen}}, so the two agree on a shared reference. - - No file I/O happens here. Read the LD first with - \code{\link{loadLdMatrix}} -- passing a vector of regions returns one - \code{LdData} per block -- then pass the result in. + The score is \eqn{\ell_j = \sum_k r^2_{jk}} within each block, with + each term ldsc's unbiased estimate of \eqn{r^2} (Bulik-Sullivan et al. + 2015, \code{ldscore.py}): \code{r^2 - (1 - r^2) / (n - 2)}, where + \code{n} is the reference panel sample size. A sample \eqn{r^2} + overstates the population value by about \code{(1 - r^2) / (n - 2)}, + and a block sums many of them. A variant's own term stays 1, and + negative estimates are kept, as in ldsc. \code{\link{computeLdScores}} + gives the same scores from an \code{\link{LdEigen}} built on the same + reference. } \examples{ -meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", - package = "pecotmr") -ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") -ldScore <- buildLdScore(ld, genome = "hg38") +panel <- readGenotypes(plink2Prefix = file.path(system.file("extdata", + "ld_reference", "chr22", package = "pecotmr"), + "protocol_example.LD.chr22")) +blocks <- data.frame(chrom = "chr22", start = c(10000000, 15000001), + end = c(15000000, 19000000)) +ldScore <- buildLdScore(panel, ldBlocks = blocks, genome = "hg38") ldScore head(S4Vectors::mcols(ldScore)$ldScores) } diff --git a/man/causalInferencePipeline.Rd b/man/causalInferencePipeline.Rd index 491a7b673..6deb488c5 100644 --- a/man/causalInferencePipeline.Rd +++ b/man/causalInferencePipeline.Rd @@ -8,8 +8,8 @@ causalInferencePipeline( gwasSumStats, twasWeights = NULL, fineMappingResult = NULL, - weightSelectionArgs = WeightSelectionParam(), - mrArgs = MrParam(), + weightSelectionParam = WeightSelectionParam(), + mrParam = MrParam(), combineMethods = NULL, alleleFlip = TRUE ) @@ -27,7 +27,7 @@ supplied, drives the MR computation and (when \code{twasWeights = NULL}) the TWAS-Z weights via the SuSiE-style coefficients on each entry's \code{topLoci}.} -\item{weightSelectionArgs}{How one TWAS method's weights are picked per +\item{weightSelectionParam}{How one TWAS method's weights are picked per \code{(study, context, trait, gwasStudy)} tuple, built with \code{\link{WeightSelectionParam}}: \code{cutoff} (minimum cross-validated r-squared, default \code{0}), \code{pvalCutoff} (the @@ -39,7 +39,7 @@ gates that also produced a finite TWAS Z. Otherwise every method is carried through. Ports the legacy \code{twas_pipeline} \code{pick_best_model} / \code{update_twas_method}.} -\item{mrArgs}{How Mendelian randomization is run, built with +\item{mrParam}{How Mendelian randomization is run, built with \code{\link{MrParam}}: \code{method} (\code{"ivwPerVariant"}, the default, or \code{"csAware"}), the PIP threshold that method reads (\code{pipCutoff} or \code{cpipCutoff}), and \code{pvalCutoff}, the @@ -71,23 +71,26 @@ Per-region pipeline that pairs QTL-derived weight vectors \item \code{twasWeights} alone (no \code{fineMappingResult}): TWAS Z only, no MR. \item \code{fineMappingResult} alone (no \code{twasWeights}): - TWAS Z derived from SuSiE-style coefficients carried on the - \code{topLoci} slot of each FineMappingRow; plus MR. + TWAS Z derived from the SuSiE-style coefficients in each + row's top loci (\code{\link{topLoci}}); plus MR. \item both: TWAS Z computed from \code{twasWeights}; MR computed from \code{fineMappingResult}. } } -\section{LD-sketch compatibility check}{ - If a QTL input (TwasWeights or - QtlFineMappingResult) carries a non-\code{NULL} \code{ldSketch}, it must - come from the same reference panel as the \code{ldSketch} on - \code{gwasSumStats} --- same samples, same allele orientation on the - shared variants. The two need NOT carry the same variants: QC-ing the two - sides separately trims each sketch to its own surviving variants, and a - partial overlap only warns. A different sample set, a swapped A1/A2 on a - shared variant, or no shared variant at all is a hard error. A QTL input - with \code{ldSketch = NULL} (the fit was learned from individual-level - data) skips the validation for that input. +\section{LD reference compatibility check}{ + If a QTL input + (TwasWeights or QtlFineMappingResult) carries a non-\code{NULL} + \code{ldReference}, it must be the same LD reference as the + \code{ldReference} on \code{gwasSumStats}. + The two must be the same kind of reference. Two genotype panels must + share their samples and allele orientation; two \code{LdMatrix} objects + must agree on the LD they share; two \code{GenotypeMixture} objects must + average the same panels with the same weights. The two need NOT carry + the same variants: QC-ing the two sides separately trims each reference + to its own surviving variants, and a partial overlap only warns. A + mismatch of any of those, or no shared variant at all, is a hard error. A + QTL input with \code{ldReference = NULL} (the fit was learned from + individual-level data) skips the validation for that input. } \section{Output shape}{ diff --git a/man/checkGenomeBuild.Rd b/man/checkGenomeBuild.Rd index cf76db309..177953957 100644 --- a/man/checkGenomeBuild.Rd +++ b/man/checkGenomeBuild.Rd @@ -16,8 +16,8 @@ TRUE if all match, error otherwise. Check that genome builds match between objects. Each object contributes a single genome build (from its \code{genome} slot). An object that records no build is skipped rather than treated as a - mismatch: \code{loadLdMatrix()} leaves the build unset, so an LD - reference built from it names no build, and an unknown build cannot - contradict a known one. + mismatch: an LD reference often names no build (a genotype panel's + variants rarely carry one), and an unknown build cannot contradict a + known one. } \keyword{internal} diff --git a/man/colocPipeline.Rd b/man/colocPipeline.Rd index 71191a050..340c58b67 100644 --- a/man/colocPipeline.Rd +++ b/man/colocPipeline.Rd @@ -8,8 +8,8 @@ colocPipeline( qtlFineMappingResult, gwasInput, priors = ColocPriorParam(), - lbfFilterArgs = ColocLbfFilterParam(), - gwasFineMappingArgs = GwasFineMappingParam(), + colocLbfFilterParam = ColocLbfFilterParam(), + gwasFineMappingParam = GwasFineMappingParam(), returnGwasFineMapping = FALSE, enrichment = NULL, adjustPips = TRUE, @@ -32,7 +32,7 @@ fine-map inline (\code{\link{QtlSumStats}} or signal) and \code{p12} (shared). Mutually exclusive with \code{enrichment}, which derives the same three.} -\item{lbfFilterArgs}{Credible-set filtering applied before scoring, +\item{colocLbfFilterParam}{Credible-set filtering applied before scoring, built with \code{\link{ColocLbfFilterParam}}. \code{filterLbfCs} keeps only effects that produced a credible set; supplying \code{secondary} instead runs a @@ -44,7 +44,7 @@ are dropped before the LBF matrix reaches cutoff (effects with \code{V <= priorTol} are dropped) and does not apply once \code{filterLbfCs} or \code{secondary} selects another.} -\item{gwasFineMappingArgs}{How \code{gwasInput} is fine-mapped when it is +\item{gwasFineMappingParam}{How \code{gwasInput} is fine-mapped when it is summary statistics rather than a fine-mapping result, built with \code{\link{GwasFineMappingParam}}: \code{methods}, \code{credibleSetParam}, \code{susieRssParam}, @@ -155,7 +155,7 @@ directly. That choice carries three behaviours that \item \strong{fSuSiE support}: the LBF matrix lives at a different slot for fSuSiE fits (\code{fsusie_result$lBF}) and gets stacked into a single matrix. - \item \strong{Effect filtering}: \code{lbfFilter}'s + \item \strong{Effect filtering}: \code{colocLbfFilterParam}'s \code{filterLbfCs} keeps only effects that produced a credible set, its \code{secondary} keeps effects at a secondary coverage; otherwise the default filter drops effects whose prior variance is @@ -178,17 +178,19 @@ This pipeline preserves all three. } } -\section{LD-sketch compatibility check}{ +\section{LD reference compatibility check}{ If - \code{ldSketch(qtlFineMappingResult)} is non-\code{NULL}, it must come - from the same reference panel as the LD sketch on \code{gwasInput}: the - same samples, and the same allele orientation on the variants the two - carry in common. The two need NOT carry the same variants --- running - \code{\link{summaryStatsQc}} on the two sides separately normally leaves - each sketch trimmed to its own surviving variants, and LD is looked up per - variant, so a partial overlap only warns (once per session). No shared - variant at all, a different sample set, or a swapped A1/A2 on a shared - variant is a hard error. When the first side's \code{ldSketch} is + \code{ldReference(qtlFineMappingResult)} is non-\code{NULL}, it must be + the same LD reference as the one on \code{gwasInput}. + The two must be the same kind of reference. Two genotype panels must + share their samples and allele orientation; two \code{LdMatrix} objects + must agree on the LD they share; two \code{GenotypeMixture} objects must + average the same panels with the same weights. The two need NOT + carry the same variants --- running \code{\link{summaryStatsQc}} on the + two sides separately normally leaves each reference trimmed to its own + surviving variants, and LD is looked up per variant, so a partial overlap + only warns (once per session). No shared variant at all, or a mismatch of + any of those, is a hard error. When the first side's \code{ldReference} is \code{NULL} (individual-level fit), the validation is skipped on that side and the second side's panel is what the result carries forward. } diff --git a/man/colocViews.Rd b/man/colocViews.Rd index 12cff8e41..f727020ae 100644 --- a/man/colocViews.Rd +++ b/man/colocViews.Rd @@ -55,7 +55,7 @@ colocGenes(x, ...) before any LD work, so a stricter threshold costs strictly less.} \item{minAbsCorr}{Minimum absolute correlation between credible-set members -(purity). Requires the object's \code{ldSketch}; when that is absent, +(purity). Requires the object's \code{ldReference}; when that is absent, purity is reported as \code{NA} and no set is dropped.} \item{requireMaxH4}{Logical (length 1), default \code{FALSE}. When diff --git a/man/colocboostPipeline.Rd b/man/colocboostPipeline.Rd index 6b5a047eb..f8982ed0a 100644 --- a/man/colocboostPipeline.Rd +++ b/man/colocboostPipeline.Rd @@ -22,9 +22,9 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) separateGwas = FALSE, samples = NULL, panelFilterParam = PanelFilterParam(), - signalScreenArgs = SignalScreenParam(), + signalScreenParam = SignalScreenParam(), alleleFlip = TRUE, - residualizationArgs = ResidualizationParam(), + residualizationParam = ResidualizationParam(), methodArgs = ColocboostOptions() ) @@ -55,9 +55,9 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) separateGwas = FALSE, samples = NULL, panelFilterParam = PanelFilterParam(), - signalScreenArgs = SignalScreenParam(), + signalScreenParam = SignalScreenParam(), alleleFlip = TRUE, - residualizationArgs = ResidualizationParam(), + residualizationParam = ResidualizationParam(), methodArgs = ColocboostOptions() ) } @@ -110,7 +110,7 @@ below its cutoffs is dropped before the LD matrix is built. The defaults filter nothing. See the Details section for how these relate to the individual-level cutoffs recorded on a \code{QtlDataset}.} -\item{signalScreenArgs}{Individual-level pre-filter (ports the legacy +\item{signalScreenParam}{Individual-level pre-filter (ports the legacy \code{pip_cutoff_to_skip_ind}), built with \code{\link{SignalScreenParam}}. For each context every outcome is fit with a single-effect SuSiE (\code{L = 1}) and dropped unless the chosen @@ -136,7 +136,7 @@ swaps recognized (flipping z / residualized dosage / LD to a shared coding); when FALSE, match on exact alleles only (names-only), so a ref/alt swap is treated as a distinct variant.} -\item{residualizationArgs}{Covariate residualization settings for +\item{residualizationParam}{Covariate residualization settings for individual-level input, built with \code{\link{ResidualizationParam}}. Reaches both \code{\link{residualizedGenotypes}} and \code{\link{residualizedPhenotypes}}, so it governs what is regressed @@ -179,7 +179,7 @@ Protocol-level multi-trait colocalization analysis using extracted from the dataset (filtering knobs on the constructor apply lazily inside the accessors). \item \code{QtlSumStats} -- summary-statistic-only QTL data with a - shared LD reference (\code{ldSketch}). Must already have + shared LD reference (\code{ldReference}). Must already have been passed through \code{\link{summaryStatsQc}} (the pipeline rejects inputs whose \code{qcInfo()} is empty). Every analysis variant is available on this input, including @@ -192,7 +192,7 @@ Protocol-level multi-trait colocalization analysis using GWAS is optional and always passed separately as a \code{GwasSumStats} object (must also be QC'd). -\code{colocboostPipeline} does \strong{not} accept a \code{FineMappingResult} +\code{colocboostPipeline} does \strong{not} accept a fine-mapping result for either side; colocboost has its own variable-selection algorithm. } \section{QC contract}{ @@ -204,17 +204,17 @@ for either side; colocboost has its own variable-selection algorithm. \code{genotypes()} / \code{residualizedGenotypes()}. The pipeline does \emph{not} run a separate individual-level QC pass. - \item \code{panelFilter} acts at ANALYSIS time on the sumstat + \item \code{panelFilterParam} acts at ANALYSIS time on the sumstat sides, measured against the \strong{LD reference panel}: a variant whose panel genotypes fall below its cutoffs is dropped before the LD matrix is built. It applies to a \code{QtlSumStats} QTL side and to a \code{GwasSumStats} GWAS side (so it still bites when the QTL side is individual-level). Its defaults filter nothing. Unlike - \code{summaryStatsQc(imputeArgs = ...)}, which only bounds what + \code{summaryStatsQc(raissParam = ...)}, which only bounds what RAISS will impute, these discard \emph{observed} variants. \item All summary-statistic QC (variant filters, harmonization - against the \code{ldSketch}, LD-mismatch detection, RAISS + against the \code{ldReference}, LD-mismatch detection, RAISS imputation, etc.) lives in \code{\link{summaryStatsQc}}. The pipeline rejects any \code{QtlSumStats} or \code{GwasSumStats} where diff --git a/man/combineFineMappingResults.Rd b/man/combineFineMappingResults.Rd index c89c20580..5a0d5be7a 100644 --- a/man/combineFineMappingResults.Rd +++ b/man/combineFineMappingResults.Rd @@ -2,15 +2,15 @@ % Please edit documentation in R/fineMappingPipeline.R \name{combineFineMappingResults} \alias{combineFineMappingResults} -\title{Combine FineMappingResult collections} +\title{Combine fine-mapping result collections} \usage{ -combineFineMappingResults(..., ldSketch = NULL) +combineFineMappingResults(..., ldReference = NULL) } \arguments{ \item{...}{Two or more \code{FineMappingResultBase} objects, or a single \code{list} of them.} -\item{ldSketch}{Optional genotype panel (see +\item{ldReference}{Optional genotype panel (see \code{\link{readGenotypes}}) to attach to the combined collection. Default \code{NULL}. Applied when combining two or more inputs; a single input is returned unchanged.} diff --git a/man/combineGwasSumStats.Rd b/man/combineGwasSumStats.Rd index 7896fc379..40ce8ee1c 100644 --- a/man/combineGwasSumStats.Rd +++ b/man/combineGwasSumStats.Rd @@ -4,14 +4,14 @@ \alias{combineGwasSumStats} \title{Combine GwasSumStats collections} \usage{ -combineGwasSumStats(..., ldSketch = NULL) +combineGwasSumStats(..., ldReference = NULL) } \arguments{ \item{...}{Two or more \code{GwasSumStats} objects, or a single \code{list} of them.} -\item{ldSketch}{Optional genotype panel (see \code{\link{readGenotypes}}) to -attach to the combined collection, overriding the unioned one. Default +\item{ldReference}{Optional genotype panel (see \code{\link{readGenotypes}}) +to attach to the combined collection, overriding the unioned one. Default \code{NULL}.} } \value{ @@ -30,10 +30,13 @@ input: \code{genome} and the \code{\link{summaryStatsQc}} options must agree across the inputs (a mismatch is an error, not a silent first-wins), the per-element \code{qcInfo$entryAudit} concatenates in element order so \code{\link{qcDiagnostics}} keeps addressing the right element, and the -LD sketches union into one panel over the shared genotype handle. That last -one matters: block-parallel pipelines narrow each piece's panel to its own -block, so keeping only the first would leave a multi-block collection whose -LD reference covers one block. +LD references combine: genotype panels union into one panel over the shared +genotype handle. That last one matters: block-parallel pipelines narrow each +piece's panel to its own block, so keeping only the first would leave a +multi-block collection whose LD reference covers one block. An +\code{LdMatrix} or a \code{GenotypeMixture} cannot be unioned that way; +one of the inputs' references must already cover the others, or the +combined one is passed as \code{ldReference}. } \examples{ data(gwasSumStatsS4Example) diff --git a/man/combinePValues.Rd b/man/combinePValues.Rd index d1147a3c4..8fb9ee297 100644 --- a/man/combinePValues.Rd +++ b/man/combinePValues.Rd @@ -10,7 +10,7 @@ combinePValues( methods, R = NULL, naRm = TRUE, - methodArgs = PvalMethodsParam() + pvalMethodsParam = PvalMethodsParam() ) } \arguments{ @@ -22,13 +22,14 @@ work on p-values; derivable from \code{zScores}.} \item{methods}{Character vector of combination method names; see above for the menu (lowercase).} -\item{R}{Optional correlation matrix aligned to \code{pvals} / +\item{R}{Optional correlation matrix among the test statistics (for +variant-level tests, their LD), aligned to \code{pvals} / \code{zScores}. Required for the correlation-adjusted methods.} \item{naRm}{Logical; if \code{TRUE} (default), drop NA p-values before combination.} -\item{methodArgs}{Per-method engine options, built with +\item{pvalMethodsParam}{Per-method engine options, built with \code{\link{PvalMethodsParam}} -- for example \code{PvalMethodsParam(aspu = AspuOptions(n.perm = 5000))}. Configuring a method that \code{methods} does not request is an error rather than a diff --git a/man/combineQtlSumStats.Rd b/man/combineQtlSumStats.Rd index fe562597a..4ac249b2d 100644 --- a/man/combineQtlSumStats.Rd +++ b/man/combineQtlSumStats.Rd @@ -4,14 +4,14 @@ \alias{combineQtlSumStats} \title{Combine QtlSumStats collections} \usage{ -combineQtlSumStats(..., ldSketch = NULL) +combineQtlSumStats(..., ldReference = NULL) } \arguments{ \item{...}{Two or more \code{QtlSumStats} objects, or a single \code{list} of them.} -\item{ldSketch}{Optional genotype panel (see \code{\link{readGenotypes}}) to -attach to the combined collection, overriding the unioned one. Default +\item{ldReference}{Optional genotype panel (see \code{\link{readGenotypes}}) +to attach to the combined collection, overriding the unioned one. Default \code{NULL}.} } \value{ @@ -27,9 +27,9 @@ lacking an optional column is NA-padded. The three collection-level slots are merged rather than taken from the first input, on the same rules as \code{\link{combineGwasSumStats}}: \code{genome} and the \code{\link{summaryStatsQc}} options must agree, the per-element -\code{qcInfo$entryAudit} concatenates in element order, and the LD sketches -union over the shared genotype handle (all-\code{NULL} stays \code{NULL}, -which is the usual case for individual-level QTL data). +\code{qcInfo$entryAudit} concatenates in element order, and the LD +references combine the same way (all-\code{NULL} stays \code{NULL}, which +is the usual case for individual-level QTL data). } \examples{ data(qtlSumStatsExample) diff --git a/man/combineTwasWeights.Rd b/man/combineTwasWeights.Rd index 78b3adf29..5b2f98b93 100644 --- a/man/combineTwasWeights.Rd +++ b/man/combineTwasWeights.Rd @@ -4,14 +4,14 @@ \alias{combineTwasWeights} \title{Combine TwasWeights collections} \usage{ -combineTwasWeights(..., ldSketch = NULL) +combineTwasWeights(..., ldReference = NULL) } \arguments{ \item{...}{Two or more \code{TwasWeights} objects, or a single \code{list} of them.} -\item{ldSketch}{Optional genotype panel (see \code{\link{readGenotypes}}) to -attach to the +\item{ldReference}{Optional genotype panel (see \code{\link{readGenotypes}}) +to attach to the combined collection. Default \code{NULL}. Applied when combining two or more inputs; a single input is returned unchanged.} } diff --git a/man/computeCsCorrelation.Rd b/man/computeCsCorrelation.Rd index b18b04b37..792699277 100644 --- a/man/computeCsCorrelation.Rd +++ b/man/computeCsCorrelation.Rd @@ -19,7 +19,7 @@ membership and PIP) and its variant ids.} \item{ldSource}{The object supplying the LD: a \code{QtlDataset} (individual-level; genotypes via \code{\link{genotypes}}) or a \code{QtlSumStats} / \code{GwasSumStats} (summary statistics; LD via -\code{\link{ldSketch}}). Any other type is an error.} +\code{\link{ldReference}}). Any other type is an error.} \item{...}{Passed to methods.} } @@ -33,7 +33,7 @@ Compute the between-credible-set correlation matrix for a \code{\link{fineMappingRow}} on demand from an LD source. The correlation is a view over the fit-time LD, which lives on the data object --- a \code{QtlDataset}'s genotypes or a \code{QtlSumStats} / \code{GwasSumStats} - LD sketch --- and is deliberately never stored on the fit. An + LD reference --- and is deliberately never stored on the fit. An \code{ldSource} is therefore always required. } \examples{ diff --git a/man/computeLd.Rd b/man/computeLd.Rd index d5ae36c46..cfcf9374b 100644 --- a/man/computeLd.Rd +++ b/man/computeLd.Rd @@ -60,11 +60,14 @@ Correlation between variants, from either a dosage matrix \code{cor()} without it) and is both the fastest and the default; \code{"snprelate"} and \code{"snpstats"} exist to cross-check it and do strictly more work, since each converts the same matrix into its own - representation first. + representation first. Both store genotypes as the integer codes 0, 1 and + 2, so they refuse fractional dosages (imputed, or a stochastic sketch's) + rather than round them; \code{"internal"} correlates dosages as they + are. } \examples{ data(qtlSumStatsExample) -panel <- ldSketch(qtlSumStatsExample) +panel <- ldReference(qtlSumStatsExample) R <- computeLd(panel, snpIdx = 1:5) dim(R) # A dosage matrix already in memory is correlated directly. diff --git a/man/computeLdScores.Rd b/man/computeLdScores.Rd index ff2bd3cc6..fa337e29e 100644 --- a/man/computeLdScores.Rd +++ b/man/computeLdScores.Rd @@ -24,7 +24,9 @@ A numeric matrix of LD scores (SNPs x annotations+1). } \description{ Compute LD scores from an LD reference, optionally stratified by - annotations. + annotations. Each r-squared is ldsc's small-sample unbiased estimate, + \eqn{r^2 - (1 - r^2)/(n - 2)} for a reference of \eqn{n} samples, as + \code{\link{buildLdScore}} stores, so the two agree. } \examples{ data(ldEigenExample) diff --git a/man/contexts.Rd b/man/contexts.Rd index 6a1e2006a..ee1319e35 100644 --- a/man/contexts.Rd +++ b/man/contexts.Rd @@ -1,14 +1,14 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/CtwasResult.R, -% R/GwasFineMappingResult.R, R/QtlDataset.R, R/QtlFineMappingResult.R, -% R/qtlSumStats.R, R/twasWeights.R +% R/GwasFineMappingResult.R, R/qtlSumStats.R, R/QtlDataset.R, +% R/QtlFineMappingResult.R, R/twasWeights.R \name{contexts} \alias{contexts} \alias{contexts,CtwasResult-method} \alias{contexts,GwasFineMappingResult-method} +\alias{contexts,QtlSumStats-method} \alias{contexts,QtlDataset-method} \alias{contexts,QtlFineMappingResult-method} -\alias{contexts,QtlSumStats-method} \alias{contexts,TwasWeights-method} \title{Get Context Names} \usage{ @@ -18,12 +18,12 @@ contexts(x) \S4method{contexts}{GwasFineMappingResult}(x) +\S4method{contexts}{QtlSumStats}(x) + \S4method{contexts}{QtlDataset}(x) \S4method{contexts}{QtlFineMappingResult}(x) -\S4method{contexts}{QtlSumStats}(x) - \S4method{contexts}{TwasWeights}(x) } \arguments{ diff --git a/man/credibleSetSummary.Rd b/man/credibleSetSummary.Rd index 798f7379a..5fc921049 100644 --- a/man/credibleSetSummary.Rd +++ b/man/credibleSetSummary.Rd @@ -10,7 +10,7 @@ credibleSetSummary(x, ...) \S4method{credibleSetSummary}{FineMappingResultBase}(x, coverage = 0.95) } \arguments{ -\item{x}{A \code{FineMappingRow} or \code{FineMappingResultBase}.} +\item{x}{A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}.} \item{...}{Ignored.} diff --git a/man/credibleSets.Rd b/man/credibleSets.Rd index cd6f77750..e07206b21 100644 --- a/man/credibleSets.Rd +++ b/man/credibleSets.Rd @@ -19,7 +19,7 @@ credibleSets(x, ...) ) } \arguments{ -\item{x}{A \code{FineMappingRow} or \code{FineMappingResult}.} +\item{x}{A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}.} \item{...}{Class-specific selection arguments plus \code{coverage}.} diff --git a/man/ctwasInputsExample.Rd b/man/ctwasInputsExample.Rd index 77ec6c070..91f07dbe2 100644 --- a/man/ctwasInputsExample.Rd +++ b/man/ctwasInputsExample.Rd @@ -7,7 +7,10 @@ \format{ A list with the cTWAS input components \code{z_snp}, \code{z_gene}, \code{weights}, \code{region_info}, \code{snp_map}, \code{LD_map}, and the - LD / SNP-info loader closures. + LD / SNP-info loader closures. Each \code{weights} entry carries the + weights \code{wgt} and their variance \code{wgt_var} (w'Rw), from which + the pipeline computes \code{z_gene}, in place of ctwas's per-gene LD + matrix \code{R_wgt}. } \description{ The assembled cTWAS input list produced by diff --git a/man/ctwasPipeline.Rd b/man/ctwasPipeline.Rd index 30028ddf0..bca7b03b9 100644 --- a/man/ctwasPipeline.Rd +++ b/man/ctwasPipeline.Rd @@ -12,9 +12,9 @@ ctwasPipeline( method = NULL, maxNumSingleEffects = 5L, numThreads = 1L, - ctwasPriorArgs = CtwasPriorParam(), - variantPruningArgs = VariantPruningParam(), - boundaryMergeArgs = BoundaryMergeParam(), + ctwasPriorParam = CtwasPriorParam(), + variantPruningParam = VariantPruningParam(), + boundaryMergeParam = BoundaryMergeParam(), keepSnps = FALSE, methodArgs = CtwasOptions() ) @@ -65,19 +65,20 @@ fine-mapping. Default \code{5}. Pass-through to \item{numThreads}{Number of cores. Default \code{1}.} -\item{ctwasPriorArgs}{The EM stage that estimates cTWAS's group priors, built -with \code{\link{CtwasPriorParam}}: \code{thin}, \code{niterPrefit}, -\code{niter}, \code{varStructure} and \code{fallbackToPrefit}. Handed -whole to \code{\link{estCtwasGroupPriors}}.} +\item{ctwasPriorParam}{The EM stage that estimates cTWAS's group priors, +built with \code{\link{CtwasPriorParam}}: \code{thin}, +\code{niterPrefit}, \code{niter}, \code{varStructure} and +\code{fallbackToPrefit}. Handed whole to +\code{\link{estCtwasGroupPriors}}.} -\item{variantPruningArgs}{Which variants survive into each gene's weight +\item{variantPruningParam}{Which variants survive into each gene's weight matrix, built with \code{\link{VariantPruningParam}}: \code{weightCutoff}, \code{csMinCor}, \code{pipRescue} and \code{maxVariants}. Handed whole to \code{\link{assembleCtwasInputs}}. The \code{csMinCor} / \code{pipRescue} rescues need a \code{fineMappingResult}.} -\item{boundaryMergeArgs}{Whether a high-PIP gene straddling an LD-block +\item{boundaryMergeParam}{Whether a high-PIP gene straddling an LD-block boundary has its regions merged and re-fine-mapped, built with \code{\link{BoundaryMergeParam}}: \code{enabled} (default \code{FALSE}), \code{pipThreshold}, \code{filterCs} and @@ -112,7 +113,7 @@ A \code{\link{CtwasResult}} collection: one row per \code{(gwasStudy, \description{ Pipeline that hands a per-block set of \code{\link{GwasSumStats}} of GWAS Z-scores together with the matching - per-block per-gene TWAS weights and LD sketches to + per-block per-gene TWAS weights and LD references to \code{ctwas::ctwas_sumstats}, producing per-gene posterior inclusion probabilities for causal genes. Optionally accepts a precomputed TWAS-Z \code{GRanges} from \code{\link{causalInferencePipeline}} as the @@ -124,20 +125,32 @@ Pipeline that hands a per-block set of \code{blockId} column -- build it with \code{loadGwasSumStatsFromManifest(..., ldBlocks = )}. Per-block \code{region_info}, \code{LD_map}, and \code{snp_map} entries are built - automatically from the LD sketch and concatenated before the call to + automatically from the LD reference and concatenated before the call to \code{ctwas::ctwas_sumstats}. A single-block input is rejected: cTWAS's EM cannot converge on a single region, so callers must supply at least two blocks. } -\section{LD-sketch compatibility check}{ +\section{cTWAS's log}{ + cTWAS narrates each of its steps through the + \code{logging} package, which writes to the console with \code{cat()}, + out of reach of \code{suppressMessages()}. The pipeline keeps that + narration off the console, cTWAS's warnings excepted. To keep the full + log, give a step a log file through its options, e.g. + \code{CtwasEstParamOptions(logfile = "est_param.log")}. +} + +\section{LD reference compatibility check}{ Per block: - \code{ldSketch(twasWeights)} (when non-NULL) must come from the same - reference panel as \code{ldSketch(gwasSumStats)} --- same samples, same - allele orientation on the shared variants. The two need NOT carry the same - variants; a partial overlap, which is what QC-ing the two sides separately - produces, only warns. A different sample set, a swapped A1/A2 on a shared - variant, or no shared variant at all is a hard error. + \code{ldReference(twasWeights)} (when non-NULL) must be the same LD + reference as \code{ldReference(gwasSumStats)}. + The two must be the same kind of reference. Two genotype panels must + share their samples and allele orientation; two \code{LdMatrix} objects + must agree on the LD they share; two \code{GenotypeMixture} objects must + average the same panels with the same weights. The two need NOT carry the + same variants; a partial overlap, which is what QC-ing the two sides + separately produces, only warns. A mismatch of any of those, or no shared + variant at all, is a hard error. } \examples{ @@ -152,12 +165,13 @@ blocks <- GenomicRanges::GRanges("chr22", IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000)), blockId = c("chr22_1", "chr22_2")) gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", - ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) + ldReference = ldStem, region = "chr22:10000000-19000000", + ldBlocks = blocks) gwasByRegion <- summaryStatsQc(gss, panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) ctwasPipeline(gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample), - ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, + ctwasPriorParam = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, fallbackToPrefit = TRUE), methodArgs = CtwasOptions( regionData = CtwasRegionDataOptions(min_group_size = 1), diff --git a/man/cvResult.Rd b/man/cvResult.Rd index 56160fd68..97cc3c6eb 100644 --- a/man/cvResult.Rd +++ b/man/cvResult.Rd @@ -20,7 +20,7 @@ cvResult(x, ...) \S4method{cvResult}{TwasWeightsRow}(x) } \arguments{ -\item{x}{A \code{FineMappingRow} or \code{FineMappingResult}.} +\item{x}{A \code{FineMappingRow} or \code{QtlFineMappingResult}.} \item{...}{Class-specific selection arguments.} @@ -42,12 +42,12 @@ A list (the CV payload) or \code{NULL}. \description{ Extract the cross-validation payload stored on a \code{FineMappingRow} (or the matching entry of a - \code{FineMappingResult}). The payload is a list with components + \code{QtlFineMappingResult}). The payload is a list with components \code{samplePartition} (a \code{data.frame} of \code{Sample}/\code{Fold} assignments), \code{predictions} (a named list of per-method out-of-fold prediction matrices), and \code{performance} (a named list of per-method metric matrices). \code{NULL} when fine-mapping was run without - cross-validation (\code{cvFolds <= 1}). + cross-validation. } \examples{ data(qtlFineMappingExample) diff --git a/man/dentist.Rd b/man/dentist.Rd index 77d74942b..75cbb2546 100644 --- a/man/dentist.Rd +++ b/man/dentist.Rd @@ -13,7 +13,7 @@ dentist( windowMode = c("distance", "count"), minDim = 2000, ldMethod = "sample", - methodArgs = DentistParam() + dentistParam = DentistParam() ) } \arguments{ @@ -22,8 +22,10 @@ dentist( \item{R}{Square LD correlation matrix. Provide either \code{R} or \code{X}.} -\item{X}{Genotype matrix (samples x SNPs). If provided, LD is computed via -\code{computeLd(X)} and \code{nSample} defaults to \code{nrow(X)}.} +\item{X}{Genotype matrix (samples x SNPs). With \code{ldMethod = "sample"} +DENTIST works on the standardized genotypes and never forms the LD +matrix; any other \code{ldMethod} computes LD via \code{computeLd(X)}. +\code{nSample} defaults to \code{nrow(X)}.} \item{nSample}{The number of samples in the LD reference panel (NOT the GWAS sample size). This controls the SVD truncation rank K = min(idx_size, @@ -44,11 +46,11 @@ windows by variant count using \code{segmentByCount} (C++ \code{--wind}).} size).} \item{ldMethod}{Character string specifying the LD computation method when -\code{X} is provided. Passed to \code{computeLd}. One of \code{"sample"} -(default), \code{"population"}, or \code{"gcta"}. Ignored when \code{R} is -provided directly.} +\code{X} is provided: \code{"sample"} (default), which uses the +genotypes directly, or \code{"population"} or \code{"gcta"}, which go +through \code{computeLd}. Ignored when \code{R} is provided directly.} -\item{methodArgs}{The DENTIST algorithm settings, built with +\item{dentistParam}{The DENTIST algorithm settings, built with \code{\link{DentistParam}}: \code{pValueThreshold}, \code{propSVD}, \code{gcControl}, \code{nIter}, \code{gPvalueThreshold}, \code{duprThreshold}, \code{numThreads}, \code{correctChenEtAlBug} diff --git a/man/dentistSingleWindow.Rd b/man/dentistSingleWindow.Rd index 55a80f9e0..025f24006 100644 --- a/man/dentistSingleWindow.Rd +++ b/man/dentistSingleWindow.Rd @@ -26,8 +26,10 @@ dentistSingleWindow( \item{R}{Square LD correlation matrix. Provide either \code{R} or \code{X}.} -\item{X}{Genotype matrix (samples x SNPs). If provided, LD is computed via -\code{computeLd(X)} and \code{nSample} defaults to \code{nrow(X)}.} +\item{X}{Genotype matrix (samples x SNPs). With \code{ldMethod = "sample"} +DENTIST works on the standardized genotypes and never forms the LD +matrix; any other \code{ldMethod} computes LD via \code{computeLd(X)}. +\code{nSample} defaults to \code{nrow(X)}.} \item{nSample}{Number of samples in the LD reference panel (NOT the GWAS sample size). Controls the SVD truncation rank. Required when \code{R} is @@ -52,9 +54,9 @@ provided; inferred from \code{X} when \code{X} is provided.} is TRUE.} \item{ldMethod}{Character string specifying the LD computation method when -\code{X} is provided. Passed to \code{computeLd}. One of \code{"sample"} -(default), \code{"population"}, or \code{"gcta"}. Ignored when \code{R} is -provided directly.} +\code{X} is provided: \code{"sample"} (default), which uses the +genotypes directly, or \code{"population"} or \code{"gcta"}, which go +through \code{computeLd}. Ignored when \code{R} is provided directly.} \item{seed}{Integer or \code{NULL}. Random seed for the iterative variant-partitioning RNG. \code{NULL} (default) preserves the original diff --git a/man/dot-annotDetectFormat.Rd b/man/dot-annotDetectFormat.Rd index e6d80ffad..386b312ed 100644 --- a/man/dot-annotDetectFormat.Rd +++ b/man/dot-annotDetectFormat.Rd @@ -14,7 +14,8 @@ Character, one of "bigwig", "ldsc_annot", or "bed". } \description{ Detect annotation file format from extension. This is separate - from \code{.h2DetectFormat} because BED annotation files (genomic intervals - for rtracklayer) must be distinguished from plink BED files. + from the genotype format detection (\code{.genotypePathFormat}) because + BED annotation files (genomic intervals for rtracklayer) must be + distinguished from plink BED files. } \keyword{internal} diff --git a/man/dot-penalizedRssWeights.Rd b/man/dot-penalizedRssWeights.Rd index e892039cf..44d167534 100644 --- a/man/dot-penalizedRssWeights.Rd +++ b/man/dot-penalizedRssWeights.Rd @@ -6,7 +6,7 @@ \usage{ .penalizedRssWeights( stat, - LD, + ldReference, penalty, s = c(0.2, 0.5, 0.9, 1), gamma = NULL, @@ -14,18 +14,22 @@ lambda0 = 0, lambda2 = 0, selection = c("ldQuadratic", "minFbeta"), + fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) } \arguments{ -\item{stat, LD, s, selection, penalty, gamma, alpha, lambda0, lambda2}{See the -public wrappers for details.} +\item{stat, ldReference, s, selection, penalty, gamma, alpha, lambda0, lambda2}{See +the public wrappers for details.} + +\item{fitRetention}{How much of the search is kept as the \code{"fit"} +attribute; see \code{\link{scadRssWeights}}.} \item{methodArgs}{Options forwarded to \code{penalizedRss}, built with \code{\link{PenalizedRssOptions}}.} } \value{ -Numeric weight vector of length \code{nrow(LD)}. +Numeric weight vector, one weight per variant of \code{stat}. } \description{ Shared implementation for \code{scadRssWeights()} and \code{mcpRssWeights()}. diff --git a/man/dot-plinkStem.Rd b/man/dot-plinkStem.Rd deleted file mode 100644 index 41ff78115..000000000 --- a/man/dot-plinkStem.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/genotypeIo.R -\name{.plinkStem} -\alias{.plinkStem} -\title{Detect Plink File Stem} -\usage{ -.plinkStem(path) -} -\arguments{ -\item{path}{Character, path to any plink file.} -} -\value{ -Character, file stem without extension. -} -\description{ -Given any plink file path, return the stem. -} -\keyword{internal} diff --git a/man/dprWeights.Rd b/man/dprWeights.Rd index 534ed90ea..fea7ed866 100644 --- a/man/dprWeights.Rd +++ b/man/dprWeights.Rd @@ -50,8 +50,7 @@ dprAdaptiveGibbsWeights( attribute of the returned weights: \code{"none"} (default) attaches nothing, \code{"slim"} and \code{"full"} attach the fitted model. This engine keeps no trimmable intermediates, so the two retaining levels -behave alike here. -Default \code{FALSE}.} +behave alike here.} \item{methodArgs}{Options forwarded to \code{RcppDPR::fit_model}, built with \code{\link{DprOptions}}. A bare list is refused: it cannot be diff --git a/man/eigenList.Rd b/man/eigenList.Rd index 26191ca8b..f15eec7d8 100644 --- a/man/eigenList.Rd +++ b/man/eigenList.Rd @@ -13,11 +13,17 @@ eigenList(x) \item{x}{An \code{LdEigen}.} } \value{ -List of per-block eigen decompositions. +A list with one element per block, each a list with + \code{values}, \code{vectors} and \code{snpIdx}. One computed from a + panel also carries \code{nNull}: the number of the block's directions + whose eigenvalue is exactly zero, which it does not list. } \description{ -Return the per-block eigendecomposition list carried by an - \code{LdEigen} object. +Return the per-block eigendecompositions of an + \code{LdEigen}: the stored ones, or, for one built from a genotype + panel (which stores none), every block's computed from the panel now. + That holds all of them in memory at once, which the estimators avoid by + decomposing one block at a time. } \examples{ data(ldEigenExample) diff --git a/man/estCtwasGroupPriors.Rd b/man/estCtwasGroupPriors.Rd index afa2c4efb..23b8793c2 100644 --- a/man/estCtwasGroupPriors.Rd +++ b/man/estCtwasGroupPriors.Rd @@ -6,7 +6,7 @@ \usage{ estCtwasGroupPriors( inputs, - ctwasPriorArgs = CtwasPriorParam(), + ctwasPriorParam = CtwasPriorParam(), numThreads = 1L, methodArgs = CtwasOptions() ) @@ -14,7 +14,7 @@ estCtwasGroupPriors( \arguments{ \item{inputs}{A list returned by \code{\link{assembleCtwasInputs}}.} -\item{ctwasPriorArgs}{The EM settings, built with +\item{ctwasPriorParam}{The EM settings, built with \code{\link{CtwasPriorParam}}: \code{thin} (SNP thinning when assembling region data), \code{niterPrefit} and \code{niter} (prefit / accurate EM iterations), \code{varStructure}, and @@ -42,7 +42,7 @@ Step 2 of the three-step \code{\link{ctwasPipeline}}: assembles \examples{ data(ctwasInputsExample) estCtwasGroupPriors(ctwasInputsExample, - ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, + ctwasPriorParam = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, fallbackToPrefit = TRUE), methodArgs = CtwasOptions( regionData = CtwasRegionDataOptions(min_group_size = 1), diff --git a/man/estimateH2.Rd b/man/estimateH2.Rd index 21376b5f7..1a164b51e 100644 --- a/man/estimateH2.Rd +++ b/man/estimateH2.Rd @@ -87,6 +87,6 @@ panel <- readGenotypes( ) ss <- GwasSumStats(studyName = "trait1", entry = list(gr), genome = unique(unname(GenomeInfoDb::genome(ldScoreExample))), - ldSketch = panel) + ldReference = panel) estimateH2(ss, ldScoreExample, method = "sldsc") } diff --git a/man/exportToBed.Rd b/man/exportToBed.Rd index 37acdf76f..4f93980c8 100644 --- a/man/exportToBed.Rd +++ b/man/exportToBed.Rd @@ -32,8 +32,8 @@ exportToBed(x, outputPath, ...) ) } \arguments{ -\item{x}{A \code{FineMappingResult} or \code{TwasWeights} object, or a -\code{list} of either, to combine first.} +\item{x}{A \code{QtlFineMappingResult}, \code{GwasFineMappingResult} or +\code{TwasWeights} object, or a \code{list} of them, to combine first.} \item{outputPath}{Output path. A \code{.gz} / \code{.bgz} extension selects bgzip + tabix (via Rsamtools, so no htslib binary is needed); any other @@ -41,14 +41,14 @@ extension writes a plain table.} \item{...}{Additional arguments passed to methods.} -\item{schema}{\code{FineMappingResult} only: which published schema to +\item{schema}{Fine-mapping results only: which published schema to write, \code{"topLoci"} (default) or \code{"fsusie"}.} \item{signalCutoff}{PIP cutoff passed to \code{\link{topLoci}} -(\code{FineMappingResult}, \code{"topLoci"} schema only). Default 0.025.} +(fine-mapping results, \code{"topLoci"} schema only). Default 0.025.} \item{minPurity}{Optional credible-set purity cutoff passed to -\code{\link{topLoci}} (\code{FineMappingResult}, \code{"topLoci"} schema +\code{\link{topLoci}} (fine-mapping results, \code{"topLoci"} schema only). Default \code{NULL} for no purity filter.} \item{coverage}{Which credible-set coverage levels to publish, as @@ -99,7 +99,7 @@ observation. } \details{ A \code{TwasWeights} writes one table, a row per (variant, weight column). -A \code{FineMappingResult} offers two, selected with \code{schema}: +A fine-mapping result offers two, selected with \code{schema}: \describe{ \item{\code{"topLoci"}}{(default) the posterior view joined to the marginal one, a row per (variant, context).} diff --git a/man/exportToVcf.Rd b/man/exportToVcf.Rd index 437eb79b2..112b90bc0 100644 --- a/man/exportToVcf.Rd +++ b/man/exportToVcf.Rd @@ -37,9 +37,10 @@ exportToVcf(x, outputPath, sampleName = NULL, ...) ) } \arguments{ -\item{x}{A \code{GwasSumStats}, \code{FineMappingResult} or -\code{TwasWeights} object, or a \code{list} of \code{FineMappingResult} -/ \code{TwasWeights} objects to combine first.} +\item{x}{A \code{GwasSumStats}, \code{QtlFineMappingResult}, +\code{GwasFineMappingResult} or \code{TwasWeights} object, or a +\code{list} of fine-mapping results or of \code{TwasWeights} objects to +combine first.} \item{outputPath}{File path for output. Extension determines format: \code{.vcf.gz} or \code{.vcf.bgz} for bgzipped VCF, \code{.bcf} for BCF, @@ -84,7 +85,7 @@ Which FORMAT fields are written depends on the input: \describe{ \item{\code{GwasSumStats}}{\code{ES} / \code{SS} / \code{AF} for one study.} - \item{\code{FineMappingResult}}{the marginal fields (\code{ES}, + \item{a fine-mapping result}{the marginal fields (\code{ES}, \code{SE}, \code{LP}, \code{SS}, \code{AF}) plus the posterior ones (\code{PIP}, \code{LBF}, \code{LFSR}, and a \code{CS}/\code{PUR} pair per credible-set coverage present).} diff --git a/man/extractCsInfo.Rd b/man/extractCsInfo.Rd index c2ee5778b..b60d67e68 100644 --- a/man/extractCsInfo.Rd +++ b/man/extractCsInfo.Rd @@ -37,8 +37,8 @@ A data frame with one row per CS, containing the following columns: CS (its row of the between-CS matrix, self-correlation on the diagonal), computed on demand from \code{ldSource}. Absent when there are fewer than two credible sets.} - \item{cs_corr_max}{Maximum absolute between-CS correlation (excluding the - self == 1); \code{NA} for a single CS.} + \item{cs_corr_max}{Maximum absolute correlation with the other credible + sets; \code{NA} for a single CS.} \item{cs_corr_min}{Minimum absolute between-CS correlation; \code{NA} for a single CS.} } diff --git a/man/fineMappingPipeline.Rd b/man/fineMappingPipeline.Rd index 02d29fbf5..672fceee5 100644 --- a/man/fineMappingPipeline.Rd +++ b/man/fineMappingPipeline.Rd @@ -23,9 +23,9 @@ fineMappingPipeline(data, ...) initializeWithSusieInf = TRUE, credibleSetParam = CredibleSetParam(), fineMappingResult = NULL, - crossValidationArgs = CrossValidationParam(), - residualizationArgs = ResidualizationParam(), - signalScreenArgs = SignalScreenParam(), + crossValidationParam = CrossValidationParam(), + residualizationParam = ResidualizationParam(), + signalScreenParam = SignalScreenParam(), usePCA = FALSE, nPCs = 10L, seed = NULL, @@ -53,9 +53,9 @@ fineMappingPipeline(data, ...) fineMappingResult = NULL, mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, - crossValidationArgs = CrossValidationParam(), - residualizationArgs = ResidualizationParam(), - signalScreenArgs = SignalScreenParam(), + crossValidationParam = CrossValidationParam(), + residualizationParam = ResidualizationParam(), + signalScreenParam = SignalScreenParam(), susieRssParam = SusieRssParam(), usePCA = FALSE, nPCs = 10L, @@ -81,8 +81,8 @@ fineMappingPipeline(data, ...) fitRetention = c("slim", "full"), susieRssParam = SusieRssParam(), panelFilterParam = PanelFilterParam(), - crossValidationArgs = CrossValidationParam(), - residualizationArgs = ResidualizationParam(), + crossValidationParam = CrossValidationParam(), + residualizationParam = ResidualizationParam(), dataType = NULL ) @@ -96,8 +96,8 @@ fineMappingPipeline(data, ...) fitRetention = c("slim", "full"), susieRssParam = SusieRssParam(), panelFilterParam = PanelFilterParam(), - crossValidationArgs = CrossValidationParam(), - residualizationArgs = ResidualizationParam(), + crossValidationParam = CrossValidationParam(), + residualizationParam = ResidualizationParam(), dataType = NULL ) } @@ -126,11 +126,22 @@ fineMappingPipeline(data, ...) even when fitting from a susieInf chain). }} -\item{contexts}{Optional character vector of context names. Default -\code{NULL} (all contexts).} - -\item{traitId}{Optional character vector of trait names to restrict -processing to.} +\item{contexts}{Optional context selection; \code{NULL} (the default) uses +every context. A character vector applies to every study: a context no +study has is an error, and one only some studies lack is skipped for +those, with a warning. A list keyed by study name picks each study's +contexts separately (\code{list(A = "liver")}); studies it does not name +keep all of theirs.} + +\item{traitId}{Optional trait selection; \code{NULL} (the default) uses +every trait, or those overlapping \code{region} when one is given. A +character vector applies to every study. A list keyed by study name +picks each study's traits separately (\code{list(A = "ENSG1")}), and a +study's entry may itself be a list keyed by context +(\code{list(A = list(brain = "ENSG1"))}). Studies and contexts the list +does not name keep all of their traits. A joint fit spanning a study's +contexts uses every trait selected in any of them, minus the (context, +trait) pairs a per-context entry leaves out.} \item{region}{Optional variant window for QtlDataset trait selection: a \code{GRanges}, a \code{"chr:start-end"} string, or a one-row data.frame @@ -156,15 +167,20 @@ labels are renumbered to stay unique. \code{TRUE} concatenates the ranges' genotypes into one joint fit. Ignored for a single-range / cis (\code{traitId} + \code{cisWindow}) request.} -\item{jointSpecification}{Optional joint-fit specification (NULL by default). -When NULL, the pipeline runs the implicit multi-context / multi-trait -mvSuSiE / fSuSiE branches as before. When non-NULL, the argument is parsed -and validated via the joint-spec grammar documented under -\code{parseJointSpecification} (a character vector of axes, or a list of -\code{list(axes, scope)} specs); the per-spec axis dispatcher -implementation is in progress and a non-NULL value currently errors with an -informative message. See the design notes in \code{R/jointSpecification.R} -for the accepted grammar.} +\item{jointSpecification}{Optional joint-fit specification saying which +axes \code{mvsusie} / \code{fsusie} fit across. When NULL (the default) +they fit across traits if the input has two or more, else across +contexts. Otherwise give a character vector of axes (one spec) or a list +of specs. A spec is a character vector drawn from \code{"study"}, +\code{"context"} and \code{"trait"}, or +\code{list(axes = , scope = )}, where \code{scope} +(keys \code{study}, \code{context}, \code{trait}) limits the fit to the +listed values, each of which must exist in \code{data}. A list-form +spec always goes inside the outer list, even on its own. Other methods +run per (study, context, trait) as usual. The \code{"study"} axis needs +summary statistics: it is rejected on a \code{QtlDataset}, and on a +\code{MultiStudyQtlDataset} only the summary-statistics studies take +part.} \item{initializeWithSusieInf}{Logical. When \code{susieInf} is in \code{methods} alongside \code{susie} and/or \code{susieAsh}, whether the @@ -191,16 +207,23 @@ credible sets, which is why it stands alone.} onto each SuSiE-family token's own arguments, so changing them needs a refit.} -\item{fineMappingResult}{Optional existing \code{FineMappingResult} to use as -a resume cache; tuples already present are not refit.} +\item{fineMappingResult}{Optional existing \code{QtlFineMappingResult} or +\code{GwasFineMappingResult} to use as a resume cache; tuples already +present are not refit.} -\item{crossValidationArgs}{Cross-validation settings, built with +\item{crossValidationParam}{Cross-validation settings, built with \code{\link{CrossValidationParam}}: \code{folds} (default \code{0}, no CV), \code{numThreads} for the per-fold refits, and \code{samplePartition} to reuse a fixed partition across methods. When \code{folds > 1} each method is refit on every fold's training samples and used to predict the held-out ones; the partition, the out-of-fold predictions and the metrics are stored on each \code{FineMappingRow}'s \code{cvResult} slot. + \code{fitFullData = FALSE} keeps only that: each row carries its + \code{cvResult} and no full-data fit, variants or top loci. A + \code{fineMappingResult} resume cache is only reused where it carries + what the run asks for -- a full-data fit unless the run is + cross-validation-only, and a \code{cvResult} when the run + cross-validates -- and the other tuples are refit. Cross-validation holds out \strong{samples}, so it is not possible on \code{QtlSumStats} / \code{GwasSumStats} input. Those methods accept @@ -210,7 +233,7 @@ a resume cache; tuples already present are not refit.} \code{maxVariants} and \code{weightMethods} are honoured by \code{\link{twasWeightsPipeline}} only and are ignored here.} -\item{residualizationArgs}{Covariate residualization settings, built with +\item{residualizationParam}{Covariate residualization settings, built with \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and \code{genotypeCovariates} name which covariates to regress out (\code{NULL}, the default, uses every available one), and @@ -220,7 +243,8 @@ a resume cache; tuples already present are not refit.} Only meaningful for \code{QtlDataset} / \code{MultiStudyQtlDataset} input. A \code{QtlSumStats} / \code{GwasSumStats} run has no covariates to regress out, so the bundle is \strong{ignored} there rather than - refused --- unlike \code{crossValidation}, which errors. Residualization + refused --- unlike \code{crossValidationParam}, which errors. + Residualization is on by default, so refusing a non-default value would reject the default bundle; CV is off by default, so a non-default value there is an explicit request for something the input cannot do. @@ -229,7 +253,7 @@ a resume cache; tuples already present are not refit.} obey the same choice as the SuSiE fit itself --- they are computed against the same residualized \code{X} / \code{Y}.} -\item{signalScreenArgs}{Individual-level single-effect (SER) pre-screen +\item{signalScreenParam}{Individual-level single-effect (SER) pre-screen applied to each residualized \code{(X, y)} block before a full fit, built with \code{\link{SignalScreenParam}}. A susie model with \code{L = 1} is fit and the block is skipped unless the chosen metric @@ -247,17 +271,19 @@ Only one metric may be enabled, which default) screens nothing. The summary-statistics analog lives in \code{\link{summaryStatsQc}}.} -\item{usePCA}{Logical (length 1). \code{QtlDataset} only. When \code{TRUE} +\item{usePCA}{Logical (length 1). Individual-level data only: a +\code{QtlDataset}, or the \code{QtlDataset} components of a +\code{MultiStudyQtlDataset}. When \code{TRUE} (default \code{FALSE}), each multi-trait context's PCA-reduced phenotype is fine-mapped with univariate SuSiE on its top principal components (ports the legacy \code{fsusie.R} \code{susie_on_top_pc}). Each PC becomes a pseudo-trait row keyed \code{trait = "topPC\{i\}"}, \code{method = "susie"}. Single-trait contexts have no PCA and are skipped.} -\item{nPCs}{Integer (length 1). \code{QtlDataset} only. Caps the number of -top principal components fine-mapped per context when \code{usePCA = TRUE} -(default \code{10}). The effective count is \code{min(nPCs, usable -traits)}.} +\item{nPCs}{Integer (length 1). Individual-level data only. Caps the +number of top principal components fine-mapped per context when +\code{usePCA = TRUE} (default \code{10}). The effective count is +\code{min(nPCs, usable traits)}.} \item{seed}{Optional integer. When non-NULL, \code{withr::local_seed(seed)} is called at the start of the call for @@ -287,7 +313,7 @@ non-default-coverage \code{credibleSets()} queries can read the full posterior matrices. The per-variant \code{topLoci} table is fully populated either way --- its per-credible-set columns are governed by -\code{credibleSet}'s \code{perCsColumns}, not by this.} +\code{credibleSetParam}'s \code{perCsColumns}, not by this.} \item{dataType}{Optional assay / modality label for the phenotype the fit was run on (\code{"bulk_rnaseq"}, \code{"methylation"}), recorded as a @@ -318,7 +344,7 @@ and GWAS methods, built with \code{\link{PanelFilterParam}}. See \code{R_finite} correction. \code{NULL} (default) uses susieR's own, except when a finite/EB mode is active (\code{serFallback} or \code{rMismatch != "none"}), where it falls back to the LD panel's - \code{nSamples(ldSketch)}. + \code{nSamples(ldReference)}. \item \code{rMismatch} (default \code{"none"}) --- LD-mismatch correction forwarded as \code{R_mismatch}: also \code{"eb"} or \code{"eb_mix"}. @@ -330,10 +356,12 @@ and GWAS methods, built with \code{\link{PanelFilterParam}}. See }} } \value{ -A \code{FineMappingResult} collection keyed by \code{(study, context, - trait, method)}. The \code{ldSketch} slot is set automatically: \code{NULL} +A \code{QtlFineMappingResult} keyed by \code{(study, context, + trait, method)} -- for \code{GwasSumStats} input, a + \code{GwasFineMappingResult} keyed by \code{(study, method)} and range. + The \code{ldReference} slot is set automatically: \code{NULL} for individual-level (QtlDataset / all-individual-level - MultiStudyQtlDataset) fits, the input's \code{ldSketch} for RSS-derived + MultiStudyQtlDataset) fits, the input's \code{ldReference} for RSS-derived fits. } \description{ @@ -404,7 +432,7 @@ S4-dispatched per-region fine-mapping entry point that All \code{QtlSumStats} and \code{GwasSumStats} inputs must have been QC'd via \code{\link{summaryStatsQc}}; the pipeline errors on inputs where \code{length(qcInfo(x)) == 0L}. \code{summaryStatsQc} - also drops variants absent from the \code{ldSketch}, so by the time + also drops variants absent from the \code{ldReference}, so by the time per-entry processing runs every variant is guaranteed to be present in the LD panel and a local LD matrix can be built with \code{extractBlockGenotypes} + \code{computeLd("sample")}. @@ -412,7 +440,7 @@ S4-dispatched per-region fine-mapping entry point that \section{Optional resume cache}{ Supplying \code{fineMappingResult} of an - existing \code{FineMappingResult} skips re-fitting any \code{(study, + existing fine-mapping result skips re-fitting any \code{(study, context, trait, method)} tuple that already has a matching row; cached entries are merged with the newly-fit entries in the returned collection. } @@ -426,8 +454,8 @@ deliberately not ported here: \itemize{ \item TWAS weights computation (\code{twasWeights = TRUE} path): lives in \code{\link{twasWeightsPipeline}} now. - \item Filtering knobs (now \code{genotypeFilter} / - \code{panelFilter}, \code{ldReferenceMetaFile}): individual- + \item Filtering knobs (now \code{genotypeFilterParam} / + \code{panelFilterParam}, \code{ldReferenceMetaFile}): individual- level QC lives on the \code{QtlDataset} constructor; sumstat QC lives in \code{summaryStatsQc()}. No filtering happens inside this pipeline. @@ -441,10 +469,10 @@ deliberately not ported here: \item \code{loadRssData} and explicit \code{ldReferenceMetaFile} arguments: the new \code{QtlSumStats} / \code{GwasSumStats} carry the - (already-QC'd) sumstats and \code{ldSketch} directly. + (already-QC'd) sumstats and \code{ldReference} directly. \item Verbose \code{methodName} suffixing (e.g. \code{"susie_rss_NO_QC"}, \code{"susie_rss_SLALOM_RAISS_imputed"}): - the method column on the returned \code{FineMappingResult} + the method column on the returned collection carries the bare token (\code{"susie"}, \code{"susieInf"}, \code{"mvsusie"}, ...) only. QC provenance is recorded on the sumstats' \code{qcInfo}. @@ -459,17 +487,17 @@ deliberately not ported here: \section{Panel filters on the RSS path}{ On \code{QtlSumStats} / \code{GwasSumStats} input there is no genotype matrix to filter, so - \code{panelFilter}'s \code{mafCutoff} / \code{macCutoff} / + \code{panelFilterParam}'s \code{mafCutoff} / \code{macCutoff} / \code{imissCutoff} are measured against the \strong{LD reference panel} instead: a variant whose panel genotypes fall below the cutoffs is dropped before the z-scores and LD matrix are built. The thresholds mean - the same thing as \code{genotypeFilter}'s on the \code{QtlDataset} path - (MAC is converted to a MAF equivalent and the stricter of the two + the same thing as \code{genotypeFilterParam}'s on the \code{QtlDataset} + path (MAC is converted to a MAF equivalent and the stricter of the two applies), so one number carries across input types. The defaults filter nothing. This discards \emph{observed} variants, unlike - \code{summaryStatsQc(imputeArgs = ...)}, which only bounds which variants + \code{summaryStatsQc(raissParam = ...)}, which only bounds which variants RAISS will impute. Use it when the panel cannot support the LD estimate a rare variant would need. } diff --git a/man/fineMappingResult.Rd b/man/fineMappingResult.Rd index afd7d1e94..dfd8b1b0b 100644 --- a/man/fineMappingResult.Rd +++ b/man/fineMappingResult.Rd @@ -32,18 +32,19 @@ fineMappingResult( ) } \arguments{ -\item{x}{A \code{FineMappingResult} object.} +\item{x}{A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}.} \item{studyName, context, trait, method}{Single character identifiers. All required when the collection has more than one row; optional when the collection has a single row.} } \value{ -A \code{FineMappingRow} object. +A single-row collection of the same class as \code{x}. } \description{ -Return the \code{FineMappingRow} for one \code{(study, - context, trait, method)} row of a \code{FineMappingResult} collection. +Return one row of a \code{QtlFineMappingResult} or + \code{GwasFineMappingResult}, selected by its identity, as a single-row + collection of the same class. } \examples{ data(qtlFineMappingExample) diff --git a/man/finemapCtwasRegions.Rd b/man/finemapCtwasRegions.Rd index 1dcefd709..d5009fdb6 100644 --- a/man/finemapCtwasRegions.Rd +++ b/man/finemapCtwasRegions.Rd @@ -47,13 +47,14 @@ blocks <- GenomicRanges::GRanges("chr22", IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000)), blockId = c("chr22_1", "chr22_2")) gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", - ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) + ldReference = ldStem, region = "chr22:10000000-19000000", + ldBlocks = blocks) gwasByRegion <- summaryStatsQc(gss, panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) inp <- assembleCtwasInputs(gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample)) est <- estCtwasGroupPriors(inp, - ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, + ctwasPriorParam = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, fallbackToPrefit = TRUE), methodArgs = CtwasOptions( regionData = CtwasRegionDataOptions(min_group_size = 1), diff --git a/man/formatFinemappingOutput.Rd b/man/formatFinemappingOutput.Rd index 4e2803225..0b095d962 100644 --- a/man/formatFinemappingOutput.Rd +++ b/man/formatFinemappingOutput.Rd @@ -19,7 +19,7 @@ A list with root-level fields including \code{finemappingEntry} (a Promotes the primary method's per-method post-processing payload to the root level and attaches the unified \code{top_loci} table. The primary method's bare \code{FineMappingRow} appears at \code{$finemappingEntry}; wrap it -into a \code{FineMappingResult} collection at the pipeline level once (study, +into a fine-mapping result collection at the pipeline level once (study, context, trait, method) identity tags are known. } \examples{ diff --git a/man/fsusieAffectedRegions.Rd b/man/fsusieAffectedRegions.Rd index a46ab2ba1..1d3951ab9 100644 --- a/man/fsusieAffectedRegions.Rd +++ b/man/fsusieAffectedRegions.Rd @@ -10,7 +10,7 @@ fsusieAffectedRegions(x, ...) \S4method{fsusieAffectedRegions}{FineMappingResultBase}(x) } \arguments{ -\item{x}{A \code{FineMappingRow} or \code{FineMappingResultBase}.} +\item{x}{A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}.} \item{...}{Ignored.} } diff --git a/man/fsusieCredibleBand.Rd b/man/fsusieCredibleBand.Rd index a1e29d90a..dc80ec4a3 100644 --- a/man/fsusieCredibleBand.Rd +++ b/man/fsusieCredibleBand.Rd @@ -10,7 +10,7 @@ fsusieCredibleBand(x, ...) \S4method{fsusieCredibleBand}{FineMappingResultBase}(x) } \arguments{ -\item{x}{A \code{FineMappingRow} or \code{FineMappingResultBase}.} +\item{x}{A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}.} \item{...}{Ignored.} } diff --git a/man/fsusieTraitEffects.Rd b/man/fsusieTraitEffects.Rd index c3fe3ac36..b3863652b 100644 --- a/man/fsusieTraitEffects.Rd +++ b/man/fsusieTraitEffects.Rd @@ -10,7 +10,7 @@ fsusieTraitEffects(x, ...) \S4method{fsusieTraitEffects}{FineMappingResultBase}(x) } \arguments{ -\item{x}{A \code{FineMappingRow} or \code{FineMappingResultBase}.} +\item{x}{A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}.} \item{...}{Ignored.} } diff --git a/man/genomicRegion.Rd b/man/genomicRegion.Rd index 4d7303068..80f8341fa 100644 --- a/man/genomicRegion.Rd +++ b/man/genomicRegion.Rd @@ -24,7 +24,7 @@ A \code{GRanges} with one range per row of \code{x}, or an empty \description{ Return the genomic interval each row was analysed over, as a \code{GRanges} with one range per row -- the trait's own region for a - \code{TwasWeights}, and for a \code{FineMappingResult} the window the fit + \code{TwasWeights}, and for a fine-mapping result the window the fit was run over (the requested region, or the trait's cis-window when the fit was driven by \code{traitId} + \code{cisWindow}). This is location provenance (e.g. for cTWAS LD-block placement). diff --git a/man/genotypeFormat.Rd b/man/genotypeFormat.Rd index 30fee7aa0..3d80e2884 100644 --- a/man/genotypeFormat.Rd +++ b/man/genotypeFormat.Rd @@ -13,7 +13,7 @@ genotypeFormat(x) \item{x}{A \code{GenotypeHandle}.} } \value{ -Character (length 1): one of "gds", "vcf", "plink1", "plink2". +Character (length 1): one of "plink1", "plink2", "bgen". } \description{ Return the detected genotype storage format. diff --git a/man/genotypeHandle.Rd b/man/genotypeHandle.Rd index 8b1ea8b11..2faf3684e 100644 --- a/man/genotypeHandle.Rd +++ b/man/genotypeHandle.Rd @@ -1,28 +1,25 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/LdData.R, R/QtlDataset.R +% Please edit documentation in R/AllGenerics.R, R/QtlDataset.R \name{genotypeHandle} \alias{genotypeHandle} -\alias{genotypeHandle,LdData-method} \alias{genotypeHandle,QtlDataset-method} -\title{Get GenotypeHandle from LdData} +\title{Get GenotypeHandle} \usage{ genotypeHandle(x) -\S4method{genotypeHandle}{LdData}(x) - \S4method{genotypeHandle}{QtlDataset}(x) } \arguments{ -\item{x}{An \code{LdData}.} +\item{x}{A \code{QtlDataset}.} } \value{ -A \code{GenotypeHandle}, a list of them, or NULL. For a - \code{QtlDataset} this is the handle itself; \code{genotypes()} - extracts a dosage block from it instead. +A \code{GenotypeHandle}, or NULL for genotypes read through no + handle (a VCF, GDS or PLINK1 file, or held in memory); + \code{genotypes()} extracts a dosage block instead. } \description{ -Return the \code{GenotypeHandle} (or list of handles for mixture - panels) carried by an \code{LdData}. +Return the \code{GenotypeHandle} behind a \code{QtlDataset}'s + genotype experiment. } \details{ The genotype handle is the seed layer behind a panel and diff --git a/man/genotypes.Rd b/man/genotypes.Rd index 0d7b37875..42377daf2 100644 --- a/man/genotypes.Rd +++ b/man/genotypes.Rd @@ -1,15 +1,12 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/LdData.R, R/QtlDataset.R +% Please edit documentation in R/AllGenerics.R, R/QtlDataset.R \name{genotypes} \alias{genotypes} -\alias{genotypes,LdData-method} \alias{genotypes,QtlDataset-method} \title{Get Genotype Matrix} \usage{ genotypes(x, ...) -\S4method{genotypes}{LdData}(x) - \S4method{genotypes}{QtlDataset}(x, traitId = NULL, region = NULL, cisWindow = NULL, samples = NULL) } \arguments{ @@ -36,10 +33,9 @@ A numeric matrix, a list of matrices, or \code{NULL}. } \description{ Extract a genotype matrix from an object that carries genotype - data. For an \code{LdData}, returns the underlying genotype matrix via its - handle (or \code{NULL} if no handle is available). For a \code{QtlDataset}, - returns the genotype matrix for a selected set of traits or region (see - method documentation for the per-class selection arguments). + data. For a \code{QtlDataset}, returns the genotype matrix for a selected + set of traits or region (see method documentation for the per-class + selection arguments). } \examples{ data(qtlDatasetExample) diff --git a/man/gwasFineMappingExample.Rd b/man/gwasFineMappingExample.Rd index 239eed4b1..b08bf4ab0 100644 --- a/man/gwasFineMappingExample.Rd +++ b/man/gwasFineMappingExample.Rd @@ -10,8 +10,8 @@ A \code{\link{GwasFineMappingResult}} object: a chr22) keyed by \code{study_1} / \code{susie}, carrying the SuSiE-RSS fit and a per-variant table with the standard post-processing columns (\code{pip}, \code{logBF}, \code{cs_95} / \code{cs_70} / \code{cs_50} and -their purities, marginal statistics). Four credible sets. \code{ldSketch} is -the bundled \code{toy_canonical} genotype panel, present +their purities, marginal statistics). Four credible sets. \code{ldReference} +is the bundled \code{toy_canonical} genotype panel, present because \code{\link{qtlEnrichmentPipeline}} requires the GWAS collection to carry one as its RSS-derived marker; the LD actually used for the fit is an in-memory correlation matrix computed from \code{\link{eqtlRegionExample}}. diff --git a/man/gwasSumStatsS4Example.Rd b/man/gwasSumStatsS4Example.Rd index 9d10de258..7713f742b 100644 --- a/man/gwasSumStatsS4Example.Rd +++ b/man/gwasSumStatsS4Example.Rd @@ -13,7 +13,7 @@ A pre-QC'd \code{\link{GwasSumStats}} collection for one synthetic trait (\code{"trait1"}, N = 50,000). The signal pattern shares one causal variant with \code{\link{qtlSumStatsExample}} (for colocalization demos) and adds a second GWAS-only causal variant. -The \code{ldSketch} slot references the same toy PLINK1 panel used +The \code{ldReference} slot references the same toy PLINK1 panel used for the QTL example. } \examples{ diff --git a/man/hasGenotypes.Rd b/man/hasGenotypes.Rd deleted file mode 100644 index 29f57b77e..000000000 --- a/man/hasGenotypes.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/LdData.R -\name{hasGenotypes} -\alias{hasGenotypes} -\alias{hasGenotypes,LdData-method} -\title{Check Genotype Availability} -\usage{ -hasGenotypes(x) - -\S4method{hasGenotypes}{LdData}(x) -} -\arguments{ -\item{x}{An \code{LdData} object.} -} -\value{ -Logical. -} -\description{ -Check whether an \code{LdData} object has a genotype handle for - extracting raw genotypes. -} -\examples{ -data(eqtlRegionExample) -X <- eqtlRegionExample$X[, 1:8] -gr <- GenomicRanges::GRanges("22", - IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -ld <- LdData(correlation = cor(X), variants = gr, - blockMetadata = S4Vectors::DataFrame( - chrom = "22", start = 1L, end = 1000L)) -hasGenotypes(ld) -} diff --git a/man/jackknifeSe.Rd b/man/jackknifeSe.Rd deleted file mode 100644 index 3f193efe1..000000000 --- a/man/jackknifeSe.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/h2EstimationWrappers.R -\name{jackknifeSe} -\alias{jackknifeSe} -\title{Jackknife Standard Errors by Block} -\usage{ -jackknifeSe(estimatesFull, estimatesLoo) -} -\arguments{ -\item{estimatesFull}{Numeric vector, full-sample parameter estimates.} - -\item{estimatesLoo}{A matrix (nBlocks x nParams), leave-one-out estimates.} -} -\value{ -Numeric vector of jackknife SEs. -} -\description{ -Compute jackknife SE estimates using leave-one-block-out. -} -\keyword{internal} diff --git a/man/l0learnRssWeights.Rd b/man/l0learnRssWeights.Rd index ba93c4680..1cdab8811 100644 --- a/man/l0learnRssWeights.Rd +++ b/man/l0learnRssWeights.Rd @@ -6,7 +6,7 @@ \usage{ l0learnRssWeights( stat, - LD, + ldReference, penalty = c("L0", "L0L1", "L0L2"), s = c(0.2, 0.5, 0.9, 1), lambda0 = exp(seq(log(0.001), log(1), length.out = 10)), @@ -14,14 +14,22 @@ l0learnRssWeights( lambda2 = 0, selection = c("ldQuadratic", "minFbeta"), maxSwaps = 100, + fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) } \arguments{ -\item{stat}{A list with \code{$b} (effect sizes) and \code{$n} (per-variant -sample sizes).} +\item{stat}{A list of summary statistics: \code{n} (per-variant sample +sizes) and the marginal effects as \code{cor} (standardized), \code{z}, +\code{b} with \code{seb}, or \code{b} alone, taken as already +standardized. The engine receives the standardized effects z / sqrt(n), +with n the median of \code{n}.} -\item{LD}{LD correlation matrix R (single matrix, NOT pre-shrunk).} +\item{ldReference}{The LD reference the statistics' variants are matched +to by \code{stat$variantNames}: a genotype panel (see +\code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +\code{\link{LdMatrix}}. A genotype reference's LD is used through its +standardized genotypes, never formed as a matrix.} \item{penalty}{L0 variant: \code{"L0"}, \code{"L0L1"}, or \code{"L0L2"}. Default \code{"L0"}.} @@ -42,13 +50,25 @@ Default \code{"L0"}.} \item{maxSwaps}{Maximum swap rounds per lambda. Default 100.} -\item{methodArgs}{Options forwarded to \code{penalizedRss}, built -with \code{\link{PenalizedRssOptions}}. A bare list is refused: it -cannot be checked against the engine, so a misspelled option would -be silently ignored.} +\item{fitRetention}{How much of the search is kept as the \code{"fit"} +attribute of the returned weights. \code{"none"} (default) attaches +nothing. \code{"slim"} keeps \code{path}, a table with one row per +candidate (\code{s}, \code{lambda0}, \code{lambda}) giving the solver's +objective \code{fbeta}, \code{loss}, convergence flag \code{conv} and +number of non-zero coefficients \code{nparams}, with \code{selected} +marking the candidate returned. \code{"full"} also keeps \code{beta}, +the candidates' coefficients (variants x candidates, in the rows' order).} + +\item{methodArgs}{Options forwarded to the solver, +\code{\link{penalizedRss}}, built with +\code{\link{PenalizedRssOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be silently +ignored.} } \value{ -A numeric vector of SNP coefficient weights. +A numeric vector of SNP coefficient weights. Unless + \code{fitRetention = "none"}, the search is attached as attribute + \code{"fit"}. } \description{ Fits L0-penalized regression (with optional L1/L2 components) on the RSS @@ -69,8 +89,8 @@ ss <- lapply( stat <- list( b = vapply(ss, `[`, numeric(1), 1L), seb = vapply(ss, `[`, numeric(1), 2L), - n = rep(nrow(X), ncol(X)) + n = rep(nrow(X), ncol(X)), + variantNames = colnames(X) ) -LD <- cor(X) -l0learnRssWeights(stat, LD) +l0learnRssWeights(stat, LdMatrix(cor(X))) } diff --git a/man/lassosumRss.Rd b/man/lassosumRss.Rd index 076373db6..aa161085d 100644 --- a/man/lassosumRss.Rd +++ b/man/lassosumRss.Rd @@ -48,16 +48,11 @@ where \eqn{R} is the LD matrix (pre-shrunk if desired) and \eqn{r = \details{ Based on Mak et al (2017) "Polygenic scores via penalized regression on summary statistics", Genetic Epidemiology 41(6):469-480. + +Internal: \code{\link{lassosumRssWeights}} is the public interface. It +runs this over a grid of LD shrinkage values, forwards \code{lambda}, +\code{thr} and \code{maxiter} through \code{\link{LassosumOptions}}, and +with \code{fitRetention} returns the paths as the \code{"fit"} attribute +of its weights. } -\examples{ -set.seed(42) -p <- 10 -n <- 100 -bhat <- rnorm(p, sd = 0.1) -R <- diag(p) -for (i in 1:(p - 1)) { - R[i, i + 1] <- 0.3 - R[i + 1, i] <- 0.3 -} -out <- lassosumRss(bhat, R, n) -} +\keyword{internal} diff --git a/man/lassosumRssWeights.Rd b/man/lassosumRssWeights.Rd index 90d995524..ec313259b 100644 --- a/man/lassosumRssWeights.Rd +++ b/man/lassosumRssWeights.Rd @@ -6,17 +6,25 @@ \usage{ lassosumRssWeights( stat, - LD, + ldReference, s = c(0.2, 0.5, 0.9, 1), selection = c("ldQuadratic", "minFbeta"), + fitRetention = c("none", "slim", "full"), methodArgs = LassosumOptions() ) } \arguments{ -\item{stat}{A list with \code{$b} (effect sizes) and \code{$n} (per-variant -sample sizes).} +\item{stat}{A list of summary statistics: \code{n} (per-variant sample +sizes) and the marginal effects as \code{cor} (standardized), \code{z}, +\code{b} with \code{seb}, or \code{b} alone, taken as already +standardized. The engine receives the standardized effects z / sqrt(n), +with n the median of \code{n}.} -\item{LD}{LD correlation matrix R (single matrix, NOT pre-shrunk).} +\item{ldReference}{The LD reference the statistics' variants are matched +to by \code{stat$variantNames}: a genotype panel (see +\code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +\code{\link{LdMatrix}}. A genotype reference's LD is used through its +standardized genotypes, never formed as a matrix.} \item{s}{Numeric vector of shrinkage parameters to search over. Default: \code{c(0.2, 0.5, 0.9, 1.0)} following Mak et al (2017) and OTTERS.} @@ -25,14 +33,24 @@ sample sizes).} \eqn{c^T \beta / \sqrt{\beta^T R \beta}} on the supplied LD matrix. \code{"minFbeta"} is retained as an explicit alternative for debugging.} -\item{methodArgs}{Options forwarded to \code{lassosumRss}, built -with \code{\link{LassosumOptions}}. A bare list is refused: it cannot be -checked against the engine, so a misspelled option would be -silently ignored.} +\item{fitRetention}{How much of the search is kept as the \code{"fit"} +attribute of the returned weights. \code{"none"} (default) attaches +nothing. \code{"slim"} keeps \code{path}, a table with one row per +candidate (\code{s}, \code{lambda}) giving the solver's objective +\code{fbeta}, \code{loss}, convergence flag \code{conv} and number of +non-zero coefficients \code{nparams}, with \code{selected} marking the +candidate returned. \code{"full"} also keeps \code{beta}, the +candidates' coefficients (variants x candidates, in the rows' order).} + +\item{methodArgs}{Options forwarded to the solver, +\code{\link{lassosumRss}}, built with \code{\link{LassosumOptions}}. A +bare list is refused: it cannot be checked against the engine, so a +misspelled option would be silently ignored.} } \value{ A numeric vector of the posterior SNP coefficients at the best (s, - lambda). + lambda). Unless \code{fitRetention = "none"}, the search is attached as + attribute \code{"fit"}. } \description{ Searches over a grid of shrinkage parameters \code{s} (default: @@ -62,8 +80,9 @@ ss <- lapply( stat <- list( b = vapply(ss, `[`, numeric(1), 1L), seb = vapply(ss, `[`, numeric(1), 2L), - n = rep(nrow(X), ncol(X)) + n = rep(nrow(X), ncol(X)), + variantNames = colnames(X) ) -LD <- cor(X) -lassosumRssWeights(stat, LD) +w <- lassosumRssWeights(stat, LdMatrix(cor(X)), fitRetention = "slim") +head(attr(w, "fit")$path) } diff --git a/man/lbf.Rd b/man/lbf.Rd index c68ee2c5c..76538fc77 100644 --- a/man/lbf.Rd +++ b/man/lbf.Rd @@ -10,7 +10,7 @@ lbf(x, ...) \S4method{lbf}{FineMappingResultBase}(x) } \arguments{ -\item{x}{A \code{FineMappingRow} or \code{FineMappingResultBase}.} +\item{x}{A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}.} \item{...}{Ignored.} } diff --git a/man/ldEigenExample.Rd b/man/ldEigenExample.Rd index 55316c3ab..08747e350 100644 --- a/man/ldEigenExample.Rd +++ b/man/ldEigenExample.Rd @@ -13,16 +13,18 @@ An \code{LdEigen} object (extends \code{LdStatistic}) with an An \code{LdEigen} reference for the eigendecomposition-based heritability estimators (\code{\link{estimateH2}} with \code{method = "lder"} or \code{"hdl"}, and -\code{\link{computeLdScores}}). Built by \code{\link{buildLdEigen}} from -the first 14 chr22 LD blocks of the de-identified \code{protocol_example} -reference panel, so the LD is real rather than simulated. Describes the -same variants as \code{\link{ldScoreExample}}, so the four estimators can -be compared on one reference. +\code{\link{computeLdScores}}). Built by \code{\link{buildLdEigen}} +over the first 14 chr22 LD blocks of the de-identified +\code{protocol_example} reference. Describes the same variants as +\code{\link{ldScoreExample}}, so the four estimators can be compared on +one reference. -The panel behind it has \code{nSamples = 1000}. That is small enough that -\code{method = "hdl"}, which models reference-panel noise explicitly, -shrinks its estimate hard -- correct behaviour for a panel this size -rather than a fault. +The LD is that of a panel of 20,000 people simulated from the +\code{protocol_example} panel's own LD, which is a sketch of 60 people: +the estimators correct for the noise in a reference's LD, and at 60 that +correction swamps the signal. A large simulated panel keeps the LD +structure real while giving the reference a realistic size +(\code{nSamples = 20000}); see \code{inst/scripts/build_h2_examples.R}. } \examples{ data(ldEigenExample) diff --git a/man/ldMatrix.Rd b/man/ldMatrix.Rd index de53c6ee7..5f8041445 100644 --- a/man/ldMatrix.Rd +++ b/man/ldMatrix.Rd @@ -1,32 +1,27 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/LdData.R +% Please edit documentation in R/AllGenerics.R, R/LdMatrix.R \name{ldMatrix} \alias{ldMatrix} -\alias{ldMatrix,LdData-method} +\alias{ldMatrix,LdMatrix-method} \title{Get LD Correlation Matrix} \usage{ ldMatrix(x) -\S4method{ldMatrix}{LdData}(x) +\S4method{ldMatrix}{LdMatrix}(x) } \arguments{ -\item{x}{An \code{LdData} object.} +\item{x}{An \code{LdMatrix}.} } \value{ -A correlation matrix, or a list of per-block matrices. +A correlation matrix. } \description{ -Extract the LD correlation matrix from an \code{LdData} object. - If only a genotype handle is available, recomputes R from genotypes on the - fly. +Extract the LD correlation matrix an \code{\link{LdMatrix}} + holds, labelled by its variant ids. } \examples{ data(eqtlRegionExample) X <- eqtlRegionExample$X[, 1:8] -gr <- GenomicRanges::GRanges("22", - IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -ld <- LdData(correlation = cor(X), variants = gr, - blockMetadata = S4Vectors::DataFrame( - chrom = "22", start = 1L, end = 1000L)) -ldMatrix(ld) +ld <- LdMatrix(cor(X), nSamples = nrow(X)) +ldMatrix(ld)[1:3, 1:3] } diff --git a/man/ldMatrixList.Rd b/man/ldMatrixList.Rd index 4a6ed9509..3564ef628 100644 --- a/man/ldMatrixList.Rd +++ b/man/ldMatrixList.Rd @@ -13,11 +13,15 @@ ldMatrixList(x) \item{x}{An \code{LdScore}.} } \value{ -List of matrices (empty list for S-LDSC). +A list with one element per block, each a list with \code{R} and + \code{snpIdx}; empty for a scores-only \code{LdScore}. } \description{ -Return the list of per-block LD (R^2) matrices used for the FGLS - residual covariance in g-LDSC. +Return the per-block LD correlation matrices g-LDSC forms its + FGLS residual covariance from: the stored ones, or, for an + \code{LdScore} built from a genotype panel (which stores none), every + block's computed from the panel now. That holds all of them in memory at + once, which the estimators avoid by reading one block at a time. } \examples{ data(ldScoreExample) diff --git a/man/ldMismatchQc.Rd b/man/ldMismatchQc.Rd index 2ca52bb4a..19d6b7c10 100644 --- a/man/ldMismatchQc.Rd +++ b/man/ldMismatchQc.Rd @@ -18,8 +18,10 @@ ldMismatchQc( \item{R}{Square LD correlation matrix. Provide either \code{R} or \code{X}.} -\item{X}{Genotype matrix (samples x SNPs). If provided, LD is computed via -\code{computeLd} and \code{nSample} defaults to \code{nrow(X)}.} +\item{X}{Genotype matrix (samples x SNPs). With \code{ldMethod = "sample"} +both methods work on the genotypes without forming the LD matrix; any +other \code{ldMethod} computes LD via \code{computeLd}. \code{nSample} +defaults to \code{nrow(X)}.} \item{nSample}{Number of samples in the LD reference panel. Required when \code{R} is provided and \code{method = "dentist"}; inferred from \code{X} diff --git a/man/ldPanelNSamples.Rd b/man/ldPanelNSamples.Rd index 2f64acf50..23b23d29e 100644 --- a/man/ldPanelNSamples.Rd +++ b/man/ldPanelNSamples.Rd @@ -1,34 +1,25 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/LdData.R, R/LdStatistic.R +% Please edit documentation in R/AllGenerics.R, R/LdStatistic.R \name{ldPanelNSamples} \alias{ldPanelNSamples} -\alias{ldPanelNSamples,LdData-method} \alias{ldPanelNSamples,LdStatistic-method} \title{Get LD Reference Panel Size} \usage{ ldPanelNSamples(x) -\S4method{ldPanelNSamples}{LdData}(x) - \S4method{ldPanelNSamples}{LdStatistic}(x) } \arguments{ -\item{x}{An \code{LdStatistic} or \code{LdData}.} +\item{x}{An \code{LdStatistic}.} } \value{ Integer (length 1). } \description{ Return the reference-panel sample size used to compute an - \code{LdStatistic} or carried by an \code{LdData}. + \code{LdStatistic}. } \examples{ -data(eqtlRegionExample) -X <- eqtlRegionExample$X[, 1:8] -gr <- GenomicRanges::GRanges("22", - IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -ld <- LdData(correlation = cor(X), variants = gr, - blockMetadata = S4Vectors::DataFrame( - chrom = "22", start = 1L, end = 1000L)) -ldPanelNSamples(ld) +data(ldEigenExample) +ldPanelNSamples(ldEigenExample) } diff --git a/man/ldPruneByCorrelation.Rd b/man/ldPruneByCorrelation.Rd index 31481765f..dc98ef417 100644 --- a/man/ldPruneByCorrelation.Rd +++ b/man/ldPruneByCorrelation.Rd @@ -23,11 +23,13 @@ group. Default 0.8.} \item{backend}{Character, one of \code{"hclust"} (default) or \code{"snprelate"}. Controls the pruning algorithm: \describe{ - \item{\code{"hclust"}}{Uses the internal hierarchical-clustering approach - with \code{Rfast::cora} (if available) or base \code{cor()}.} + \item{\code{"hclust"}}{Single-linkage groups, found as the connected + components of the |cor| >= \code{corThres} graph.} \item{\code{"snprelate"}}{Requires \pkg{SNPRelate} and \pkg{gdsfmt}. Creates a temporary GDS file and runs - \code{SNPRelate::snpgdsLDpruning(method = "corr")}.} + \code{SNPRelate::snpgdsLDpruning(method = "corr")}. GDS stores + genotypes as the integer codes 0, 1 and 2, so fractional dosages are + refused rather than rounded.} }} \item{verbose}{Logical. If TRUE, print progress messages. Default FALSE.} @@ -49,9 +51,12 @@ A list with: } \description{ Performs LD pruning using one of two backends. The default \code{"hclust"} -backend computes the full correlation matrix, builds a single-linkage -hierarchical clustering on the distance (1 - |cor|), and keeps one -representative column per cluster. The \code{"snprelate"} backend delegates +backend groups the columns as single-linkage hierarchical clustering on the +distance (1 - |cor|), cut at 1 - \code{corThres}, would, and keeps the +first column of each group. Those groups are the connected components +of the graph joining columns with |cor| >= \code{corThres}, found from the +correlations a stripe of rows at a time, so the full correlation matrix is +never formed. The \code{"snprelate"} backend delegates to \code{SNPRelate::snpgdsLDpruning}, which performs a sliding-window greedy prune directly on a temporary GDS file. } diff --git a/man/ldReference.Rd b/man/ldReference.Rd new file mode 100644 index 000000000..a4c7321ac --- /dev/null +++ b/man/ldReference.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, +% R/ColocResult.R, R/LdStatistic.R, R/twasWeights.R +\name{ldReference} +\alias{ldReference} +\alias{ldReference,SumStatsBase-method} +\alias{ldReference,FineMappingResultBase-method} +\alias{ldReference,ColocResultBase-method} +\alias{ldReference,LdStatistic-method} +\alias{ldReference,TwasWeights-method} +\title{Get LD Reference} +\usage{ +ldReference(x, ...) + +\S4method{ldReference}{SumStatsBase}(x) + +\S4method{ldReference}{FineMappingResultBase}(x) + +\S4method{ldReference}{ColocResultBase}(x) + +\S4method{ldReference}{LdStatistic}(x) + +\S4method{ldReference}{TwasWeights}(x) +} +\arguments{ +\item{x}{An S4 object that carries an \code{ldReference} slot.} + +\item{...}{Unused.} +} +\value{ +A \code{RangedSummarizedExperiment} genotype panel, a + \code{GenotypeMixture}, an \code{LdMatrix}, or \code{NULL}. +} +\description{ +Return the LD reference of this object: a genotype panel + (see \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or + an \code{\link{LdMatrix}}. Defined on classes that embed an + \code{ldReference} slot: \code{GwasSumStats}, \code{QtlSumStats}, + \code{FineMappingResultBase}, \code{TwasWeights}, + \code{ColocResultBase} and \code{LdStatistic}, whose reference is the + panel it reads its blocks' LD from. Returns \code{NULL} when the slot is + unset (e.g. a \code{TwasWeights} fit from individual-level data via + \code{QtlDataset}, or an \code{LdStatistic} built from \code{LdMatrix} + blocks). +} +\examples{ +data(qtlSumStatsExample) +ldReference(qtlSumStatsExample) +} diff --git a/man/ldScoreExample.Rd b/man/ldScoreExample.Rd index 73733f40e..aa350bc80 100644 --- a/man/ldScoreExample.Rd +++ b/man/ldScoreExample.Rd @@ -13,10 +13,10 @@ An \code{LdScore} object (extends \code{LdStatistic}) carrying An \code{LdScore} reference (per-variant LD scores, weights, and per-block LD matrices) for the LD-score-based heritability estimators (\code{\link{estimateH2}} with \code{method = "sldsc"} or -\code{"gldsc"}). Built by \code{\link{buildLdScore}} from the first 14 -chr22 LD blocks of the de-identified \code{protocol_example} reference -panel, so the LD is real rather than simulated. Describes the same variants -as \code{\link{ldEigenExample}}. +\code{"gldsc"}). Built by \code{\link{buildLdScore}} over the first 14 +chr22 LD blocks of the de-identified \code{protocol_example} reference, +from the same simulated 20,000-person panel as +\code{\link{ldEigenExample}}, and describes the same variants. The per-block LD matrices are retained because \code{"gldsc"} and stratified \code{"sldsc"} both need them; unstratified \code{"sldsc"} diff --git a/man/ldSketch.Rd b/man/ldSketch.Rd deleted file mode 100644 index 2a8cbceaa..000000000 --- a/man/ldSketch.Rd +++ /dev/null @@ -1,41 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, -% R/ColocResult.R, R/twasWeights.R -\name{ldSketch} -\alias{ldSketch} -\alias{ldSketch,SumStatsBase-method} -\alias{ldSketch,FineMappingResultBase-method} -\alias{ldSketch,ColocResultBase-method} -\alias{ldSketch,TwasWeights-method} -\title{Get LD Sketch} -\usage{ -ldSketch(x, ...) - -\S4method{ldSketch}{SumStatsBase}(x) - -\S4method{ldSketch}{FineMappingResultBase}(x) - -\S4method{ldSketch}{ColocResultBase}(x) - -\S4method{ldSketch}{TwasWeights}(x) -} -\arguments{ -\item{x}{An S4 object that carries an \code{ldSketch} slot.} - -\item{...}{Unused.} -} -\value{ -A \code{RangedSummarizedExperiment} genotype panel, or - \code{NULL}. -} -\description{ -Return the genotype panel carrying the LD reference for - this collection. Defined on classes that embed an \code{ldSketch} slot: - \code{GwasSumStats}, \code{QtlSumStats}, \code{FineMappingResult}, - \code{TwasWeights}. Returns \code{NULL} when the slot is unset (e.g. a - \code{TwasWeights} fit from individual-level data via \code{QtlDataset}). -} -\examples{ -data(qtlSumStatsExample) -ldSketch(qtlSumStatsExample) -} diff --git a/man/learnTwasWeights.Rd b/man/learnTwasWeights.Rd index a6620aff1..bcfd675a6 100644 --- a/man/learnTwasWeights.Rd +++ b/man/learnTwasWeights.Rd @@ -16,7 +16,7 @@ learnTwasWeights( fitRetention = c("none", "slim", "full"), weightStandardized = FALSE, weightsDataType = NULL, - ldSketch = NULL, + ldReference = NULL, verbose = 1, seed = NULL ) @@ -68,8 +68,9 @@ are already standardized. Default \code{FALSE}.} \item{weightsDataType}{Character or \code{NULL}. Data-type label recorded on the weights (e.g. \code{"individual"}).} -\item{ldSketch}{A genotype panel (see \code{\link{readGenotypes}}) to -record on the weights as their LD sketch, or \code{NULL}.} +\item{ldReference}{An LD reference (a genotype panel, see +\code{\link{readGenotypes}}, a \code{GenotypeMixture} or an +\code{LdMatrix}) to record on the weights, or \code{NULL}.} \item{verbose}{Integer controlling verbosity level: 0 = suppress all messages, 1 = suppress external package messages (default), 2 = show all diff --git a/man/loadGenotypeRegion.Rd b/man/loadGenotypeRegion.Rd index 1913b17b5..fead0e4fd 100644 --- a/man/loadGenotypeRegion.Rd +++ b/man/loadGenotypeRegion.Rd @@ -15,7 +15,7 @@ loadGenotypeRegion( ) } \arguments{ -\item{genotype}{Path to the genotype data file (without extension).} +\item{genotype}{Path to the genotype data file, or a PLINK prefix.} \item{region}{The target region in the format "chr:start-end".} @@ -42,11 +42,11 @@ If return_variant_info is FALSE, a numeric dosage matrix } \description{ Auto-detects PLINK2 (.pgen/.pvar[.zst]/.psam), PLINK1 (.bed/.bim/.fam), VCF -(.vcf/.vcf.gz/.bcf), or GDS (.gds) format and loads genotype data via -\code{\link{readGenotypes}} and \code{\link{extractBlockGenotypes}}. If a -stochastic genotype sidecar file (.afreq or .stochastic_meta.tsv) is found -alongside the genotype file, non-integer dosages are automatically rescaled -using the stored U_MIN/U_MAX values. +(.vcf.gz/.vcf.bgz, bgzipped with a tabix index), GDS (.gds) or BGEN (.bgen) +format, reads the file as a panel with \code{\link{readGenotypes}} and +loads the region's dosages. If a stochastic genotype sidecar file (.afreq +or .stochastic_meta.tsv) is found alongside the genotype file, non-integer +dosages are automatically rescaled using the stored U_MIN/U_MAX values. } \examples{ stem <- sub("[.]bed$", "", diff --git a/man/loadGwasSumStatsFromManifest.Rd b/man/loadGwasSumStatsFromManifest.Rd index fa372c11c..fbedf58bf 100644 --- a/man/loadGwasSumStatsFromManifest.Rd +++ b/man/loadGwasSumStatsFromManifest.Rd @@ -7,7 +7,7 @@ loadGwasSumStatsFromManifest( manifest, genome = NULL, - ldSketch = NULL, + ldReference = NULL, region = NULL, minLdOverlapWarn = 0.5, columnMapping = NULL, @@ -21,22 +21,24 @@ loadGwasSumStatsFromManifest( \code{study} (required, unique), \code{sumStatsPath} (required), \code{columnMapping} (optional), \code{nCase} / \code{nControl} (optional), \code{nSample} (optional study-level total N), \code{varY} (optional), and -the single-valued \code{genome} / \code{ldSketchPath}. When a row supplies -a study-level scalar (\code{nCase} + \code{nControl}, or \code{nSample}), -its sumstats file need not carry a per-variant \code{N} column; +the single-valued \code{genome} / \code{ldReferencePath}. When a row +supplies a study-level scalar (\code{nCase} + \code{nControl}, or +\code{nSample}), its sumstats file need not carry a per-variant \code{N} +column; \code{\link{summaryStatsQc}} fills \code{N} from the scalar.} \item{genome}{Genome build; reconciled with a \code{genome} column.} -\item{ldSketch}{A genotype panel (see \code{\link{readGenotypes}}) or a spec -(path/prefix/genoMeta); reconciled with an \code{ldSketchPath} column.} +\item{ldReference}{A genotype panel (see \code{\link{readGenotypes}}) or a +spec (path/prefix/genoMeta); reconciled with an \code{ldReferencePath} +column.} \item{region}{Optional \code{chr:start-end} string, GRanges, or one-row data.frame restricting the variants read (honoured only for tabix-indexed text and bgzipped+tabixed VCF; ignored with a warning otherwise).} \item{minLdOverlapWarn}{Warn when the fraction of sumstats variants present -in the LD sketch falls below this (default 0.5).} +in the LD reference falls below this (default 0.5).} \item{columnMapping}{Optional default column mapping (a named list/vector, or a path to a YAML file of \code{standardName: sourceName} entries) applied @@ -47,9 +49,9 @@ when a row has no \code{columnMapping}.} \item{formatMapping}{Optional GWAS-VCF FORMAT tag mapping (canonical stat -> FORMAT field), overriding ES/SE/LP/SS/EAF defaults.} -\item{ldBlocks}{Optional LD-block specification (an \code{LdBlocks}, a -\code{GRanges}, a data.frame with \code{chrom}/\code{start}/\code{end}, -or a path to such a table). Without it a genome-wide file splits into one +\item{ldBlocks}{Optional LD-block specification (a \code{GRanges}, a +data.frame with \code{chrom}/\code{start}/\code{end}, or a path to such +a table). Without it a genome-wide file splits into one element per chromosome; with it, into one element per LD block, which is the granularity \code{\link{assembleCtwasInputs}} needs.} } @@ -70,5 +72,5 @@ ldStem <- file.path(system.file("extdata", "ld_reference", "chr22", package = "pecotmr"), "protocol_example.LD.chr22") manifest <- data.frame(study = "g1", sumStatsPath = gwasTsv) loadGwasSumStatsFromManifest(manifest = manifest, genome = "hg38", - ldSketch = ldStem, region = "chr22:10000000-19000000") + ldReference = ldStem, region = "chr22:10000000-19000000") } diff --git a/man/loadLdMatrix.Rd b/man/loadLdMatrix.Rd deleted file mode 100644 index cd07214c9..000000000 --- a/man/loadLdMatrix.Rd +++ /dev/null @@ -1,98 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ld.R -\name{loadLdMatrix} -\alias{loadLdMatrix} -\title{Load and Process Linkage Disequilibrium (LD) Matrix} -\usage{ -loadLdMatrix( - ldMetaFilePath, - region = NULL, - block = NULL, - extractCoordinates = NULL, - returnGenotype = FALSE, - dropMonomorphic = FALSE, - materializeGenotypes = FALSE, - maxVariants = NULL, - seed = NULL, - nSample = NULL -) -} -\arguments{ -\item{ldMetaFilePath}{Path to the LD metadata TSV file.} - -\item{region}{Region of interest: "chr:start-end" string or data.frame with -chrom/start/end.} - -\item{block}{Integer block index (or vector of them), for sources that -carry no coordinates: an \code{ldInfo} table (the cTWAS \code{LD_map} -shape -- an \code{LD_file} column and optionally \code{SNP_file}), a -correlation or genotype matrix, or a list of either. Supply exactly one -of \code{region} and \code{block}.} - -\item{extractCoordinates}{Optional data.frame with columns "chrom" and "pos" -for specific coordinates extraction (only for pre-computed LD blocks).} - -\item{returnGenotype}{Controls what ldMatrix contains in the return value. -FALSE (default): always return correlation matrix R. TRUE: return genotype -matrix X (only valid for PLINK sources). "auto": return X for PLINK -sources, R for pre-computed sources.} - -\item{dropMonomorphic}{Logical. Drop variants with no variation, which -carry no LD and make a correlation undefined. Needs allele frequencies, -so it applies to genotype sources.} - -\item{materializeGenotypes}{Logical. Read the dosages once and keep them on -the returned object, so later access does no file I/O. Costs memory and -saves repeated reads.} - -\item{maxVariants}{Integer or \code{NULL}. Randomly thin any block larger -than this, to bound memory.} - -\item{seed}{Integer or \code{NULL}. Seeds the \code{maxVariants} draw, -offset by the block index so blocks are independent yet reproducible, via -a scoped \code{withr::local_seed} that leaves the session RNG alone.} - -\item{nSample}{Optional sample size for computing variance (= -2*p*(1-p)*n/(n-1)). If NULL, ref_panel will not include variance or -n_nomiss columns. Only used for PLINK genotype sources.} -} -\value{ -A list with: -\describe{ - \item{ldVariants}{Character vector of variant IDs (canonical format).} - \item{ldMatrix}{LD correlation matrix R (or genotype matrix X when - returnGenotype is TRUE or "auto" with PLINK source).} - \item{ref_panel}{Data.frame with variant metadata (chrom, pos, A2, A1, - variant_id, - and optionally allele_freq, variance, n_nomiss).} - \item{is_genotype}{Logical: TRUE if ldMatrix contains genotype X, FALSE if - correlation R.} - \item{blockMetadata}{Data.frame with region/block info. For pre-computed - LD: one row per block. - For PLINK: a single row spanning the loaded region.} -} -} -\description{ -Unified entry point for loading LD data from a metadata TSV file. -} -\details{ -The metadata TSV must have columns: chrom, start, end, path. Two formats: -\itemize{ - \item Pre-computed LD blocks: many rows per chromosome with block - boundaries - in start/end and path pointing to .cor.xz files (optionally - comma-separated - with a .bim path). - \item PLINK genotype files: one row per chromosome with start=0, end=0, and - path pointing to a per-chromosome PLINK prefix (.pgen/.pvar[.zst]/.psam - or - .bed/.bim/.fam). LD is computed on the fly via \code{computeLd()}. -} -} -\examples{ -meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", - package = "pecotmr") -loadLdMatrix(ldMetaFilePath = meta, region = "chr22:16000000-18000000") -# Several regions at once return one LdData per block. -length(loadLdMatrix(meta, region = rep("chr22:16000000-18000000", 2))) -} diff --git a/man/loadMultiStudyQtlDatasetFromManifest.Rd b/man/loadMultiStudyQtlDatasetFromManifest.Rd index 33abb2301..72863db69 100644 --- a/man/loadMultiStudyQtlDatasetFromManifest.Rd +++ b/man/loadMultiStudyQtlDatasetFromManifest.Rd @@ -8,7 +8,7 @@ loadMultiStudyQtlDatasetFromManifest( qtlDatasetsManifest, sumStatsManifest = NULL, genome = NULL, - ldSketch = NULL, + ldReference = NULL, region = NULL, minLdOverlapWarn = 0.5, columnMapping = NULL, @@ -27,7 +27,7 @@ loadMultiStudyQtlDatasetFromManifest( \item{sumStatsManifest}{Optional QtlSumStats manifest (see \code{\link{loadQtlSumStatsFromManifest}}).} -\item{genome, ldSketch, region, minLdOverlapWarn}{Passed to the QtlSumStats +\item{genome, ldReference, region, minLdOverlapWarn}{Passed to the QtlSumStats loader for \code{sumStatsManifest}.} \item{columnMapping, sampleSelect, formatMapping}{Passed to the QtlSumStats diff --git a/man/loadQtlSumStatsFromManifest.Rd b/man/loadQtlSumStatsFromManifest.Rd index 1e919fa37..d3900b65a 100644 --- a/man/loadQtlSumStatsFromManifest.Rd +++ b/man/loadQtlSumStatsFromManifest.Rd @@ -7,7 +7,7 @@ loadQtlSumStatsFromManifest( manifest, genome = NULL, - ldSketch = NULL, + ldReference = NULL, region = NULL, minLdOverlapWarn = 0.5, columnMapping = NULL, @@ -22,7 +22,7 @@ loadQtlSumStatsFromManifest( \code{study}, \code{context}, \code{trait} (required), \code{sumStatsPath} (required), \code{columnMapping} (optional), \code{nSample} (optional tuple-level total N), \code{varY} (optional), and the single-valued -\code{genome} / \code{ldSketchPath}. When a row supplies \code{nSample}, +\code{genome} / \code{ldReferencePath}. When a row supplies \code{nSample}, its sumstats file need not carry a per-variant \code{N} column; \code{\link{summaryStatsQc}} fills \code{N} from the scalar. (Unlike the GWAS loader, there are no \code{nCase}/\code{nControl} columns: molecular @@ -30,8 +30,8 @@ QTL traits are quantitative.)} \item{genome}{Genome build; reconciled with a \code{genome} column.} -\item{ldSketch}{A genotype panel (see \code{\link{readGenotypes}}) or spec; -reconciled with an \code{ldSketchPath} column.} +\item{ldReference}{A genotype panel (see \code{\link{readGenotypes}}) or +spec; reconciled with an \code{ldReferencePath} column.} \item{region, minLdOverlapWarn, columnMapping, sampleSelect, formatMapping}{As for \code{\link{loadGwasSumStatsFromManifest}}.} @@ -72,5 +72,5 @@ ldStem <- file.path(system.file("extdata", "ld_reference", "chr22", manifest <- data.frame(study = "s1", context = "brain", trait = "ENSG1", sumStatsPath = tsv) loadQtlSumStatsFromManifest(manifest = manifest, genome = "hg38", - ldSketch = ldStem, region = "chr22:10000000-19000000") + ldReference = ldStem, region = "chr22:10000000-19000000") } diff --git a/man/marginalEffects.Rd b/man/marginalEffects.Rd index 4a08c449c..18ab81e48 100644 --- a/man/marginalEffects.Rd +++ b/man/marginalEffects.Rd @@ -18,7 +18,7 @@ marginalEffects(x, maxPval = NULL, ...) ) } \arguments{ -\item{x}{A \code{FineMappingRow} or \code{FineMappingResult}.} +\item{x}{A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}.} \item{maxPval}{Optional numeric (length 1). When non-\code{NULL}, filter rows where \code{p > maxPval}. Default \code{NULL} (no filter).} diff --git a/man/mashInput.Rd b/man/mashInput.Rd index 8eb1a1604..22fbd218e 100644 --- a/man/mashInput.Rd +++ b/man/mashInput.Rd @@ -19,7 +19,7 @@ mashInput( } \arguments{ \item{objects}{A named \code{list} of \code{\link{QtlSumStats}} and/or -\code{FineMappingResult} objects, one per region. Names disambiguate +fine-mapping result objects, one per region. Names disambiguate rownames across regions (defaults to \code{region1}, \code{region2}, ...). For \code{QtlSumStats} inputs \code{\link{summaryStatsQc}} must have been run (the matrix builder rejects un-QC'd SumStats).} @@ -28,8 +28,8 @@ run (the matrix builder rejects un-QC'd SumStats).} \item{excludeCondition}{Character vector of condition (column) names to drop.} -\item{coverage}{Credible-set coverage for \code{FineMappingResult} strong -selection (default 0.95).} +\item{coverage}{Credible-set coverage for the strong selection on +fine-mapping results (default 0.95).} \item{zOnly}{When \code{TRUE} the returned partitions carry only \code{.z} (the \code{.b}/\code{.s} matrices are dropped after z is derived).} @@ -39,7 +39,7 @@ selection (default 0.95).} \item{inputScale}{Matrix scale for \code{QtlSumStats} inputs (\code{"auto"}/\code{"beta"}/\code{"z"}); ignored for -\code{FineMappingResult} (always effect-size scale).} +fine-mapping results (always effect-size scale).} \item{independentVariants}{Optional character vector of variant ids (e.g. an LD-pruned independent SNP list). When supplied, the \emph{random} and @@ -71,7 +71,7 @@ For EACH object three partitions are extracted: \describe{ \item{strong}{The high-signal variants (deterministic, class-specific). \code{QtlSumStats}: the single most significant variant (\eqn{\max|z|}) - per condition, unioned. \code{FineMappingResult}: the lead variant + per condition, unioned. A fine-mapping result: the lead variant (\eqn{\max} PIP) of each credible set in each condition, unioned (conditions with no credible set contribute nothing).} \item{random}{\code{nRandom} variants sampled uniformly at random -- diff --git a/man/mcpRssWeights.Rd b/man/mcpRssWeights.Rd index 46a519d7f..127619759 100644 --- a/man/mcpRssWeights.Rd +++ b/man/mcpRssWeights.Rd @@ -6,19 +6,27 @@ \usage{ mcpRssWeights( stat, - LD, + ldReference, s = c(0.2, 0.5, 0.9, 1), gamma = 3, alpha = 1, selection = c("ldQuadratic", "minFbeta"), + fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) } \arguments{ -\item{stat}{A list with \code{$b} (effect sizes) and \code{$n} (per-variant -sample sizes).} +\item{stat}{A list of summary statistics: \code{n} (per-variant sample +sizes) and the marginal effects as \code{cor} (standardized), \code{z}, +\code{b} with \code{seb}, or \code{b} alone, taken as already +standardized. The engine receives the standardized effects z / sqrt(n), +with n the median of \code{n}.} -\item{LD}{LD correlation matrix R (single matrix, NOT pre-shrunk).} +\item{ldReference}{The LD reference the statistics' variants are matched +to by \code{stat$variantNames}: a genotype panel (see +\code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +\code{\link{LdMatrix}}. A genotype reference's LD is used through its +standardized genotypes, never formed as a matrix.} \item{s}{Numeric vector of LD shrinkage parameters. Default: \code{c(0.2, 0.5, 0.9, 1.0)}.} @@ -30,13 +38,25 @@ sample sizes).} \item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or \code{"minFbeta"}.} -\item{methodArgs}{Options forwarded to \code{penalizedRss}, built -with \code{\link{PenalizedRssOptions}}. A bare list is refused: it -cannot be checked against the engine, so a misspelled option would -be silently ignored.} +\item{fitRetention}{How much of the search is kept as the \code{"fit"} +attribute of the returned weights. \code{"none"} (default) attaches +nothing. \code{"slim"} keeps \code{path}, a table with one row per +candidate (\code{s}, \code{lambda}) giving the solver's objective +\code{fbeta}, \code{loss}, convergence flag \code{conv} and number of +non-zero coefficients \code{nparams}, with \code{selected} marking the +candidate returned. \code{"full"} also keeps \code{beta}, the +candidates' coefficients (variants x candidates, in the rows' order).} + +\item{methodArgs}{Options forwarded to the solver, +\code{\link{penalizedRss}}, built with +\code{\link{PenalizedRssOptions}}. A bare list is refused: it cannot +be checked against the engine, so a misspelled option would be +silently ignored.} } \value{ -A numeric vector of SNP coefficient weights. +A numeric vector of SNP coefficient weights. Unless + \code{fitRetention = "none"}, the search is attached as attribute + \code{"fit"}. } \description{ Fits MCP-penalized regression on the RSS objective, searching over a @@ -52,8 +72,8 @@ ss <- lapply( stat <- list( b = vapply(ss, `[`, numeric(1), 1L), seb = vapply(ss, `[`, numeric(1), 2L), - n = rep(nrow(X), ncol(X)) + n = rep(nrow(X), ncol(X)), + variantNames = colnames(X) ) -LD <- cor(X) -mcpRssWeights(stat, LD) +mcpRssWeights(stat, LdMatrix(cor(X))) } diff --git a/man/mergeSusieCs.Rd b/man/mergeSusieCs.Rd index 9f228e29d..c95ab378a 100644 --- a/man/mergeSusieCs.Rd +++ b/man/mergeSusieCs.Rd @@ -8,7 +8,7 @@ mergeSusieCs(fineMappingResult, coverage = 0.95) } \arguments{ \item{fineMappingResult}{A \code{\link{QtlFineMappingResult}} (or any -\code{FineMappingResult}) produced by per-condition SuSiE fine-mapping. +\code{FineMappingResultBase}) produced by per-condition SuSiE fine-mapping. Each entry's \code{topLoci} must carry a credible-set column (\code{cs_}, e.g. \code{cs_95}, with values such as \code{"susie_1"} where the trailing integer is the set index and \code{_0} diff --git a/man/methodNames.Rd b/man/methodNames.Rd index 452eaab82..59a1f2448 100644 --- a/man/methodNames.Rd +++ b/man/methodNames.Rd @@ -20,8 +20,8 @@ methodNames(x) \S4method{methodNames}{TwasWeights}(x) } \arguments{ -\item{x}{A \code{FineMappingResult}, \code{TwasWeights}, -\code{CtwasResult} or \code{H2Estimate} object.} +\item{x}{A \code{QtlFineMappingResult}, \code{GwasFineMappingResult}, +\code{TwasWeights}, \code{CtwasResult} or \code{H2Estimate} object.} } \value{ Character vector. diff --git a/man/mixtureWeights.Rd b/man/mixtureWeights.Rd index 105f2d4ea..ab5e12b86 100644 --- a/man/mixtureWeights.Rd +++ b/man/mixtureWeights.Rd @@ -1,32 +1,36 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/LdData.R +% Please edit documentation in R/AllGenerics.R, R/GenotypeMixture.R, +% R/LdMatrix.R \name{mixtureWeights} \alias{mixtureWeights} -\alias{mixtureWeights,LdData-method} +\alias{mixtureWeights,GenotypeMixture-method} +\alias{mixtureWeights,LdMatrix-method} \title{Get Mixture Weights} \usage{ mixtureWeights(x) -\S4method{mixtureWeights}{LdData}(x) +\S4method{mixtureWeights}{GenotypeMixture}(x) + +\S4method{mixtureWeights}{LdMatrix}(x) } \arguments{ -\item{x}{An \code{LdData}.} +\item{x}{An \code{LdMatrix} or a \code{GenotypeMixture}.} } \value{ Numeric vector or NULL. } \description{ -Return the per-panel mixing proportions carried by an - \code{LdData} when its \code{genotypeHandle} slot is a list of panels. NULL - for single-panel objects. +Return the weights a mixture's components are combined + with: an \code{\link{LdMatrix}} mixture's (\code{NULL} for a single + panel's LD), or a \code{\link{GenotypeMixture}}'s, named after its + panels. } \examples{ data(eqtlRegionExample) X <- eqtlRegionExample$X[, 1:8] -gr <- GenomicRanges::GRanges("22", - IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -ld <- LdData(correlation = cor(X), variants = gr, - blockMetadata = S4Vectors::DataFrame( - chrom = "22", start = 1L, end = 1000L)) -mixtureWeights(ld) +half <- seq_len(nrow(X) / 2) +mix <- LdMatrix( + list(LdMatrix(cor(X[half, ])), LdMatrix(cor(X[-half, ]))), + mixtureWeights = c(0.75, 0.25)) +mixtureWeights(mix) } diff --git a/man/mrashRssWeights.Rd b/man/mrashRssWeights.Rd index a46f6da31..b1cc5e8f8 100644 --- a/man/mrashRssWeights.Rd +++ b/man/mrashRssWeights.Rd @@ -6,42 +6,54 @@ \usage{ mrashRssWeights( stat, - LD, - varY, - sigma2E, - s0, - w0, - z = numeric(0), + ldReference, + varY = NULL, + sigma2E = NULL, + s0 = NULL, + w0 = NULL, + fitRetention = c("none", "slim", "full"), methodArgs = MrashRssOptions() ) } \arguments{ -\item{stat}{A list of summary statistics with elements \code{b} (effect -sizes), \code{seb} (standard errors) and \code{n} (per-variant sample -sizes).} +\item{stat}{A list of summary statistics: \code{n} (per-variant sample +sizes), \code{variantNames}, and the marginal effects as \code{z}, or as +\code{b} with \code{seb}.} -\item{LD}{Numeric LD (correlation) matrix aligned to the variants in -\code{stat}.} +\item{ldReference}{The LD reference the statistics' variants are matched +to by \code{stat$variantNames}: a genotype panel (see +\code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +\code{\link{LdMatrix}}. \code{mr.ash.rss} takes an LD matrix, which is +formed from the reference over these variants.} -\item{varY}{Numeric. Variance of the phenotype.} +\item{varY}{Variance of the phenotype, or \code{NULL} (default) to fit on +the standardized scale. Used only with \code{b} and \code{seb}.} -\item{sigma2E}{Numeric. Residual error variance estimate.} +\item{sigma2E}{Initial residual variance, or \code{NULL} (default) for +\code{mr.ash.rss}'s own.} -\item{s0}{Numeric vector of prior mixture standard deviations (the sigma0 -grid).} +\item{s0}{Prior variances of the mixture components, relative to the +residual variance, or \code{NULL} (default) for the grid +\code{susieR::mr.ash} uses by default, built for these statistics.} -\item{w0}{Numeric vector of prior mixture weights (summing to 1).} +\item{w0}{Prior mixture weights (summing to 1), or \code{NULL} (default) +for equal weights.} -\item{z}{Optional numeric vector of z-scores; defaults to \code{numeric(0)} -(derived from \code{stat}).} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing, \code{"slim"} and \code{"full"} attach the fitted +\code{mr.ash.rss} model. This engine keeps no trimmable intermediates, +so the two retaining levels behave alike here.} \item{methodArgs}{Options forwarded to \code{susieR::mr.ash.rss}, built -with \code{\link{MrashOptions}}. A bare list is refused: it cannot be +with \code{\link{MrashRssOptions}}. A bare list is refused: it cannot be checked against the engine, so a misspelled option would be silently ignored.} } \value{ -A numeric vector of the posterior mean of the coefficients. +A numeric vector of the posterior mean of the coefficients. Unless + \code{fitRetention = "none"}, the fitted model is attached as attribute + \code{"fit"}. } \description{ Extract weights from mr.ash.rss (susieR) @@ -54,7 +66,7 @@ ss <- lapply(seq_len(ncol(X)), function(j) { coef(summary(lm(y ~ X[, j])))[2, 1:2] }) stat <- list(b = vapply(ss, `[`, numeric(1), 1L), - seb = vapply(ss, `[`, numeric(1), 2L), n = rep(nrow(X), ncol(X))) -mrashRssWeights(stat, cor(X), varY = var(y), sigma2E = var(y), - s0 = c(0, 0.1, 0.5), w0 = c(0.8, 0.1, 0.1)) + seb = vapply(ss, `[`, numeric(1), 2L), n = rep(nrow(X), ncol(X)), + variantNames = colnames(X)) +mrashRssWeights(stat, LdMatrix(cor(X))) } diff --git a/man/mrashWeights.Rd b/man/mrashWeights.Rd index 06419f2ca..5229a2498 100644 --- a/man/mrashWeights.Rd +++ b/man/mrashWeights.Rd @@ -7,7 +7,6 @@ mrashWeights( X, y, - initPriorSd = TRUE, fitRetention = c("none", "slim", "full"), methodArgs = MrashOptions() ) @@ -17,15 +16,11 @@ mrashWeights( \item{y}{Numeric response (phenotype) vector of length \code{nrow(X)}.} -\item{initPriorSd}{Logical. Initialize the prior standard-deviation grid -from the data. Default \code{TRUE}.} - \item{fitRetention}{How much of the fit is kept as the \code{"fit"} - attribute of the returned weights: \code{"none"} (default) attaches - nothing, \code{"slim"} and \code{"full"} attach the fitted model. This - engine keeps no trimmable intermediates, so the two retaining levels - behave alike here. -Default \code{FALSE}.} +attribute of the returned weights: \code{"none"} (default) attaches +nothing, \code{"slim"} and \code{"full"} attach the fitted model. This +engine keeps no trimmable intermediates, so the two retaining levels +behave alike here.} \item{methodArgs}{Options forwarded to \code{susieR::mr.ash}, built with \code{\link{MrashOptions}}. A bare list is refused: it cannot be @@ -40,9 +35,10 @@ A numeric vector of weights, one per variant (column of \code{X}); } \description{ This function fits the `mr.ash` model (adaptive shrinkage regression) to -estimate weights for a given set of predictors and response. It uses optional -prior standard deviation initialization and can accept custom initial beta -values. +estimate weights for a given set of predictors and response. The prior is +\code{susieR::mr.ash}'s own default mixture grid unless \code{sa2} is +supplied through \code{methodArgs}, and custom initial beta values are +accepted. } \examples{ set.seed(1) diff --git a/man/mrmashRssWeights.Rd b/man/mrmashRssWeights.Rd index df64a7e48..197eed21b 100644 --- a/man/mrmashRssWeights.Rd +++ b/man/mrmashRssWeights.Rd @@ -6,7 +6,7 @@ \usage{ mrmashRssWeights( stat, - LD, + ldReference, mrmashRssFit = NULL, dataDrivenPriorMatrices = NULL, canonicalPriorMatrices = TRUE, @@ -19,11 +19,16 @@ mrmashRssWeights( ) } \arguments{ -\item{stat}{A list with \code{z} (variants x conditions matrix) and \code{n} -(per-context numeric vector or scalar). May also include \code{Bhat}, -\code{Shat} matrices.} +\item{stat}{A list with \code{z} (variants x conditions matrix), +\code{n} (per-context numeric vector or scalar) and \code{variantNames}. +May also include \code{Bhat}, \code{Shat} matrices.} -\item{LD}{LD correlation matrix.} +\item{ldReference}{The LD reference the statistics' variants are matched +to by \code{stat$variantNames}: a genotype panel (see +\code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +\code{\link{LdMatrix}}. \code{mr.mash.rss} takes an LD matrix, which is +formed from the reference over these variants; it is not read when +\code{mrmashRssFit} is supplied.} \item{mrmashRssFit}{Optional pre-fitted \code{mr.mash.rss} object; skips fitting when supplied.} @@ -93,8 +98,9 @@ X <- eqtlRegionExample$X[, 1:30] cond <- c("brain", "blood", "muscle") zmat <- matrix(rnorm(30 * 3), 30, 3, dimnames = list(colnames(X), cond)) -stat <- list(z = zmat, n = matrix(nrow(X), 30, 3)) -mrmashRssWeights(stat, cor(X), +stat <- list(z = zmat, n = matrix(nrow(X), 30, 3), + variantNames = colnames(X)) +mrmashRssWeights(stat, LdMatrix(cor(X)), dataDrivenPriorMatrices = multiTraitData$priorMatrices, canonicalPriorMatrices = TRUE) } diff --git a/man/mvsusieRssWeights.Rd b/man/mvsusieRssWeights.Rd index b36f4fa27..13b4c4ab7 100644 --- a/man/mvsusieRssWeights.Rd +++ b/man/mvsusieRssWeights.Rd @@ -6,18 +6,21 @@ \usage{ mvsusieRssWeights( stat, - LD, + ldReference = NULL, mvsusieRssFit = NULL, fitRetention = c("none", "slim", "full") ) } \arguments{ -\item{stat}{A list with \code{z} (matrix variants x conditions) and \code{n} -(numeric vector or scalar), describing the block the fit came from.} +\item{stat}{A list with \code{z} (matrix variants x conditions), \code{n} +(numeric vector or scalar) and, to check against an \code{ldReference}, +\code{variantNames}, describing the block the fit came from. The fit +must cover the same number of variants; a mismatch is an error, since +weights from one block are not comparable against another's.} -\item{LD}{LD correlation matrix for that block. The fit must cover the -same number of variants; a mismatch is an error, since weights from one -block are not comparable against another's LD.} +\item{ldReference}{Optional LD reference for that block: a genotype +panel, a \code{\link{GenotypeMixture}} or an \code{\link{LdMatrix}}. +With one, the statistics' variants must also be in it. No LD is read.} \item{mvsusieRssFit}{A fitted \code{mvsusieRss} object. Required: this extracts weights and never runs fine-mapping itself.} @@ -37,9 +40,9 @@ extracts coefficients from an existing \code{mvsusieR::mvsusie_rss} fit. It never runs fine-mapping itself --- \code{mvsusieRssFit} is required. } \details{ -Follows the \code{*_rss_weights(stat, LD, ...)} contract: \code{stat} and -\code{LD} describe the block the fit is being extracted against, and the -fit is checked against them rather than refitted. +Follows the RSS weights contract: \code{stat} (and \code{ldReference}, +when given) describe the block the fit is being extracted against, and +the fit is checked against them rather than refitted. } \examples{ data(eqtlRegionExample) @@ -56,5 +59,5 @@ stat <- list( LD <- cor(X) fit <- fitMvsusieRss(Z = stat$z, R = LD, N = nrow(X), prior_variance = 1) -mvsusieRssWeights(stat, LD, mvsusieRssFit = fit) +mvsusieRssWeights(stat, mvsusieRssFit = fit) } diff --git a/man/nSamples.Rd b/man/nSamples.Rd index 8bcdafaf1..0f1fa66d8 100644 --- a/man/nSamples.Rd +++ b/man/nSamples.Rd @@ -1,14 +1,17 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/GenotypeHandle.R, -% R/AllClasses.R +% Please edit documentation in R/AllGenerics.R, R/LdMatrix.R, +% R/GenotypeHandle.R, R/AllClasses.R \name{nSamples} \alias{nSamples} +\alias{nSamples,LdMatrix-method} \alias{nSamples,GenotypeHandle-method} \alias{nSamples,SumStatsBase-method} \title{Get Sample Sizes} \usage{ nSamples(x, ...) +\S4method{nSamples}{LdMatrix}(x, ...) + \S4method{nSamples}{GenotypeHandle}(x) \S4method{nSamples}{SumStatsBase}( @@ -21,7 +24,7 @@ nSamples(x, ...) ) } \arguments{ -\item{x}{A \code{GwasSumStats}, \code{QtlSumStats} or +\item{x}{A \code{GwasSumStats}, \code{QtlSumStats}, \code{LdMatrix} or \code{GenotypeHandle} object.} \item{...}{Class-specific selection arguments.} @@ -43,12 +46,14 @@ variants overlapping these ranges; \code{NULL} returns everything.} } \value{ Numeric vector of sample sizes for a summary-statistic entry; - integer of length 1 for a \code{GenotypeHandle}. + integer of length 1 for a \code{GenotypeHandle} or an \code{LdMatrix} + (\code{NA} when the matrix records no size). } \description{ Extract sample sizes: the per-variant sample-size vector of a \code{GwasSumStats} or \code{QtlSumStats} entry, selected by its identity - tuple, or the number of samples carried by a \code{GenotypeHandle}. + tuple, the number of samples carried by a \code{GenotypeHandle}, or the + panel size an \code{\link{LdMatrix}} records. } \details{ The genotype handle is the seed layer behind a panel and is not diff --git a/man/pecotmr-genotype-io.Rd b/man/pecotmr-genotype-io.Rd index 8bb5bb0c3..5dd493018 100644 --- a/man/pecotmr-genotype-io.Rd +++ b/man/pecotmr-genotype-io.Rd @@ -2,10 +2,11 @@ % Please edit documentation in R/genotypeIo.R \name{pecotmr-genotype-io} \alias{pecotmr-genotype-io} -\title{Genotype I/O via GenotypeHandle} +\title{Genotype I/O} \description{ -Read genotype data from various formats (VCF, plink1, plink2, - GDS) and provide block-level genotype extraction without requiring format - conversion. +Read genotype data in its own format (VCF, plink1, plink2, + GDS, BGEN) as a lazily read genotype panel, without converting it: + PLINK2 and BGEN files through a GenotypeHandle, VCF, GDS and PLINK1 + files through a GenotypeDosageSeed. } \keyword{internal} diff --git a/man/pecotmr-h2-gldsc.Rd b/man/pecotmr-h2-gldsc.Rd index 219433914..cd3fcdf6d 100644 --- a/man/pecotmr-h2-gldsc.Rd +++ b/man/pecotmr-h2-gldsc.Rd @@ -7,10 +7,15 @@ Estimate heritability and functional enrichment by feasible generalized least squares (FGLS) on LD scores (Xiong et al. 2024). The response \eqn{Z_j^2 - 1} is regressed on stratified LD scores - \eqn{\ell_{ja} = \sum_k R^2_{jk} A_{ka}} (with a confounding intercept) - using the full residual covariance + \eqn{\ell_{ja} = \sum_k R^2_{jk} A_{ka}} (with a confounding intercept; + the raw sample \eqn{R^2}, as the original gLDSC implementation forms + them, not the unbiased \eqn{r^2} of the S-LDSC scores) using the full + residual covariance \eqn{\Omega = (\hat{N\tau}\, R D_a R + R)^2} (elementwise), inverted per LD - block via a 99\%-eigenvalue-mass truncation. \eqn{\hat{N\tau} = \sum(Z^2-1) + block via a 99\%-eigenvalue-mass truncation. Each block's \eqn{\Omega} + is formed, decomposed and dropped in turn; for a reference read from a + genotype panel it is formed from the panel's factor, never from the + block's \eqn{R}. \eqn{\hat{N\tau} = \sum(Z^2-1) / \sum \ell} is a method-of-moments plug-in; \eqn{D_a = diag(\sum_a A_{ja})}. Coefficients are \eqn{\tau = (X'\Omega^{-1}X)^{-1} X'\Omega^{-1} y / N} and diff --git a/man/pecotmr-h2-sldsc.Rd b/man/pecotmr-h2-sldsc.Rd index e21a2ea21..6a9fff58b 100644 --- a/man/pecotmr-h2-sldsc.Rd +++ b/man/pecotmr-h2-sldsc.Rd @@ -8,8 +8,10 @@ Estimate heritability and functional enrichment by weighted least squares on LD scores (Finucane et al. 2015) -- the original method the other three estimators descend from. Per-variant \eqn{\chi^2_j} is regressed on annotation-stratified LD scores - \eqn{\ell_{jC} = \sum_{k \in C} r^2_{jk}} with a confounding - intercept, fitting + \eqn{\ell_{jC} = \sum_{k \in C} r^2_{jk}}, each \eqn{r^2} being ldsc's + unbiased estimate \code{r^2 - (1 - r^2) / (n - 2)} at the reference + panel size \code{n} (see \code{\link{buildLdScore}}), with a + confounding intercept, fitting \eqn{E[\chi^2_j] = N \sum_C \tau_C \ell_{jC} + Na + 1}. Weights are LDSC's two multiplied factors, both floored at 1: the @@ -24,8 +26,9 @@ Estimate heritability and functional enrichment by weighted \item{unstratified}{the two-step estimator: the intercept is fit on the variants with \eqn{\chi^2 < 30}, then held fixed while the slope is fit over all of them.} - \item{stratified}{no two-step -- upstream refuses one on a - partitioned design. Variants with \eqn{\chi^2 >} \code{max(0.001 + \item{stratified}{no two-step -- the original \code{ldsc} refuses + one on a partitioned design. Variants with \eqn{\chi^2 >} + \code{max(0.001 N, 80)} are dropped, the design is weighted once, and a single weighted least-squares fit follows.} } @@ -35,15 +38,17 @@ Estimate heritability and functional enrichment by weighted than an error to clamp away, and clamping would move the heritability too. - Estimates agree with upstream \code{ldsc} to roughly 1e-6 relative; - the residual is a small ridge in the weighted solve, which upstream has - no equivalent of and which exists so an exactly singular design returns - a value rather than \code{NA}. + Estimates agree with the original \code{ldsc} implementation to + roughly 1e-6 relative; the residual is a small ridge in the weighted + solve, which the original has no equivalent of and which exists so an + exactly singular design returns a value rather than \code{NA}. Unlike \code{\link{pecotmr-h2-gldsc}} this needs only the per-variant scores when unstratified, so it runs on a scores-only \code{\link{LdScore}}; the stratified fit forms per-annotation scores - from the per-block LD matrices and therefore requires them. + from each block's LD, so it needs an \code{LdScore} that carries it: + one built from a genotype panel, or from \code{LdMatrix} blocks with + their matrices kept. \strong{Scale.} LD score regression is a genome-scale method -- real analyses regress over roughly a million variants. On a reference of a diff --git a/man/penalizedRss.Rd b/man/penalizedRss.Rd index 86c6d3359..4acb4b814 100644 --- a/man/penalizedRss.Rd +++ b/man/penalizedRss.Rd @@ -73,16 +73,12 @@ and L0L2 penalties. Uses coordinate descent on the objective where \eqn{R} is a (possibly pre-shrunk) LD matrix and \eqn{z = \hat\beta / \sqrt{n}}. } -\examples{ -set.seed(42) -p <- 10; n <- 100 -bhat <- rnorm(p, sd = 0.1) -R <- diag(p) -# MCP -penalizedRss(bhat, R, n, penalty = "MCP") -# SCAD -penalizedRss(bhat, R, n, penalty = "SCAD") -# L0 -penalizedRss(bhat, R, n, penalty = "L0", lambda0 = 0.01, - lambda = c(0)) +\details{ +Internal: \code{\link{scadRssWeights}}, \code{\link{mcpRssWeights}} and +\code{\link{l0learnRssWeights}} are the public interface, with +\code{\link{lassosumRssWeights}} for the lasso. They run this over a grid +of LD shrinkage values, forward its options through +\code{\link{PenalizedRssOptions}}, and with \code{fitRetention} return +the paths as the \code{"fit"} attribute of their weights. } +\keyword{internal} diff --git a/man/pip.Rd b/man/pip.Rd index 2a527db62..64258ed8a 100644 --- a/man/pip.Rd +++ b/man/pip.Rd @@ -29,7 +29,7 @@ pip(x, ...) ) } \arguments{ -\item{x}{A \code{FineMappingRow} or \code{FineMappingResult}.} +\item{x}{A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}.} \item{...}{Class-specific selection arguments.} @@ -56,9 +56,9 @@ identity tuple instead of a single flattened vector.} A named numeric vector of PIPs. } \description{ -Extract posterior inclusion probabilities from a single - \code{FineMappingRow} or from one entry of a \code{FineMappingResult} - (selected by its identity tuple). +Extract posterior inclusion probabilities from a + \code{QtlFineMappingResult} or \code{GwasFineMappingResult}, narrowed to + the entries its identity selectors pick. } \examples{ data(qtlFineMappingExample) diff --git a/man/postprocessFinemappingFits.Rd b/man/postprocessFinemappingFits.Rd index 04466a70f..c7f57c4d0 100644 --- a/man/postprocessFinemappingFits.Rd +++ b/man/postprocessFinemappingFits.Rd @@ -50,7 +50,7 @@ including non-credible-set variants in top loci), \code{minAbsCorr} and \item{fitRetention}{How much of each fit is kept: \code{"slim"} (default) trims the retained fit to what downstream needs, \code{"full"} keeps the whole fit object. The \code{topLoci} table's per-credible-set columns -are governed by \code{credibleSet}'s \code{perCsColumns} instead.} +are governed by \code{credibleSetParam}'s \code{perCsColumns} instead.} \item{otherQuantities}{Optional named list of extra per-method quantities to carry on the result untouched (returned as the \code{otherQuantities} diff --git a/man/prsCs.Rd b/man/prsCs.Rd index e629f3335..654eccd9d 100644 --- a/man/prsCs.Rd +++ b/man/prsCs.Rd @@ -60,45 +60,10 @@ marginal effect size estimates from regression and an external LD reference panel and infers posterior SNP effect sizes using Bayesian regression with continuous shrinkage priors. } -\examples{ -# Generate example data -set.seed(985115) -n <- 350 -p <- 16 -sigmasq_error <- 0.5 -zeroes <- rbinom(p, 1, 0.6) -beta.true <- rnorm(p, 1, sd = 4) -beta.true[zeroes] <- 0 - -X <- cbind(matrix(rnorm(n * p), nrow = n)) -X <- scale(X, center = TRUE, scale = FALSE) -y <- X \%*\% matrix(beta.true, ncol = 1) + rnorm(n, 0, sqrt(sigmasq_error)) -y <- scale(y, center = TRUE, scale = FALSE) - -# Calculate sufficient statistics -XtX <- t(X) \%*\% X -Xty <- t(X) \%*\% y -yty <- t(y) \%*\% y - -# Set the prior -K <- 9 -sigma0 <- c(0.001, .1, .5, 1, 5, 10, 20, 30, .005) -omega0 <- rep(1 / K, K) - -# Calculate summary statistics -b.hat <- sapply(1:p, function(j) { - summary(lm(y ~ X[, j]))$coefficients[-1, 1] -}) -s.hat <- sapply(1:p, function(j) { - summary(lm(y ~ X[, j]))$coefficients[-1, 2] -}) -R.hat <- cor(X) -var_y <- var(y) -sigmasq_init <- 1.5 - -# Run PRS CS -maf <- rep(0.5, length(b.hat)) # fake MAF -out <- prsCs(b.hat, R.hat, n, maf = maf) -# In sample prediction correlations -cor(X \%*\% out$betaEst, y) # 0.9944553 +\details{ +Internal: \code{\link{prsCsWeights}} is the public interface. It forwards +the arguments below other than \code{bhat}, \code{R} and \code{n} through +\code{\link{PrsCsOptions}}, and with \code{fitRetention} returns this +function's list as the \code{"fit"} attribute of its weights. } +\keyword{internal} diff --git a/man/prsCsWeights.Rd b/man/prsCsWeights.Rd index 43257f3ea..7cb729cac 100644 --- a/man/prsCsWeights.Rd +++ b/man/prsCsWeights.Rd @@ -4,22 +4,43 @@ \alias{prsCsWeights} \title{Extract weights from prsCs function} \usage{ -prsCsWeights(stat, LD, methodArgs = PrsCsOptions()) +prsCsWeights( + stat, + ldReference, + fitRetention = c("none", "slim", "full"), + methodArgs = PrsCsOptions() +) } \arguments{ -\item{stat}{A list of summary statistics with elements \code{b} (effect -sizes) and \code{n} (per-variant sample sizes).} +\item{stat}{A list of summary statistics: \code{n} (per-variant sample +sizes) and the marginal effects as \code{cor} (standardized), \code{z}, +\code{b} with \code{seb}, or \code{b} alone, taken as already +standardized. The engine receives the standardized effects z / sqrt(n), +with n the median of \code{n}.} + +\item{ldReference}{The LD reference the statistics' variants are matched +to by \code{stat$variantNames}: a genotype panel (see +\code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +\code{\link{LdMatrix}}. A genotype reference's LD is used through its +standardized genotypes, never formed as a matrix.} -\item{LD}{Numeric LD (correlation) matrix aligned to the variants in -\code{stat}.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing, \code{"slim"} and \code{"full"} attach the sampler's posterior +estimates: \code{betaEst}, the local shrinkage parameters +\code{psiEst}, the residual variance \code{sigmaEst} and the global +shrinkage \code{phiEst}. This engine keeps no trimmable intermediates, +so the two retaining levels behave alike here.} -\item{methodArgs}{Options forwarded to \code{prsCs}, built -with \code{\link{PrsCsOptions}}. A bare list is refused: it cannot be -checked against the engine, so a misspelled option would be +\item{methodArgs}{Options forwarded to the sampler, \code{\link{prsCs}}, +built with \code{\link{PrsCsOptions}}. A bare list is refused: it cannot +be checked against the engine, so a misspelled option would be silently ignored.} } \value{ -A numeric vector of the posterior SNP coefficients. +A numeric vector of the posterior SNP coefficients. Unless + \code{fitRetention = "none"}, the sampler's estimates are attached as + attribute \code{"fit"}. } \description{ Extract weights from prsCs function @@ -33,8 +54,14 @@ ss <- lapply( stat <- list( b = vapply(ss, `[`, numeric(1), 1L), seb = vapply(ss, `[`, numeric(1), 2L), - n = rep(nrow(X), ncol(X)) + n = rep(nrow(X), ncol(X)), + variantNames = colnames(X) +) +w <- prsCsWeights( + stat, + LdMatrix(cor(X)), + fitRetention = "slim", + methodArgs = PrsCsOptions(maf = rep(0.3, ncol(X))) ) -LD <- cor(X) -prsCsWeights(stat, LD, methodArgs = PrsCsOptions(maf = rep(0.3, ncol(X)))) +attr(w, "fit")$phiEst } diff --git a/man/qtlEnrichment.Rd b/man/qtlEnrichment.Rd index 8acc477cf..6adf61374 100644 --- a/man/qtlEnrichment.Rd +++ b/man/qtlEnrichment.Rd @@ -73,7 +73,7 @@ A named list of enrichment parameter estimates, carrying the \code{sd (w/ shrinkage)}, \code{Alternative (coloc) p1} / \code{p2} / \code{p12} and \code{Effective MI rounds} -- plus \code{unused_xqtl_variants}, the QTL variants of each region that no GWAS - variant matched. The names are upstream fastenloc's; + variant matched. The names are the original fastenloc's; \code{\link{qtlEnrichmentPipeline}} is what renames them to a tidy table. } \description{ diff --git a/man/qtlEnrichmentPipeline.Rd b/man/qtlEnrichmentPipeline.Rd index 1acf65d90..a9b0f378f 100644 --- a/man/qtlEnrichmentPipeline.Rd +++ b/man/qtlEnrichmentPipeline.Rd @@ -7,7 +7,7 @@ qtlEnrichmentPipeline( gwasFineMappingResult, qtlFineMappingResult, - methodArgs = QtlEnrichmentParam(), + qtlEnrichmentParam = QtlEnrichmentParam(), numThreads = 1L, seed = NULL, verbose = TRUE @@ -18,7 +18,7 @@ qtlEnrichmentPipeline( \item{qtlFineMappingResult}{The annotation side; see above.} -\item{methodArgs}{The estimator's algorithmic settings, built with +\item{qtlEnrichmentParam}{The estimator's algorithmic settings, built with \code{\link{QtlEnrichmentParam}}: \code{numGwas}, \code{piQtl}, \code{lambda}, \code{impN}, \code{doubleShrinkage} and \code{besselCorrection}. A bare list is refused, since it cannot be @@ -78,27 +78,30 @@ genome of outcome PIPs and the full collection of annotation fits at once. \itemize{ \item \code{gwasFineMappingResult}: the genome-wide outcome collection. - Each entry's \code{FineMappingRow$trimmedFit} must carry a \code{pip} + Each row's stored fit (\code{\link{susieFit}}) must carry a \code{pip} vector. One PIP vector is built per outcome trait -- keyed by \code{study} for a GWAS collection (one trait per study) and by (\code{study}, \code{context}, \code{trait}) for a QTL one, since a variant's PIP differs between molecular traits and pooling them would collide. - \item \code{qtlFineMappingResult}: the annotation collection. Each entry's - \code{trimmedFit} must carry \code{alpha}, \code{pip}, and + \item \code{qtlFineMappingResult}: the annotation collection. Each row's + stored fit must carry \code{alpha}, \code{pip}, and prior-variance fields (\code{V}). Its region fits are pooled per (\code{study}, \code{context}) -- per \code{study} alone for a GWAS collection, which has no context axis. } } -\section{LD-sketch compatibility check}{ - A GWAS outcome collection must have - a non-NULL \code{ldSketch} (it should be RSS-derived). Where both sides - carry one, the two must come from the same reference panel --- same - samples, same allele orientation on the variants they share --- but need - NOT carry the same variants: QC-ing the two sides separately trims each - sketch to its own surviving variants, and a partial overlap only warns. A +\section{LD reference compatibility check}{ + A GWAS outcome collection + must have a non-NULL \code{ldReference} (it should be RSS-derived). Where + both sides carry one, the two must be the same LD reference. + The two must be the same kind of reference. Two genotype panels must + share their samples and allele orientation; two \code{LdMatrix} objects + must agree on the LD they share; two \code{GenotypeMixture} objects must + average the same panels with the same weights. They need NOT carry the + same variants: QC-ing the two sides separately trims each reference to + its own surviving variants, and a partial overlap only warns. A \code{NULL} on either side (an individual-level fit) skips the check. } diff --git a/man/qtlSumStatsExample.Rd b/man/qtlSumStatsExample.Rd index 11676e1ca..d6042aa31 100644 --- a/man/qtlSumStatsExample.Rd +++ b/man/qtlSumStatsExample.Rd @@ -12,7 +12,7 @@ A \code{QtlSumStats} S4 collection with one row (study1, brain, A pre-QC'd \code{\link{QtlSumStats}} collection covering the same (study, context, trait) tuple as \code{\link{qtlDatasetExample}}; the per-variant Z / BETA / SE / N values were computed from the synthetic -phenotype by per-variant linear regression. The \code{ldSketch} slot +phenotype by per-variant linear regression. The \code{ldReference} slot references the same toy PLINK1 panel. } \examples{ diff --git a/man/qtlSumStatsFromBetaMatrix.Rd b/man/qtlSumStatsFromBetaMatrix.Rd index 687d7bdfc..3a0bc2d32 100644 --- a/man/qtlSumStatsFromBetaMatrix.Rd +++ b/man/qtlSumStatsFromBetaMatrix.Rd @@ -8,7 +8,7 @@ qtlSumStatsFromBetaMatrix( bhat, shat, studyName, - ldSketch = NULL, + ldReference = NULL, context = colnames(bhat), trait = "mash", genome = "GRCh38", @@ -28,7 +28,7 @@ conditions.} \item{studyName}{Study identifier (recycled across conditions).} -\item{ldSketch}{A genotype panel (see \code{\link{readGenotypes}}) +\item{ldReference}{A genotype panel (see \code{\link{readGenotypes}}) embedded in the collection, or \code{NULL} (default) -- mash operates across conditions per variant and needs no LD reference.} @@ -66,7 +66,7 @@ bhat <- matrix(rnorm(6), 2, 3, dimnames = list( c("chr22:1:A:G", "chr22:2:A:G"), c("brain", "blood", "muscle"))) shat <- matrix(0.1, 2, 3, dimnames = dimnames(bhat)) qtlSumStatsFromBetaMatrix(bhat = bhat, shat = shat, studyName = "s1", - ldSketch = panel, context = colnames(bhat), trait = "g1", + ldReference = panel, context = colnames(bhat), trait = "g1", genome = "hg38", n = 100) } \seealso{ diff --git a/man/qtlSumStatsFromZMatrix.Rd b/man/qtlSumStatsFromZMatrix.Rd index 0d8b2dc68..b28915e7c 100644 --- a/man/qtlSumStatsFromZMatrix.Rd +++ b/man/qtlSumStatsFromZMatrix.Rd @@ -7,7 +7,7 @@ qtlSumStatsFromZMatrix( z, studyName, - ldSketch = NULL, + ldReference = NULL, context = colnames(z), trait = "mash", genome = "GRCh38", @@ -24,7 +24,7 @@ conditions.} \item{studyName}{Study identifier (recycled across conditions).} -\item{ldSketch}{A genotype panel (see \code{\link{readGenotypes}}) +\item{ldReference}{A genotype panel (see \code{\link{readGenotypes}}) embedded in the collection, or \code{NULL} (default) -- mash operates across conditions per variant and needs no LD reference.} @@ -68,6 +68,6 @@ panel <- readGenotypes( system.file("extdata", "toy_ref.bed", package = "pecotmr")) z <- matrix(rnorm(6), 2, 3, dimnames = list( c("chr22:1:A:G", "chr22:2:A:G"), c("brain", "blood", "muscle"))) -qtlSumStatsFromZMatrix(z = z, studyName = "s1", ldSketch = panel, +qtlSumStatsFromZMatrix(z = z, studyName = "s1", ldReference = panel, context = colnames(z), trait = "g1", genome = "hg38", n = 100) } diff --git a/man/raiss.Rd b/man/raiss.Rd index ee30378d1..c0f2b7e21 100644 --- a/man/raiss.Rd +++ b/man/raiss.Rd @@ -5,10 +5,10 @@ \title{Impute Summary Statistics Using LD (RAISS)} \usage{ raiss( - refPanel, + refPanel = NULL, knownZscores, ldMatrix = NULL, - genotypeMatrix = NULL, + genotypes = NULL, lamb = 0.01, rcond = 0.01, svdTol = 1e-08, @@ -19,26 +19,33 @@ raiss( } \arguments{ \item{refPanel}{A data frame containing 'chrom', 'pos', 'variant_id', 'A1', -and 'A2'.} +and 'A2'. Optional when the LD comes as an \code{LdMatrix} or a genotype +panel, whose own variants are used; \code{knownZscores} must then label +chromosomes canonically, as character (e.g. \code{"22"}). Required +with a plain \code{ldMatrix}, whose rows and columns follow it.} \item{knownZscores}{A data frame containing 'chrom', 'pos', 'variant_id', 'A1', 'A2', and 'z' values.} -\item{ldMatrix}{Either a square matrix or a list of matrices for LD blocks. -Provide either \code{ldMatrix} or \code{genotypeMatrix}, not both.} +\item{ldMatrix}{A square LD matrix over \code{refPanel}'s variants, in its +order, or an \code{LdMatrix} covering them. Provide either +\code{ldMatrix} or \code{genotypes}, not both.} -\item{genotypeMatrix}{A centered and scaled genotype matrix (n x p) as an -alternative to \code{ldMatrix}. Column order must match the variant order -in \code{refPanel}. When provided, the imputation uses an SVD-based -approach that avoids forming the p x p LD matrix.} +\item{genotypes}{A genotype panel (see \code{\link{readGenotypes}}) or a +\code{\link{GenotypeMixture}} covering the variants, as an alternative +to \code{ldMatrix}. Its dosages are matched to \code{refPanel} by +variant and allele, mean-imputed and standardized here.} \item{lamb}{Regularization term added to the diagonal of the ldMatrix.} -\item{rcond}{Threshold for filtering eigenvalues in the pseudo-inverse -computation (only used with ldMatrix path).} +\item{rcond}{Eigenvalue cutoff for the pseudo-inverse of the known +variants' LD: directions whose ridged eigenvalue is below \code{rcond} +times the largest are dropped. Applied on both routes, so a genotype +panel and the LD matrix computed from it give the same imputation.} -\item{svdTol}{Relative tolerance for filtering small singular values (only -used with genotypeMatrix path).} +\item{svdTol}{Relative tolerance below which singular values of the +standardized genotypes are treated as numerically zero (genotype route +only).} \item{r2Threshold}{R square threshold below which SNPs are filtered from the output.} @@ -49,7 +56,7 @@ output.} } \value{ A list containing filtered and unfiltered results, and filtered LD - matrix (ldMat is NULL when using genotypeMatrix path). + matrix (ldMat is NULL on the genotype route). } \description{ An R port of the RAISS summary-statistic imputation library, described in @@ -63,10 +70,12 @@ Zaitlen N, et al. (2014), "Fast and accurate imputation of summary statistics enhances evidence of functional enrichment", Bioinformatics 30(20):2906-2914. \doi{10.1093/bioinformatics/btu416} -This function can process either a single LD matrix or a list of LD matrices -for different blocks. For a list of matrices, it processes each block -separately and combines the results. Alternatively, it can accept a genotype -matrix X directly, avoiding the need to form the p x p LD matrix (memory and +One call imputes one region, from either of the two kinds of LD reference. +The LD can be given as a square correlation matrix or an +\code{\link{LdMatrix}}, and the imputation then inverts it. Or a genotype +panel from \code{\link{readGenotypes}} can be given instead, and the +imputation then works from the singular value decomposition of its +standardized dosages, never forming the p x p LD matrix (memory and compute savings when n << p). } \examples{ diff --git a/man/readGenotypes.Rd b/man/readGenotypes.Rd index 5beefc705..666705747 100644 --- a/man/readGenotypes.Rd +++ b/man/readGenotypes.Rd @@ -30,18 +30,43 @@ readGenotypes(path, format = NULL, ...) } \arguments{ \item{path}{Character, path to a single self-describing genotype file -(\code{.vcf}, \code{.vcf.gz}, \code{.vcf.bgz}, \code{.bcf} or -\code{.gds}). Omit it when naming the panel by one of the keyword -sources described above.} + (\code{.vcf.gz}, \code{.vcf.bgz}, \code{.gds} or \code{.bgen}). Omit it + when naming the panel by one of the keyword sources described above. -\item{format}{Character, one of "vcf", "plink1", "plink2", "gds". If NULL, -inferred from file extension.} + A VCF must be bgzip-compressed with its tabix index (\code{.tbi}) beside + it, through which its records are read a block at a time; a BCF cannot + be read. Its dosage is its FORMAT/DS when the header declares one, else + the copies of the ALT allele in each GT call, a call with a missing + allele being missing. + + A GDS file is SNPRelate's, whose genotype codes count the first of each + SNP's two alleles (A1), or SeqArray's, read like a VCF: its FORMAT/DS + when it stores one, else its genotype calls. + + A BGEN file of any layout (BGEN 1.1, 1.2 or 1.3), phased or unphased + and of any ploidy, needs its \code{.bgi} index beside it and its sample + ids in the file or in a \code{.sample} file beside it. Its dosage is the + expected count of A1, from 0 to the sample's ploidy. + + A PLINK1 fileset, a \code{.bed} with its \code{.bim} and \code{.fam} + beside it, is read through the PlinkMatrix package: its dosage counts + each variant's A1 allele, the \code{.bim}'s fifth column, a missing + call being missing. Its samples are named by the \code{.fam}'s + individual ids. + + In a VCF, a SeqArray GDS or a BGEN file, A2 is each record's first (REF) + allele, and a record with more than one other allele is read, with a + warning, as one variant per other allele, each counting its own.} + +\item{format}{Character, one of "vcf", "plink1", "plink2", "gds", "bgen". +If NULL, inferred from file extension.} \item{...}{The keyword source arguments described above, plus any further arguments forwarded to the format-specific reader.} \item{vcfArgs}{Optional named list of arguments forwarded to -\code{VariantAnnotation::readVcf} when the source is a VCF.} +\code{VariantAnnotation::readVcf} when a VCF's records are read (its +genotypes are read a block at a time, as they are needed).} \item{plink1Prefix, plink2Prefix}{Character. Stem of a plink1 (\code{.bed}/\code{.bim}/\code{.fam}) or plink2 @@ -63,7 +88,8 @@ resolved and the file it names is read with the matching backend.} \item{genoMeta}{One-file-per-chromosome specification: a path to a \code{#chr,path} meta file, or a named character vector (names = -chromosomes, values = payload paths / prefixes).} +chromosomes, values = payload paths / prefixes). Every file must be of +one format and hold the same samples in the same order.} \item{chroms}{Optional character vector of chromosomes. Only the \code{genoMeta} shards whose chromosome is listed are read; chromosome @@ -73,14 +99,14 @@ labels are compared canonically. Meaningful only with \code{genoMeta}.} A \code{RangedSummarizedExperiment} of variants x samples. } \description{ -Read genotype data (VCF, plink1, plink2 or GDS) as a +Read genotype data (VCF, plink1, plink2, GDS or BGEN) as a \code{RangedSummarizedExperiment}: variants in \code{rowRanges}, samples in \code{colData}, and dosages in a \code{DelayedArray} assay that reads from the file only when something touches it. Nothing is read here beyond the variant and sample metadata. The panel is the same shape a \code{QtlDataset} uses for its genotypes - and the same shape a collection carries as its \code{ldSketch}, so the + and the same shape a collection carries as its \code{ldReference}, so the Bioconductor and tidy surfaces apply throughout: subset it with \code{panel[i, j]}, ask \code{rowRanges()} for the variants, \code{colnames()} for the samples, and hand it to diff --git a/man/refPanel.Rd b/man/refPanel.Rd deleted file mode 100644 index 8ad2b6f50..000000000 --- a/man/refPanel.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/LdData.R -\name{refPanel} -\alias{refPanel} -\alias{refPanel,LdData-method} -\title{Get Reference Panel (data.frame)} -\usage{ -refPanel(x) - -\S4method{refPanel}{LdData}(x) -} -\arguments{ -\item{x}{An \code{LdData}.} -} -\value{ -A data.frame. -} -\description{ -Flatten the variant \code{GRanges} of an \code{LdData} into a - reference-panel data.frame. -} -\examples{ -data(eqtlRegionExample) -X <- eqtlRegionExample$X[, 1:8] -gr <- GenomicRanges::GRanges("22", - IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -ld <- LdData(correlation = cor(X), variants = gr, - blockMetadata = S4Vectors::DataFrame( - chrom = "22", start = 1L, end = 1000L)) -refPanel(ld) -} diff --git a/man/refVariantInfo.Rd b/man/refVariantInfo.Rd index 8c5250db4..ec559bb7e 100644 --- a/man/refVariantInfo.Rd +++ b/man/refVariantInfo.Rd @@ -17,10 +17,11 @@ A data.frame with columns: chrom, id, pos, A2, A1. May also include allele_freq, variance, n_nomiss depending on source. } \description{ -Auto-detects the source type (PLINK2, PLINK1, VCF, GDS, or pre-computed LD -metadata) and returns variant metadata. For PLINK2, opens only the .pvar -file. For PLINK1, reads only the .bim file. For VCF and GDS, loads the full -file and extracts variant info. +Auto-detects the source type (PLINK2, PLINK1, VCF, GDS or BGEN, given +directly or through LD metadata whose rows point at genotype files) and +returns variant metadata. For PLINK2, opens only the .pvar file. For PLINK1, +reads only the .bim file. For VCF, GDS and BGEN, loads the full file and +extracts variant info. } \examples{ meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", diff --git a/man/residualizedGenotypes.Rd b/man/residualizedGenotypes.Rd index f7721debb..7e6e4a609 100644 --- a/man/residualizedGenotypes.Rd +++ b/man/residualizedGenotypes.Rd @@ -14,7 +14,7 @@ residualizedGenotypes(x, ...) region = NULL, cisWindow = NULL, samples = NULL, - residualizationArgs = ResidualizationParam() + residualizationParam = ResidualizationParam() ) } \arguments{ @@ -41,7 +41,7 @@ around the trait; \code{NULL} uses the dataset default.} \item{samples}{Character vector or \code{NULL}. Restrict to these sample IDs; \code{NULL} uses all samples.} -\item{residualizationArgs}{What the data is residualized on, built with +\item{residualizationParam}{What the data is residualized on, built with \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and \code{genotypeCovariates} choose the covariate sets, \code{residualizePhenotype} / \code{residualizeGenotype} turn each diff --git a/man/residualizedPhenotypes.Rd b/man/residualizedPhenotypes.Rd index d99534fa4..28881f8bf 100644 --- a/man/residualizedPhenotypes.Rd +++ b/man/residualizedPhenotypes.Rd @@ -16,7 +16,7 @@ residualizedPhenotypes(x, ...) outlierAction = c("keep", "drop"), outlierPvalThreshold = 0.001, outlierArgs = CovMcdOptions(), - residualizationArgs = ResidualizationParam() + residualizationParam = ResidualizationParam() ) } \arguments{ @@ -51,7 +51,7 @@ robust covariance estimator the outlier rule is built on, supplied with \code{\link{CovMcdOptions}} -- \code{alpha} in particular. Only consulted when \code{outlierAction = "drop"}.} -\item{residualizationArgs}{What the data is residualized on, built with +\item{residualizationParam}{What the data is residualized on, built with \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and \code{genotypeCovariates} choose the covariate sets, \code{residualizePhenotype} / \code{residualizeGenotype} turn each diff --git a/man/resolveWeights.Rd b/man/resolveWeights.Rd index df7285d57..2fd92ce85 100644 --- a/man/resolveWeights.Rd +++ b/man/resolveWeights.Rd @@ -26,7 +26,8 @@ resolveWeights(x, ...) ) } \arguments{ -\item{x}{A \code{TwasWeights} or a \code{FineMappingResult}.} +\item{x}{A \code{TwasWeights}, \code{QtlFineMappingResult} or +\code{GwasFineMappingResult}.} \item{...}{Reserved for future use.} @@ -35,8 +36,8 @@ row of a collection, as elsewhere; each \code{NULL} (default) leaves that part of the tuple unconstrained. Ignored when \code{x} is already a row.} \item{region}{Character (length 1, \code{"chr:start-end"}) or \code{NULL}. -A further selector for a \code{FineMappingResult}, whose rows also carry -a region; \code{NULL} (default) leaves it unconstrained.} +A further selector for a fine-mapping result, whose rows also carry a +region; \code{NULL} (default) leaves it unconstrained.} } \value{ A \code{list} with \code{variantIds} (character) and \code{weights} @@ -47,8 +48,8 @@ Return an aligned \code{(variantIds, weights)} pair from a single weight-source entry, so cTWAS and \code{\link{causalInferencePipeline}} extract weights identically whether the source is a \code{TwasWeights} collection (its learned weight vector) - or a \code{FineMappingResult} one (its topLoci posterior effect). The - selectors pin the single row the weights come from. + or a fine-mapping one (its topLoci posterior effect). The selectors pin + the single row the weights come from. } \examples{ data(twasWeightsExample) diff --git a/man/scadRssWeights.Rd b/man/scadRssWeights.Rd index 76e3077d8..86734f301 100644 --- a/man/scadRssWeights.Rd +++ b/man/scadRssWeights.Rd @@ -6,19 +6,27 @@ \usage{ scadRssWeights( stat, - LD, + ldReference, s = c(0.2, 0.5, 0.9, 1), gamma = 3.7, alpha = 1, selection = c("ldQuadratic", "minFbeta"), + fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) } \arguments{ -\item{stat}{A list with \code{$b} (effect sizes) and \code{$n} (per-variant -sample sizes).} +\item{stat}{A list of summary statistics: \code{n} (per-variant sample +sizes) and the marginal effects as \code{cor} (standardized), \code{z}, +\code{b} with \code{seb}, or \code{b} alone, taken as already +standardized. The engine receives the standardized effects z / sqrt(n), +with n the median of \code{n}.} -\item{LD}{LD correlation matrix R (single matrix, NOT pre-shrunk).} +\item{ldReference}{The LD reference the statistics' variants are matched +to by \code{stat$variantNames}: a genotype panel (see +\code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +\code{\link{LdMatrix}}. A genotype reference's LD is used through its +standardized genotypes, never formed as a matrix.} \item{s}{Numeric vector of LD shrinkage parameters. Default: \code{c(0.2, 0.5, 0.9, 1.0)}.} @@ -30,13 +38,25 @@ sample sizes).} \item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or \code{"minFbeta"}.} -\item{methodArgs}{Options forwarded to \code{penalizedRss}, built -with \code{\link{PenalizedRssOptions}}. A bare list is refused: it -cannot be checked against the engine, so a misspelled option would -be silently ignored.} +\item{fitRetention}{How much of the search is kept as the \code{"fit"} +attribute of the returned weights. \code{"none"} (default) attaches +nothing. \code{"slim"} keeps \code{path}, a table with one row per +candidate (\code{s}, \code{lambda}) giving the solver's objective +\code{fbeta}, \code{loss}, convergence flag \code{conv} and number of +non-zero coefficients \code{nparams}, with \code{selected} marking the +candidate returned. \code{"full"} also keeps \code{beta}, the +candidates' coefficients (variants x candidates, in the rows' order).} + +\item{methodArgs}{Options forwarded to the solver, +\code{\link{penalizedRss}}, built with +\code{\link{PenalizedRssOptions}}. A bare list is refused: it cannot +be checked against the engine, so a misspelled option would be +silently ignored.} } \value{ -A numeric vector of SNP coefficient weights. +A numeric vector of SNP coefficient weights. Unless + \code{fitRetention = "none"}, the search is attached as attribute + \code{"fit"}. } \description{ Fits SCAD-penalized regression on the RSS objective, searching over a @@ -52,8 +72,8 @@ ss <- lapply( stat <- list( b = vapply(ss, `[`, numeric(1), 1L), seb = vapply(ss, `[`, numeric(1), 2L), - n = rep(nrow(X), ncol(X)) + n = rep(nrow(X), ncol(X)), + variantNames = colnames(X) ) -LD <- cor(X) -scadRssWeights(stat, LD) +scadRssWeights(stat, LdMatrix(cor(X))) } diff --git a/man/sdpr.Rd b/man/sdpr.Rd index aa46fb4ac..89963fa5d 100644 --- a/man/sdpr.Rd +++ b/man/sdpr.Rd @@ -70,14 +70,19 @@ arrays in a separate cohort). Default is 1.} } \value{ A list with \code{betaEst} (the estimated effect sizes) and - \code{h2} (the estimated heritability). \code{sdprWeights()} returns - only \code{betaEst}; call this directly when you also want \code{h2}. + \code{h2} (the estimated heritability). } \description{ This function is a wrapper for the SDPR C++ implementation, which performs Markov Chain Monte Carlo (MCMC) for estimating effect sizes and heritability based on summary statistics and reference LD matrices. } +\details{ +Internal: \code{\link{sdprWeights}} is the public interface. It forwards +the arguments below other than \code{bhat}, \code{R} and \code{n} through +\code{\link{SdprOptions}}, and with \code{fitRetention} returns this +function's list as the \code{"fit"} attribute of its weights. +} \note{ This function wraps a rewritten and adapted version of the SDPR C++ implementation. SDPR is described in Zhou G, Zhao H (2021), "A fast and @@ -85,45 +90,4 @@ This function wraps a rewritten and adapted version of the SDPR C++ using summary statistics", PLoS Genetics 17(7): e1009697. \doi{10.1371/journal.pgen.1009697} } -\examples{ -# Generate example data -set.seed(985115) -n <- 350 -p <- 16 -sigmasq_error <- 0.5 -zeroes <- rbinom(p, 1, 0.6) -beta.true <- rnorm(p, 1, sd = 4) -beta.true[zeroes] <- 0 - -X <- cbind(matrix(rnorm(n * p), nrow = n)) -X <- scale(X, center = TRUE, scale = FALSE) -y <- X \%*\% matrix(beta.true, ncol = 1) + rnorm(n, 0, sqrt(sigmasq_error)) -y <- scale(y, center = TRUE, scale = FALSE) - -# Calculate sufficient statistics -XtX <- t(X) \%*\% X -Xty <- t(X) \%*\% y -yty <- t(y) \%*\% y - -# Set the prior -K <- 9 -sigma0 <- c(0.001, .1, .5, 1, 5, 10, 20, 30, .005) -omega0 <- rep(1 / K, K) - -# Calculate summary statistics -b.hat <- sapply(1:p, function(j) { - summary(lm(y ~ X[, j]))$coefficients[-1, 1] -}) -s.hat <- sapply(1:p, function(j) { - summary(lm(y ~ X[, j]))$coefficients[-1, 2] -}) -R.hat <- cor(X) -var_y <- var(y) -sigmasq_init <- 1.5 - -# Run SDPR -out <- sdpr(b.hat, R.hat, n) -# In sample prediction correlations -cor(X \%*\% out$betaEst, y) # - -} +\keyword{internal} diff --git a/man/sdprWeights.Rd b/man/sdprWeights.Rd index d5d7a5378..ea9f66004 100644 --- a/man/sdprWeights.Rd +++ b/man/sdprWeights.Rd @@ -4,22 +4,44 @@ \alias{sdprWeights} \title{Extract weights from sdpr function} \usage{ -sdprWeights(stat, LD, methodArgs = SdprOptions()) +sdprWeights( + stat, + ldReference, + fitRetention = c("none", "slim", "full"), + methodArgs = SdprOptions() +) } \arguments{ -\item{stat}{A list of summary statistics with elements \code{b} (effect -sizes) and \code{n} (per-variant sample sizes).} +\item{stat}{A list of summary statistics: \code{n} (per-variant sample +sizes) and the marginal effects as \code{cor} (standardized), \code{z}, +\code{b} with \code{seb}, or \code{b} alone, taken as already +standardized. The engine receives the standardized effects z / sqrt(n), +with n the median of \code{n}.} + +\item{ldReference}{The LD reference the statistics' variants are matched +to by \code{stat$variantNames}: a genotype panel (see +\code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +\code{\link{LdMatrix}}. A genotype reference's LD is used through its +standardized genotypes and not formed as a matrix, except under +\code{optLlk = 2} when the per-variant sample sizes and arrays are +too varied for its low-rank form to pay.} -\item{LD}{Numeric LD (correlation) matrix aligned to the variants in -\code{stat}.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing, \code{"slim"} and \code{"full"} attach the sampler's +estimates, \code{betaEst} and the heritability \code{h2}. This engine +keeps no trimmable intermediates, so the two retaining levels behave +alike here.} -\item{methodArgs}{Options forwarded to \code{sdpr}, built -with \code{\link{SdprOptions}}. A bare list is refused: it cannot be -checked against the engine, so a misspelled option would be +\item{methodArgs}{Options forwarded to the sampler, \code{\link{sdpr}}, +built with \code{\link{SdprOptions}}. A bare list is refused: it cannot +be checked against the engine, so a misspelled option would be silently ignored.} } \value{ -A numeric vector of the posterior SNP coefficients. +A numeric vector of the posterior SNP coefficients. Unless + \code{fitRetention = "none"}, the sampler's estimates, the heritability + among them, are attached as attribute \code{"fit"}. } \description{ Extract weights from sdpr function @@ -33,8 +55,9 @@ ss <- lapply( stat <- list( b = vapply(ss, `[`, numeric(1), 1L), seb = vapply(ss, `[`, numeric(1), 2L), - n = rep(nrow(X), ncol(X)) + n = rep(nrow(X), ncol(X)), + variantNames = colnames(X) ) -LD <- cor(X) -sdprWeights(stat, LD) +w <- sdprWeights(stat, LdMatrix(cor(X)), fitRetention = "slim") +attr(w, "fit")$h2 } diff --git a/man/show-methods.Rd b/man/show-methods.Rd index 67731abc9..adc2515f7 100644 --- a/man/show-methods.Rd +++ b/man/show-methods.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/GenotypeHandle.R, % R/AnnotationMatrix.R, R/ColocResult.R, R/ColocBoostResult.R, -% R/CtwasResult.R, R/GwasFineMappingResult.R, R/H2Estimate.R, R/LdData.R, -% R/LdEigen.R, R/LdScore.R, R/MashPrior.R, R/QtlDataset.R, +% R/CtwasResult.R, R/GwasFineMappingResult.R, R/H2Estimate.R, R/LdEigen.R, +% R/LdScore.R, R/MashPrior.R, R/qtlSumStats.R, R/QtlDataset.R, % R/MultiStudyQtlDataset.R, R/QtlFineMappingResult.R, R/gwasSumStats.R, -% R/qtlSumStats.R, R/fineMappingRow.R, R/twasWeights.R, R/twasWeightsRow.R +% R/fineMappingRow.R, R/twasWeights.R, R/twasWeightsRow.R \name{show-methods} \alias{show-methods} \alias{show,GenotypeHandle-method} @@ -14,15 +14,14 @@ \alias{show,CtwasResult-method} \alias{show,GwasFineMappingResult-method} \alias{show,H2Estimate-method} -\alias{show,LdData-method} \alias{show,LdEigen-method} \alias{show,LdScore-method} \alias{show,MashPrior-method} +\alias{show,QtlSumStats-method} \alias{show,QtlDataset-method} \alias{show,MultiStudyQtlDataset-method} \alias{show,QtlFineMappingResult-method} \alias{show,GwasSumStats-method} -\alias{show,QtlSumStats-method} \alias{show,FineMappingRow-method} \alias{show,TwasWeights-method} \alias{show,TwasWeightsRow-method} @@ -42,14 +41,14 @@ \S4method{show}{H2Estimate}(object) -\S4method{show}{LdData}(object) - \S4method{show}{LdEigen}(object) \S4method{show}{LdScore}(object) \S4method{show}{MashPrior}(object) +\S4method{show}{QtlSumStats}(object) + \S4method{show}{QtlDataset}(object) \S4method{show}{MultiStudyQtlDataset}(object) @@ -58,8 +57,6 @@ \S4method{show}{GwasSumStats}(object) -\S4method{show}{QtlSumStats}(object) - \S4method{show}{FineMappingRow}(object) \S4method{show}{TwasWeights}(object) diff --git a/man/shrinkLd.Rd b/man/shrinkLd.Rd deleted file mode 100644 index f8cd5f8c6..000000000 --- a/man/shrinkLd.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/h2EstimationWrappers.R -\name{shrinkLd} -\alias{shrinkLd} -\title{Apply LD Shrinkage} -\usage{ -shrinkLd(R, nSamples, shrinkageType = "wen_stephens", geneticMap = NULL) -} -\arguments{ -\item{R}{Numeric matrix, sample LD correlation matrix.} - -\item{nSamples}{Integer, reference panel sample size.} - -\item{shrinkageType}{Character, one of "wen_stephens", "constant".} - -\item{geneticMap}{Numeric vector, genetic map positions for SNPs in R.} -} -\value{ -Shrunk LD correlation matrix. -} -\description{ -Apply shrinkage to sample LD matrix to reduce noise from finite - reference panel size, following Wen & Stephens (2010). -} -\keyword{internal} diff --git a/man/slalom.Rd b/man/slalom.Rd index dac3f42ac..4ec1e70e9 100644 --- a/man/slalom.Rd +++ b/man/slalom.Rd @@ -21,8 +21,9 @@ slalom( \item{R}{Square LD correlation matrix. Provide either \code{R} or \code{X}.} -\item{X}{Genotype matrix (samples x SNPs). If provided, LD is computed via -\code{computeLd(X)}.} +\item{X}{Genotype matrix (samples x SNPs). With \code{ldMethod = "sample"} +only the lead variant's LD column is computed from it; any other +\code{ldMethod} computes the LD matrix via \code{computeLd(X)}.} \item{standardError}{Optional numeric vector of standard errors corresponding to each z-score. If not provided, a default value of 1 is assumed for all @@ -41,9 +42,9 @@ for prediction. Default is 0.6.} "pvalue" or "abf", with default "pvalue".} \item{ldMethod}{Character string specifying the LD computation method when -\code{X} is provided. Passed to \code{computeLd}. One of \code{"sample"} -(default), \code{"population"}, or \code{"gcta"}. Ignored when \code{R} is -provided directly.} +\code{X} is provided: \code{"sample"} (default), which uses the +genotypes directly, or \code{"population"} or \code{"gcta"}, which go +through \code{computeLd}. Ignored when \code{R} is provided directly.} } \value{ A list containing the annotated LD matrix with ABF results, credible @@ -57,7 +58,9 @@ p-values from z-scores assuming a two-sided standard normal distribution. } \details{ Provide either an LD correlation matrix \code{R} or a genotype matrix -\code{X} (from which LD is derived automatically via \code{computeLd}). +\code{X}. SLALOM needs only the lead variant's LD with the others, so with +\code{ldMethod = "sample"} it computes that one column from the genotypes +and never forms the LD matrix. } \examples{ # Simulate z-scores and an LD matrix from a reference panel, then screen diff --git a/man/snpIdx.Rd b/man/snpIdx.Rd deleted file mode 100644 index 3965937fa..000000000 --- a/man/snpIdx.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/LdData.R -\name{snpIdx} -\alias{snpIdx} -\alias{snpIdx,LdData-method} -\title{Get SNP Indices} -\usage{ -snpIdx(x) - -\S4method{snpIdx}{LdData}(x) -} -\arguments{ -\item{x}{An \code{LdData}.} -} -\value{ -Integer vector or NULL. -} -\description{ -Return the integer indices into the handle's snpInfo carried by - an \code{LdData}. -} -\examples{ -data(eqtlRegionExample) -X <- eqtlRegionExample$X[, 1:8] -gr <- GenomicRanges::GRanges("22", - IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -ld <- LdData(correlation = cor(X), variants = gr, - blockMetadata = S4Vectors::DataFrame( - chrom = "22", start = 1L, end = 1000L)) -snpIdx(ld) -} diff --git a/man/sumStats.Rd b/man/sumStats.Rd index d3d0d292d..d4db4bd91 100644 --- a/man/sumStats.Rd +++ b/man/sumStats.Rd @@ -1,16 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/MultiStudyQtlDataset.R, -% R/qtlSumStats.R +% Please edit documentation in R/AllGenerics.R, R/qtlSumStats.R, +% R/MultiStudyQtlDataset.R \name{sumStats} \alias{sumStats} -\alias{sumStats,MultiStudyQtlDataset-method} \alias{sumStats,QtlSumStats-method} +\alias{sumStats,MultiStudyQtlDataset-method} \title{Get a Single Summary-Statistic Entry or Embedded Collection} \usage{ sumStats(x, ...) -\S4method{sumStats}{MultiStudyQtlDataset}(x) - \S4method{sumStats}{QtlSumStats}( x, studyName = NULL, @@ -19,6 +17,8 @@ sumStats(x, ...) annotateSignificance = NULL, ranges = NULL ) + +\S4method{sumStats}{MultiStudyQtlDataset}(x) } \arguments{ \item{x}{A \code{GwasSumStats}, \code{QtlSumStats}, or diff --git a/man/sumStatsDataFrame.Rd b/man/sumStatsDataFrame.Rd index d768793d2..29fca09e3 100644 --- a/man/sumStatsDataFrame.Rd +++ b/man/sumStatsDataFrame.Rd @@ -1,29 +1,29 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/gwasSumStats.R, R/qtlSumStats.R -\name{as.data.frame,GwasSumStats-method} +% Please edit documentation in R/qtlSumStats.R, R/gwasSumStats.R +\name{as.data.frame,QtlSumStats-method} +\alias{as.data.frame,QtlSumStats-method} \alias{as.data.frame,GwasSumStats-method} \alias{sumStatsDataFrame} -\alias{as.data.frame,QtlSumStats-method} \title{Coerce Summary Statistics to a Data Frame} \usage{ -\S4method{as.data.frame}{GwasSumStats}( +\S4method{as.data.frame}{QtlSumStats}( x, row.names = NULL, optional = FALSE, studyName = NULL, + context = NULL, + trait = NULL, require = character(0), derive = c("none", "zFromBetaSe"), keepChrPrefix = TRUE, ... ) -\S4method{as.data.frame}{QtlSumStats}( +\S4method{as.data.frame}{GwasSumStats}( x, row.names = NULL, optional = FALSE, studyName = NULL, - context = NULL, - trait = NULL, require = character(0), derive = c("none", "zFromBetaSe"), keepChrPrefix = TRUE, @@ -39,6 +39,12 @@ \item{studyName}{Character (length 1) or \code{NULL}. Restrict the selection to this study; \code{NULL} matches all studies.} +\item{context}{Character (length 1) or \code{NULL}. Restrict the selection to +this context; \code{NULL} matches all contexts (\code{QtlSumStats} only).} + +\item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to +this trait; \code{NULL} matches all traits (\code{QtlSumStats} only).} + \item{require}{Character vector. Columns that must be present (derived if necessary) in the returned summary-statistics data frame.} @@ -49,12 +55,6 @@ ones; \code{"zFromBetaSe"} recovers \code{z} from \code{beta}/\code{se}.} chromosome names; otherwise strip it.} \item{...}{Unused.} - -\item{context}{Character (length 1) or \code{NULL}. Restrict the selection to -this context; \code{NULL} matches all contexts (\code{QtlSumStats} only).} - -\item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to -this trait; \code{NULL} matches all traits (\code{QtlSumStats} only).} } \value{ A \code{data.frame}. diff --git a/man/summaryStatsQc.Rd b/man/summaryStatsQc.Rd index 1de434739..d291b52b9 100644 --- a/man/summaryStatsQc.Rd +++ b/man/summaryStatsQc.Rd @@ -6,24 +6,24 @@ \usage{ summaryStatsQc( sumstats, - sumstatsFilterArgs = SumstatsFilterParam(), + sumstatsFilterParam = SumstatsFilterParam(), panelFilterParam = PanelFilterParam(), keepVariants = NULL, skipRegion = NULL, - signalScreenArgs = SignalScreenParam(), + signalScreenParam = SignalScreenParam(), ldMismatchQcMethod = c("none", "slalom", "dentist"), alleleFlipKriging = FALSE, effectiveN = TRUE, impute = FALSE, - imputeArgs = RaissParam(), + raissParam = RaissParam(), matchMinProp = 0, - sumstatsCleaningArgs = SumstatsCleaningParam() + sumstatsCleaningParam = SumstatsCleaningParam() ) } \arguments{ \item{sumstats}{A \code{QtlSumStats} or \code{GwasSumStats} collection.} -\item{sumstatsFilterArgs}{Row filters applied to the summary statistics +\item{sumstatsFilterParam}{Row filters applied to the summary statistics themselves, built with \code{\link{SumstatsFilterParam}}: \code{removeIndels} drops indels during panel harmonization, \code{removeStrandAmbiguous} drops A/T and C/G variants, @@ -35,8 +35,10 @@ disables it).} \item{panelFilterParam}{LD-reference-panel filters, built with \code{\link{PanelFilterParam}}. \code{macCutoff} is converted to a MAF equivalent using \code{macCutoff / (2 * nSamples)} and the stricter of - it and \code{mafCutoff} applies; \code{imissCutoff} is a per-variant - missingness ceiling. See the panel-filters section below. + it and \code{mafCutoff} applies; \code{nSamples} counts the panel's real + samples, which for a stochastic LD sketch are those its \code{.afreq} + records rather than its pseudo-samples. \code{imissCutoff} is a + per-variant missingness ceiling. See the panel-filters section below. \code{mafCutoff} is the one setting that reaches past the panel: it is measured wherever it can be, against the summary statistics' own @@ -50,7 +52,7 @@ retain prior to harmonization.} \item{skipRegion}{Optional character vector of \code{"chr:start-end"} strings, or a \code{GRanges}, of regions to drop.} -\item{signalScreenArgs}{Whether to skip an entry before fitting it, +\item{signalScreenParam}{Whether to skip an entry before fitting it, built with \code{\link{SignalScreenParam}} --- the same bundle \code{\link{fineMappingPipeline}} and \code{\link{colocboostPipeline}} @@ -87,15 +89,15 @@ records the setting and each entry's \code{nSource} is one of \code{"effective"}, \code{"column"}, \code{"total"}, or \code{NA}.} \item{impute}{Logical (length 1). Run RAISS imputation against the -\code{ldSketch}. Default \code{FALSE}. (Note: RAISS against the sketch is -not yet fully wired for the new path; the option is accepted but currently -emits a warning and is skipped.)} +\code{ldReference}'s genotype panel as the last QC step, adding z-scores +for panel variants the input lacks (see \code{raissParam}). The audit +records how many variants were imputed. Default \code{FALSE}.} -\item{imputeArgs}{RAISS settings, built with \code{\link{RaissParam}}. +\item{raissParam}{RAISS settings, built with \code{\link{RaissParam}}. A bare list is refused, since it cannot be checked. RAISS imputation scopes its reference panel to the analysis-region window - (so a per-chromosome / genome-wide \code{ldSketch} does not materialize + (so a per-chromosome / genome-wide \code{ldReference} does not materialize its full dosage); \code{flank} widens that window by the given number of base pairs on each side to retain LD context for edge variants. @@ -112,7 +114,7 @@ emits a warning and is skipped.)} the panel handed to RAISS holds nothing below those. Use them to impute only common variants from a panel deliberately kept wider than that --- e.g. \code{mafCutoff = 0.001} with - \code{imputeArgs = RaissParam(mafCutoff = 0.01)}. A variant present in + \code{raissParam = RaissParam(mafCutoff = 0.01)}. A variant present in the sumstats is never dropped here: RAISS derives its LD basis from those same panel rows. @@ -122,12 +124,12 @@ emits a warning and is skipped.)} \item{matchMinProp}{Minimum proportion of LD panel variants that must be matched by the sumstats; default 0.} -\item{sumstatsCleaningArgs}{What makes a row a well-formed record, built with -\code{\link{SumstatsCleaningParam}}: \code{coerceNumeric}, +\item{sumstatsCleaningParam}{What makes a row a well-formed record, built +with \code{\link{SumstatsCleaningParam}}: \code{coerceNumeric}, \code{normalizeChr} / \code{dropNonstandardChr}, \code{dropMissData}, \code{dropPOutOfRange}, \code{clampSmallP} / \code{smallPFloor}, \code{dropZeroEffect} and \code{dropNonpositiveSe}. Applied before any -filter or screen. Distinct from \code{sumstatsFilter}, which applies +filter or screen. Distinct from \code{sumstatsFilterParam}, which applies quality thresholds to rows that are already well formed.} } \value{ @@ -141,10 +143,11 @@ with out-of-range / zero P, BETA == 0, SE <= 0, NA in vital columns; clamp tiny P; normalize CHR; coerce signed columns to numeric), variant-content filters (MAF / INFO / N) via \code{.applyContentFilters}, optional \code{skipRegion} drop, optional PIP screen, panel-vs-sumstats allele -harmonization against the \code{ldSketch} via \code{harmonizeAlleles} (which -handles indels, strand-ambiguous variants, sign / strand flips, and duplicate -drops in a single sweep), optional SLALOM/DENTIST LD-mismatch QC, and -optional RAISS imputation. No Bioconductor genome / dbSNP packages required. +harmonization against the \code{ldReference} via \code{harmonizeAlleles} +(which handles indels, strand-ambiguous variants, sign / strand flips, and +duplicate drops in a single sweep), optional SLALOM/DENTIST LD-mismatch QC, +and optional RAISS imputation. No Bioconductor genome / dbSNP packages +required. } \details{ The returned collection has its \code{qcInfo} slot populated with a per-entry diff --git a/man/susieAshRssWeights.Rd b/man/susieAshRssWeights.Rd index 52ba85684..e1ea4b109 100644 --- a/man/susieAshRssWeights.Rd +++ b/man/susieAshRssWeights.Rd @@ -6,16 +6,19 @@ \usage{ susieAshRssWeights( stat, - LD, + ldReference = NULL, susieAshRssFit = NULL, fitRetention = c("slim", "none", "full") ) } \arguments{ \item{stat}{List with components \code{z} (z-scores), \code{n} (sample -sizes).} +sizes) and, to check against an \code{ldReference}, \code{variantNames}.} -\item{LD}{LD correlation matrix.} +\item{ldReference}{Optional LD reference: a genotype panel, a +\code{\link{GenotypeMixture}} or an \code{\link{LdMatrix}}. The fit is +checked against the statistics' variants and, with a reference, those +variants must also be in it. No LD is read.} \item{susieAshRssFit}{Optional pre-fitted SuSiE-ASH-RSS object.} @@ -45,5 +48,5 @@ stat <- list( n = rep(nrow(X), ncol(X))) LD <- cor(X) fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) -susieAshRssWeights(stat, LD, susieAshRssFit = fit) +susieAshRssWeights(stat, susieAshRssFit = fit) } diff --git a/man/susieFit.Rd b/man/susieFit.Rd index c549a0a8f..977365664 100644 --- a/man/susieFit.Rd +++ b/man/susieFit.Rd @@ -21,7 +21,8 @@ susieFit(x, ...) \S4method{susieFit}{FineMappingRow}(x) } \arguments{ -\item{x}{A \code{FineMappingRow} or \code{FineMappingResult}.} +\item{x}{A \code{FineMappingRow}, \code{QtlFineMappingResult} or +\code{GwasFineMappingResult}.} \item{...}{Class-specific selection arguments.} diff --git a/man/susieInfRssWeights.Rd b/man/susieInfRssWeights.Rd index 35276cecf..b091bd6e4 100644 --- a/man/susieInfRssWeights.Rd +++ b/man/susieInfRssWeights.Rd @@ -6,16 +6,19 @@ \usage{ susieInfRssWeights( stat, - LD, + ldReference = NULL, susieInfRssFit = NULL, fitRetention = c("slim", "none", "full") ) } \arguments{ \item{stat}{List with components \code{z} (z-scores), \code{n} (sample -sizes).} +sizes) and, to check against an \code{ldReference}, \code{variantNames}.} -\item{LD}{LD correlation matrix.} +\item{ldReference}{Optional LD reference: a genotype panel, a +\code{\link{GenotypeMixture}} or an \code{\link{LdMatrix}}. The fit is +checked against the statistics' variants and, with a reference, those +variants must also be in it. No LD is read.} \item{susieInfRssFit}{Optional pre-fitted SuSiE-inf-RSS object.} @@ -45,5 +48,5 @@ stat <- list( n = rep(nrow(X), ncol(X))) LD <- cor(X) fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) -susieInfRssWeights(stat, LD, susieInfRssFit = fit) +susieInfRssWeights(stat, susieInfRssFit = fit) } diff --git a/man/susieResult.Rd b/man/susieResult.Rd index c2ed60ebd..7959846f8 100644 --- a/man/susieResult.Rd +++ b/man/susieResult.Rd @@ -9,17 +9,18 @@ susieResult(conData) \arguments{ \item{conData}{List. The method-layer entry from a finemapping pipeline result, expected to carry \code{$finemappingEntry} as a -\code{FineMappingRow} object.} +\code{FineMappingRow} or a single-row fine-mapping result.} } \value{ The trimmed fit (a list with \code{pip}, \code{sets}, etc.) or NULL. } \description{ -Returns the trimmed model fit underlying \code{con_data$finemappingEntry} (a -\code{FineMappingRow} S4 object), or NULL if no fine-mapping entry is -attached. +Returns the trimmed model fit underlying \code{conData$finemappingEntry} (a +\code{FineMappingRow}, or a single-row fine-mapping result), or NULL if no +fine-mapping entry is attached. } \examples{ -data(qtlSumStatsExample) -susieResult(qtlSumStatsExample) +data(qtlFineMappingExample) +fit <- susieResult(list(finemappingEntry = qtlFineMappingExample[1])) +head(fit$pip) } diff --git a/man/susieRssWeights.Rd b/man/susieRssWeights.Rd index c54884361..a4a18d294 100644 --- a/man/susieRssWeights.Rd +++ b/man/susieRssWeights.Rd @@ -6,16 +6,19 @@ \usage{ susieRssWeights( stat, - LD, + ldReference = NULL, susieRssFit = NULL, fitRetention = c("slim", "none", "full") ) } \arguments{ \item{stat}{List with components \code{z} (z-scores), \code{n} (sample -sizes).} +sizes) and, to check against an \code{ldReference}, \code{variantNames}.} -\item{LD}{LD correlation matrix.} +\item{ldReference}{Optional LD reference: a genotype panel, a +\code{\link{GenotypeMixture}} or an \code{\link{LdMatrix}}. The fit is +checked against the statistics' variants and, with a reference, those +variants must also be in it. No LD is read.} \item{susieRssFit}{A fitted SuSiE-RSS object. Required: these wrappers extract weights and never run fine-mapping themselves.} @@ -46,5 +49,5 @@ stat <- list( n = rep(nrow(X), ncol(X))) LD <- cor(X) fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) -susieRssWeights(stat, LD, susieRssFit = fit) +susieRssWeights(stat, susieRssFit = fit) } diff --git a/man/topLoci.Rd b/man/topLoci.Rd index 41f7eaa23..0673afb09 100644 --- a/man/topLoci.Rd +++ b/man/topLoci.Rd @@ -20,7 +20,7 @@ topLoci(x, signalCutoff = 0.025, ...) ) } \arguments{ -\item{x}{A \code{FineMappingRow} or \code{FineMappingResult}.} +\item{x}{A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}.} \item{signalCutoff}{Numeric (length 1). Drop rows where \code{pip <= signalCutoff}. Default \code{0.025}. Use \code{signalCutoff = 0} to keep diff --git a/man/traitNames.Rd b/man/traitNames.Rd index c25030fa9..6f87383af 100644 --- a/man/traitNames.Rd +++ b/man/traitNames.Rd @@ -1,14 +1,14 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/GwasFineMappingResult.R, -% R/H2Estimate.R, R/QtlFineMappingResult.R, R/SldscData.R, R/qtlSumStats.R, +% R/H2Estimate.R, R/qtlSumStats.R, R/QtlFineMappingResult.R, R/SldscData.R, % R/twasWeights.R \name{traitNames} \alias{traitNames} \alias{traitNames,GwasFineMappingResult-method} \alias{traitNames,H2Estimate-method} +\alias{traitNames,QtlSumStats-method} \alias{traitNames,QtlFineMappingResult-method} \alias{traitNames,SldscData-method} -\alias{traitNames,QtlSumStats-method} \alias{traitNames,TwasWeights-method} \title{Get Unique Trait Names} \usage{ @@ -18,12 +18,12 @@ traitNames(x) \S4method{traitNames}{H2Estimate}(x) +\S4method{traitNames}{QtlSumStats}(x) + \S4method{traitNames}{QtlFineMappingResult}(x) \S4method{traitNames}{SldscData}(x) -\S4method{traitNames}{QtlSumStats}(x) - \S4method{traitNames}{TwasWeights}(x) } \arguments{ diff --git a/man/traitPosition.Rd b/man/traitPosition.Rd index 18ea2152b..933a0b833 100644 --- a/man/traitPosition.Rd +++ b/man/traitPosition.Rd @@ -1,11 +1,11 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, R/QtlDataset.R, -% R/qtlSumStats.R, R/twasWeights.R +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, +% R/qtlSumStats.R, R/QtlDataset.R, R/twasWeights.R \name{traitPosition} \alias{traitPosition} \alias{traitPosition,FineMappingResultBase-method} -\alias{traitPosition,QtlDataset-method} \alias{traitPosition,QtlSumStats-method} +\alias{traitPosition,QtlDataset-method} \alias{traitPosition,TwasWeights-method} \title{Get Per-Row Trait Positions} \usage{ @@ -13,10 +13,10 @@ traitPosition(x, ...) \S4method{traitPosition}{FineMappingResultBase}(x) -\S4method{traitPosition}{QtlDataset}(x, traitId = NULL) - \S4method{traitPosition}{QtlSumStats}(x, traitId = NULL) +\S4method{traitPosition}{QtlDataset}(x, traitId = NULL) + \S4method{traitPosition}{TwasWeights}(x) } \arguments{ @@ -35,8 +35,8 @@ A \code{GRanges} with one range per row of \code{x}, or an empty Return the molecular feature's OWN genomic coordinates (the gene / peak range; TSS = \code{start()}) for each row of a per-tuple collection, as a \code{GRanges} with one range per row. Distinct from - \code{\link{genomicRegion}} (the fine-mapping window for a - \code{FineMappingResult}): the true trait position cannot be inferred from + \code{\link{genomicRegion}} (the window a fine-mapping result was fit + over): the true trait position cannot be inferred from summary statistics, so it is threaded from the QtlDataset \code{rowRanges} or an explicit QtlSumStats trait-position and carried as provenance onto \code{QtlFineMappingResult} and \code{TwasWeights}. diff --git a/man/twasWeightsPipeline.Rd b/man/twasWeightsPipeline.Rd index a63e090d9..4ee091162 100644 --- a/man/twasWeightsPipeline.Rd +++ b/man/twasWeightsPipeline.Rd @@ -22,14 +22,13 @@ twasWeightsPipeline(data, ...) fineMappingResult = NULL, twasWeights = NULL, mashPrior = NULL, - crossValidationArgs = CrossValidationParam(), - fitFullData = TRUE, - ensembleArgs = EnsembleParam(), + crossValidationParam = CrossValidationParam(), + ensembleParam = EnsembleParam(), estimatePi = TRUE, usePCA = FALSE, nPCs = 10L, fitRetention = c("slim", "none", "full"), - residualizationArgs = ResidualizationParam(), + residualizationParam = ResidualizationParam(), weightsDataType = NULL, naAction = c("drop", "impute"), verbose = 1, @@ -48,7 +47,7 @@ twasWeightsPipeline(data, ...) weightsDataType = NULL, verbose = 1L, panelFilterParam = PanelFilterParam(), - crossValidationArgs = CrossValidationParam() + crossValidationParam = CrossValidationParam() ) \S4method{twasWeightsPipeline}{MultiStudyQtlDataset}( @@ -65,15 +64,16 @@ twasWeightsPipeline(data, ...) fineMappingResult = NULL, twasWeights = NULL, mashPrior = NULL, - fitFullData = TRUE, estimatePi = TRUE, + usePCA = FALSE, + nPCs = 10L, fitRetention = c("slim", "none", "full"), weightsDataType = NULL, naAction = c("drop", "impute"), verbose = 1, - residualizationArgs = ResidualizationParam(), - crossValidationArgs = CrossValidationParam(), - ensembleArgs = EnsembleParam(), + residualizationParam = ResidualizationParam(), + crossValidationParam = CrossValidationParam(), + ensembleParam = EnsembleParam(), seed = NULL ) } @@ -87,16 +87,27 @@ embedded \code{QtlSumStats}, then rbinds the results.} \item{methods}{A character vector of short method names, a preset string (\code{"default"} or \code{"fastDefault"}), or a named list of -\code{_weights = args} entries. For QtlSumStats / GwasSumStats -inputs the default switches to the RSS preset (\code{c("susieRss", -"susieInfRss", "lassosumRss", "prsCs", "sdpr")}).} - -\item{contexts}{Optional character vector of contexts to restrict processing -to (QtlDataset / QtlSumStats inputs). Default \code{NULL} (use all -contexts).} - -\item{traitId}{Optional character vector of trait identifiers to restrict -processing to (QtlDataset / QtlSumStats inputs). Default \code{NULL}.} +\code{_weights = args} entries. For QtlSumStats input the +default is \code{c("lasso", "prsCs", "dprGibbs")}, which there run +lassosum, PRS-CS and SDPR; the fine-mapping methods are not in it, and +are requested by name together with a \code{fineMappingResult}.} + +\item{contexts}{Optional context selection; \code{NULL} (the default) uses +every context. A character vector applies to every study: a context no +study has is an error, and one only some studies lack is skipped for +those, with a warning. A list keyed by study name picks each study's +contexts separately (\code{list(A = "liver")}); studies it does not name +keep all of theirs.} + +\item{traitId}{Optional trait selection; \code{NULL} (the default) uses +every trait, or those overlapping \code{region} when one is given. A +character vector applies to every study. A list keyed by study name +picks each study's traits separately (\code{list(A = "ENSG1")}), and a +study's entry may itself be a list keyed by context +(\code{list(A = list(brain = "ENSG1"))}). Studies and contexts the list +does not name keep all of their traits. A joint fit spanning a study's +contexts uses every trait selected in any of them, minus the (context, +trait) pairs a per-context entry leaves out.} \item{region}{Optional variant window for QtlDataset trait selection: a \code{GRanges}, a \code{"chr:start-end"} string, or a one-row data.frame @@ -124,15 +135,21 @@ flat \code{cvResult} data frame (one row per region). \code{TRUE} concatenates the ranges' genotypes into one joint fit. Ignored for a single-range / cis request.} -\item{jointSpecification}{Optional joint-fit specification (NULL by default). -When NULL, the pipeline runs the implicit multi-trait / multi-context -mr.mash branches as before. When non-NULL, the argument is parsed and -validated via the joint-spec grammar documented under -\code{parseJointSpecification}; the per-spec axis dispatcher implementation -is in progress and a non-NULL value currently errors with an informative -message.} - -\item{fineMappingResult}{Optional \code{FineMappingResult}. When supplied, +\item{jointSpecification}{Optional joint-fit specification saying which +axes \code{mrmash} fits across. When NULL (the default) it runs its +implicit multi-trait / multi-context fit. Otherwise give a character +vector of axes (one spec) or a list of specs. A spec is a character +vector drawn from \code{"study"}, \code{"context"} and \code{"trait"}, +or \code{list(axes = , scope = )}, where \code{scope} +(keys \code{study}, \code{context}, \code{trait}) limits the fit to the +listed values, each of which must exist in \code{data}. A list-form +spec always goes inside the outer list, even on its own. Other methods +run per (study, context, trait) as usual. The \code{"study"} axis needs +summary statistics: it is rejected on a \code{QtlDataset}, and on a +\code{MultiStudyQtlDataset} only the summary-statistics studies take +part.} + +\item{fineMappingResult}{Optional \code{QtlFineMappingResult}. When supplied, its SuSiE / SuSiE-inf / SuSiE-ash trimmed fits for the matching (study, context, trait) tuples are injected into \code{learnTwasWeights} via \code{fittedModels} so SuSiE-family weight methods reuse the prior fit @@ -151,11 +168,13 @@ produce one fit jointly across multiple \code{(context, trait)} columns.} \item{mashPrior}{Optional \code{\link{MashPrior}} (or coercible) supplying data-driven prior matrices for mr.mash weight methods; \code{NULL} to skip.} -\item{crossValidationArgs}{Cross-validation settings, built with +\item{crossValidationParam}{Cross-validation settings, built with \code{\link{CrossValidationParam}}: \code{folds} (default \code{0}, no CV), \code{threads}, \code{samplePartition}, \code{maxVariants} (cap - on the CV design matrix) and \code{weightMethods} (which methods to - cross-validate; unset means every method with non-zero weights). + on the CV design matrix), \code{weightMethods} (which methods to + cross-validate; unset means every method with non-zero weights) and + \code{fitFullData} (\code{FALSE} keeps only the cross-validation + results; default \code{TRUE}). \code{folds} defaulted to \code{5} before, while \code{\link{fineMappingPipeline}}'s defaulted to \code{0}. The two now @@ -165,21 +184,20 @@ data-driven prior matrices for mr.mash weight methods; \code{NULL} to skip.} \code{QtlSumStats} input; that method \strong{errors} if it is set rather than returning results that were never cross-validated.} -\item{fitFullData}{Logical. If \code{TRUE}, fit final weights on the full -data after cross-validation. Default \code{TRUE}.} - -\item{ensembleArgs}{SR-TWAS ensemble settings, built with +\item{ensembleParam}{SR-TWAS ensemble settings, built with \code{\link{EnsembleParam}}: \code{enabled} (default \code{FALSE}), \code{r2Threshold}, \code{solver} and \code{alpha}. Stacking reads out-of-fold predictions, so \code{enabled = TRUE} requires -\code{crossValidation} with \code{folds >= 2} and is an error +\code{crossValidationParam} with \code{folds >= 2} and is an error otherwise --- it previously returned a result quietly missing its ensemble row.} \item{estimatePi}{If TRUE, estimate spike-and-slab sparsity from mr.ash before BGLR / qgg spike-and-slab methods that consume it.} -\item{usePCA}{Logical (length 1). \code{QtlDataset} only. When +\item{usePCA}{Logical (length 1). Individual-level data only: a +\code{QtlDataset}, or the \code{QtlDataset} components of a +\code{MultiStudyQtlDataset}. When \code{TRUE}, each multi-trait context is additionally PCA-reduced and weights are fitted for each top principal component \emph{as a trait} (\code{topPC1}, \code{topPC2}, ...), alongside the per-trait rows. The @@ -198,13 +216,14 @@ components fitted per context when \code{usePCA = TRUE} (default takes, which has no \code{"none"} --- its \code{susieFit} slot is part of the returned object's contract. - \code{"full"} is honoured only by the mr.mash engines, the only ones - that distinguish the two retaining levels; every other method keeps its - fit whole or not at all. Requesting \code{"full"} for a run where no - method can honour it is an error, and a mixed run warns rather than - dropping it in silence.} + \code{"full"} is honoured by the mr.mash engines and, on summary + statistics, by \code{lasso}, \code{scad}, \code{mcp} and + \code{l0learn}, whose full fit also keeps every candidate's + coefficients; every other method keeps its fit whole or not at all. + Requesting \code{"full"} for a run where no method can honour it is an + error, and a mixed run warns rather than dropping it in silence.} -\item{residualizationArgs}{Covariate residualization settings, built with +\item{residualizationParam}{Covariate residualization settings, built with \code{\link{ResidualizationParam}} and forwarded to \code{\link{residualizedPhenotypes}} / \code{\link{residualizedGenotypes}}: \code{phenotypeCovariates} and @@ -216,7 +235,8 @@ components fitted per context when \code{usePCA = TRUE} (default \code{QtlDataset} / \code{MultiStudyQtlDataset} input only. A \code{QtlSumStats} run has no covariates to regress out, so the bundle is \strong{ignored} there rather than refused --- unlike - \code{crossValidation}, which errors. Residualization is on by default, + \code{crossValidationParam}, which errors. Residualization is on by + default, so refusing a non-default value would reject the default bundle; CV is off by default, so a non-default value there is an explicit request for something the input cannot do.} @@ -245,8 +265,8 @@ above.} } \value{ A \code{\link{TwasWeights}} collection keyed by \code{(study, - context, trait, method)}. The \code{ldSketch} slot is \code{NULL} for - individual-level fits and equals the input's \code{ldSketch} for + context, trait, method)}. The \code{ldReference} slot is \code{NULL} for + individual-level fits and equals the input's \code{ldReference} for RSS-derived fits. } \description{ @@ -255,8 +275,9 @@ Accepts: \itemize{ \item a \code{\link{QtlDataset}} for individual-level cohort fits; \item a \code{\link{QtlSumStats}} for per-trait RSS fits; - \item a \code{\link{GwasSumStats}} for per-LD-block PRS-CS-style fits - from GWAS summary statistics. + \item a \code{\link{MultiStudyQtlDataset}}, whose individual-level + studies and optional summary-statistic studies are each fitted, + then combined. } } \details{ @@ -265,49 +286,51 @@ Method-restriction rules (enforced): \item \code{mr.mash}, \code{mvsusie} follow the multi-trait / multi-context rules of the fine-mapping \code{mvsusie} family (require at least two traits OR at least two contexts). - \item RSS-only methods (PRS-CS, \code{lassosumRss}, SDPR, all - \code{*Rss} variants) are rejected on \code{QtlDataset} - input. - \item Individual-level-only methods (BGLR and CRAN-stable qgg: - \code{bayes_a/b/c/l/n/r}, \code{b_lasso}, \code{dpr_*}) are - rejected on \code{QtlSumStats} / \code{GwasSumStats} input. + \item \code{prsCs} runs only on summary statistics, so it is rejected + on \code{QtlDataset} input. + \item \code{enet}, \code{dprVb}, \code{dprAdaptiveGibbs} and the + Bayesian alphabet (\code{bayesA}, \code{bayesB}, \code{bayesC}, + \code{bayesL}, \code{bayesN}, \code{bayesR}, \code{bLasso}) run + only on individual-level data, so they are rejected on + \code{QtlSumStats} input. } -Both \code{QtlSumStats} and \code{GwasSumStats} inputs must have been QC'd -via \code{\link{summaryStatsQc}} first; otherwise an error is raised pointing +A \code{QtlSumStats} input must have been QC'd via +\code{\link{summaryStatsQc}} first; otherwise an error is raised pointing at that function. -The returned \code{\link{TwasWeights}} collection's \code{ldSketch} slot is -set automatically: \code{NULL} for individual-level fits, the input's -\code{ldSketch} for RSS-derived fits. +The returned \code{\link{TwasWeights}} collection's \code{ldReference} slot +is set automatically: \code{NULL} for individual-level fits, the input's +\code{ldReference} for RSS-derived fits. -Optionally a \code{FineMappingResult} may be supplied as a source of pre-fit -SuSiE / SuSiE-inf / SuSiE-ash objects; their \code{trimmedFit} payloads are -passed through to \code{learnTwasWeights} / the RSS sub-pipelines via the +Optionally a \code{QtlFineMappingResult} may be supplied as a source of +pre-fit SuSiE / SuSiE-inf / SuSiE-ash objects; their stored fits are passed +through to \code{learnTwasWeights} / the RSS sub-pipelines via the \code{fittedModels} slot, avoiding a re-fit. -When the supplied \code{FineMappingResult} was produced with cross-validation -(\code{fineMappingPipeline(..., cvFolds > 1)}), each matching \code{(study, -context, trait)} entry's \code{cvResult} is reused: its fold partition -becomes the CV partition (unless \code{samplePartition} is given explicitly) -and its per-fold out-of-fold predictions/metrics are fed directly into the -SR-TWAS ensemble in place of re-fitting those fine-mapping methods here. +When the supplied result was produced with cross-validation (a +\code{\link{CrossValidationParam}} with \code{folds >= 2}), each matching +\code{(study, context, trait)} entry's \code{cvResult} is reused: its fold +partition becomes the CV partition (unless \code{samplePartition} is given +explicitly) and its per-fold out-of-fold predictions/metrics are fed +directly into the SR-TWAS ensemble in place of re-fitting those +fine-mapping methods here. Non-fine-mapping methods (lasso, enet, ...) are still cross-validated on the same shared partition. } \section{Panel filters on the RSS path}{ On \code{QtlSumStats} input there - is no genotype matrix to filter, so \code{panelFilter}'s + is no genotype matrix to filter, so \code{panelFilterParam}'s \code{mafCutoff} / \code{macCutoff} / \code{imissCutoff} are measured against the \strong{LD reference panel} instead: a variant whose panel genotypes fall below the cutoffs is dropped before the z-scores and LD matrix are built. The thresholds mean the same thing as - \code{genotypeFilter}'s on the \code{QtlDataset} path (MAC is converted - to a MAF equivalent and the stricter of the two applies), so one number - carries across input types. The defaults filter nothing. + \code{genotypeFilterParam}'s on the \code{QtlDataset} path (MAC is + converted to a MAF equivalent and the stricter of the two applies), so + one number carries across input types. The defaults filter nothing. This discards \emph{observed} variants, unlike - \code{summaryStatsQc(imputeArgs = ...)}, which only bounds which variants + \code{summaryStatsQc(raissParam = ...)}, which only bounds which variants RAISS will impute. } diff --git a/man/twasZ.Rd b/man/twasZ.Rd index c4660b80e..1609aced4 100644 --- a/man/twasZ.Rd +++ b/man/twasZ.Rd @@ -25,8 +25,9 @@ name defaults to \code{"method1"}.} \item{R}{Optional LD correlation matrix.} -\item{X}{Optional genotype matrix used to compute \code{R} when \code{R} is -missing.} +\item{X}{Optional genotype matrix (samples x variants) standing in for +\code{R} when \code{R} is missing; its LD is taken as +\code{\link{computeLd}}'s, without forming it.} \item{V, D, nSketch}{SVD components of the LD sketch (right-singular vectors, singular values, panel sample size). Supplying all three selects the SVD @@ -70,8 +71,10 @@ combined p-value trivially equals the per-tuple p-value. The SVD path (\code{V}, \code{D}, \code{nSketch}) lets the caller avoid materializing the full LD matrix: \code{covY = (V^TW * sqrt(Lambda))^T (V^TW * sqrt(Lambda))} with \code{Lambda_i = D_i^2 / (nSketch - 1)}. Use the -\code{R} path when an LD correlation matrix is already available; use the -\code{X} path to compute \code{R} from a genotype matrix. +\code{R} path when an LD correlation matrix is already available; the +\code{X} path works from a genotype matrix directly, as +\code{covY = (F W)^T (F W) / (n - 1)} for its standardized dosages +\code{F}, never forming \code{R}. } \examples{ data(eqtlRegionExample) diff --git a/man/varY.Rd b/man/varY.Rd index 5021ef5fa..4cc18b6af 100644 --- a/man/varY.Rd +++ b/man/varY.Rd @@ -1,17 +1,17 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/gwasSumStats.R, -% R/qtlSumStats.R +% Please edit documentation in R/AllGenerics.R, R/qtlSumStats.R, +% R/gwasSumStats.R \name{varY} \alias{varY} -\alias{varY,GwasSumStats-method} \alias{varY,QtlSumStats-method} +\alias{varY,GwasSumStats-method} \title{Get Phenotype Variance} \usage{ varY(x, ...) -\S4method{varY}{GwasSumStats}(x, studyName = NULL) - \S4method{varY}{QtlSumStats}(x, studyName = NULL, context = NULL, trait = NULL) + +\S4method{varY}{GwasSumStats}(x, studyName = NULL) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} diff --git a/man/variantIds.Rd b/man/variantIds.Rd index b659c0de0..877032218 100644 --- a/man/variantIds.Rd +++ b/man/variantIds.Rd @@ -1,11 +1,13 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, R/LdData.R, -% R/fineMappingRow.R, R/twasWeights.R, R/twasWeightsRow.R +% Please edit documentation in R/AllGenerics.R, R/GenotypeMixture.R, +% R/LdMatrix.R, R/AllClasses.R, R/fineMappingRow.R, R/twasWeights.R, +% R/twasWeightsRow.R \name{variantIds} \alias{variantIds} +\alias{variantIds,GenotypeMixture-method} +\alias{variantIds,LdMatrix-method} \alias{variantIds,FineMappingResultBase-method} \alias{variantIds,SumStatsBase-method} -\alias{variantIds,LdData-method} \alias{variantIds,FineMappingRow-method} \alias{variantIds,TwasWeights-method} \alias{variantIds,TwasWeightsRow-method} @@ -13,6 +15,10 @@ \usage{ variantIds(x, ...) +\S4method{variantIds}{GenotypeMixture}(x, ...) + +\S4method{variantIds}{LdMatrix}(x, ...) + \S4method{variantIds}{FineMappingResultBase}( x, studyName = NULL, @@ -31,8 +37,6 @@ variantIds(x, ...) ranges = NULL ) -\S4method{variantIds}{LdData}(x) - \S4method{variantIds}{FineMappingRow}(x) \S4method{variantIds}{TwasWeights}(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) @@ -71,7 +75,7 @@ Character vector of variant IDs. } \description{ Extract variant ID vector from an object that carries one (e.g., - \code{LdData}, \code{FineMappingRow}, \code{TwasWeightsRow}) or from + \code{LdMatrix}, \code{FineMappingRow}, \code{TwasWeightsRow}) or from one entry of a collection class selected by its identity tuple. } \examples{ diff --git a/man/variantInfo.Rd b/man/variantInfo.Rd deleted file mode 100644 index 566920830..000000000 --- a/man/variantInfo.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/LdData.R -\name{variantInfo} -\alias{variantInfo} -\alias{variantInfo,LdData-method} -\title{Get Variant GRanges} -\usage{ -variantInfo(x) - -\S4method{variantInfo}{LdData}(x) -} -\arguments{ -\item{x}{An \code{LdData}.} -} -\value{ -A \code{GRanges}. -} -\description{ -Return the variant metadata \code{GRanges} of an \code{LdData}. -} -\examples{ -data(eqtlRegionExample) -X <- eqtlRegionExample$X[, 1:8] -gr <- GenomicRanges::GRanges("22", - IRanges::IRanges(seq(1L, by = 100L, length.out = 8), width = 1L)) -ld <- LdData(correlation = cor(X), variants = gr, - blockMetadata = S4Vectors::DataFrame( - chrom = "22", start = 1L, end = 1000L)) -variantInfo(ld) -} diff --git a/pixi.toml b/pixi.toml index a08cb0051..5b2e1acb9 100644 --- a/pixi.toml +++ b/pixi.toml @@ -46,17 +46,21 @@ r45 = {features = ["r45"]} "r-testthat" = "*" "r-tidyverse" = "*" "bioconductor-biocparallel" = "*" +"bioconductor-biocsingular" = "*" +"bioconductor-gdsarray" = "*" "bioconductor-genomicranges" = "*" "bioconductor-iranges" = "*" "bioconductor-qvalue" = "*" "bioconductor-s4vectors" = "*" "bioconductor-snprelate" = "*" "bioconductor-snpstats" = "*" -"bioconductor-mungesumstats" = "*" "bioconductor-multiassayexperiment" = "*" +"bioconductor-plinkmatrix" = "*" "bioconductor-rsamtools" = "*" "bioconductor-rtracklayer" = "*" +"bioconductor-seqarray" = "*" "bioconductor-summarizedexperiment" = "*" +"bioconductor-variantannotation" = "*" "r-archive" = "*" "r-arrow" = "*" "r-aspu" = "*" @@ -71,6 +75,7 @@ r45 = {features = ["r45"]} "r-cpp11" = "*" "r-cpp11armadillo" = "*" "r-ctwas" = "*" +"r-dbi" = "*" "r-dplyr" = "*" "r-flashier" = "*" "r-fsusier" = "*" @@ -101,6 +106,7 @@ r45 = {features = ["r45"]} "r-rfast" = "*" "r-rlang" = "*" "r-robustbase" = "*" +"r-rsqlite" = "*" "r-softimpute" = "*" "r-stringr" = "*" "r-susier" = "*" diff --git a/src/bgen.cpp b/src/bgen.cpp new file mode 100644 index 000000000..5ddd56ca4 --- /dev/null +++ b/src/bgen.cpp @@ -0,0 +1,220 @@ +/** + * @file bgen.cpp + * @brief Expected allele counts from BGEN layout-2 genotype probability data. + * + * The R side (R/genotypeIo.R) reads one variant's record from the .bgen file, + * decompresses its probability data (zlib or zstd) and hands the + * uncompressed bytes here. The layout is BGEN 1.2 / 1.3's + * (https://www.well.ox.ac.uk/~gav/bgen_format/spec/latest.html): + * + * uint32 N, uint16 K, uint8 Pmin, uint8 Pmax, + * N bytes of ploidy (low 6 bits) and missingness (top bit), + * uint8 phased, uint8 B, + * the probabilities, B bits each, least significant bit first. + * + * For each sample, a phased record stores K - 1 probabilities per haplotype + * (the K-th is one minus their sum); an unphased one stores one per possible + * genotype but the last, the genotypes enumerated as allele-count vectors in + * colex order. A stored value v is the probability v / (2^B - 1). Samples + * flagged missing store zeros, which are skipped. A sample's ploidy is any + * the spec allows (6 bits, so up to 63), and the expected count of an allele + * runs from 0 to the ploidy. + */ + +#include +#include +#include + +using namespace cpp11; + +namespace { + +// Reads B-bit unsigned values from a byte buffer, least significant bit +// first, as the BGEN spec stores them. +class BitReader { +public: + BitReader(const unsigned char* data, size_t size, int bits) + : data_(data), size_(size), bits_(bits), pos_(0), buffer_(0), held_(0) {} + + double next() { + while (held_ < bits_) { + if (pos_ >= size_) cpp11::stop("BGEN probability data ends early."); + buffer_ |= static_cast(data_[pos_++]) << held_; + held_ += 8; + } + uint64_t mask = (bits_ == 64) ? ~uint64_t(0) : ((uint64_t(1) << bits_) - 1); + uint64_t value = buffer_ & mask; + buffer_ >>= bits_; + held_ -= bits_; + return static_cast(value) / static_cast(mask); + } + +private: + const unsigned char* data_; + size_t size_; + int bits_; + size_t pos_; + uint64_t buffer_; + int held_; +}; + +uint32_t read_u32(const unsigned char* p) { + return uint32_t(p[0]) | (uint32_t(p[1]) << 8) | (uint32_t(p[2]) << 16) | (uint32_t(p[3]) << 24); +} + +uint16_t read_u16(const unsigned char* p) { + return uint16_t(p[0]) | (uint16_t(uint16_t(p[1]) << 8)); +} + +// The allele-count vectors of the genotypes of a sample of ploidy `ploidy` +// with `K` alleles, in the colex order the spec stores their probabilities +// in: the last allele's count varies slowest. counts[g][k] is allele k's +// count in genotype g. +void colex_genotypes(int ploidy, int K, std::vector& current, int k, + int remaining, std::vector>& out) { + if (k == 0) { + current[0] = remaining; + out.push_back(current); + return; + } + for (int c = 0; c <= remaining; ++c) { + current[k] = c; + colex_genotypes(ploidy, K, current, k - 1, remaining - c, out); + } +} + +std::vector> genotype_counts(int ploidy, int K) { + std::vector> out; + std::vector current(K, 0); + colex_genotypes(ploidy, K, current, K - 1, ploidy, out); + return out; +} + +// How many genotypes a sample of ploidy `ploidy` with `K` alleles has -- the +// multisets of `ploidy` alleles, C(ploidy + K - 1, ploidy) -- counted only up +// to just past `cap`, so a corrupt record claiming an enormous ploidy or +// allele count is caught before its genotypes are enumerated. +double genotype_number(int ploidy, int K, double cap) { + double n = 1.0; + for (int j = 1; j <= ploidy && n <= cap; ++j) { + n = n * (K - 1 + j) / j; + } + return n; +} + +} // namespace + +/** + * @brief The expected counts of the requested alleles in every sample. + * + * @param data One variant's uncompressed layout-2 probability data. + * @param nSamples The file's sample count, which the data must repeat. + * @param alleles 1-based indices of the alleles whose expected counts to + * return, one output column each. + * @return An nSamples x length(alleles) matrix; NA for a sample flagged + * missing or of ploidy 0. + */ +[[cpp11::register]] +cpp11::writable::doubles_matrix<> bgenDosageCpp(cpp11::raws data, int nSamples, + cpp11::integers alleles) { + const size_t size = data.size(); + const unsigned char* p = RAW(static_cast(data)); + if (size < 10) cpp11::stop("BGEN probability data is truncated."); + uint32_t N = read_u32(p); + if (static_cast(N) != nSamples) + cpp11::stop("BGEN variant stores %d samples but the file declares %d.", + static_cast(N), nSamples); + int K = read_u16(p + 4); + if (size < 10 + N) cpp11::stop("BGEN probability data is truncated."); + const unsigned char* ploidyBytes = p + 8; + int phased = p[8 + N]; + int bits = p[9 + N]; + if (phased != 0 && phased != 1) cpp11::stop("BGEN phased flag must be 0 or 1."); + if (bits < 1 || bits > 32) cpp11::stop("BGEN bit depth must be between 1 and 32."); + + const int nOut = alleles.size(); + for (int a = 0; a < nOut; ++a) { + if (alleles[a] < 1 || alleles[a] > K) + cpp11::stop("Allele %d is not one of the variant's %d alleles.", alleles[a], K); + } + // Each ploidy's genotypes, enumerated when a sample of it is first met. + // The data cannot hold more probabilities than it has bits, which bounds + // the enumeration of a record that is not what it claims to be. + std::vector>> countsOf(64); + const double cap = 8.0 * static_cast(size) / bits + 1.0; + + cpp11::writable::doubles_matrix<> out(nSamples, nOut); + BitReader reader(p + 10 + N, size - 10 - N, bits); + std::vector stored; + for (int i = 0; i < nSamples; ++i) { + int ploidy = ploidyBytes[i] & 63; + bool missing = (ploidyBytes[i] & 128) != 0; + if (!phased && ploidy > 0 && countsOf[ploidy].empty()) { + if (genotype_number(ploidy, K, cap) > cap) cpp11::stop("BGEN probability data is truncated."); + countsOf[ploidy] = genotype_counts(ploidy, K); + } + // How many probabilities this sample stores, and what they are. + int nStored = 0; + if (ploidy > 0) { + nStored = phased ? ploidy * (K - 1) : static_cast(countsOf[ploidy].size()) - 1; + } + stored.assign(nStored, 0.0); + for (int s = 0; s < nStored; ++s) stored[s] = reader.next(); + if (missing || ploidy == 0) { + for (int a = 0; a < nOut; ++a) out(i, a) = NA_REAL; + continue; + } + for (int a = 0; a < nOut; ++a) { + int allele = alleles[a] - 1; + double expected = 0.0; + if (phased) { + // Each haplotype carries the allele with its probability; the + // last allele's is one minus the stored ones'. + for (int h = 0; h < ploidy; ++h) { + const double* hap = stored.data() + h * (K - 1); + if (allele < K - 1) { + expected += hap[allele]; + } else { + double rest = 0.0; + for (int k = 0; k < K - 1; ++k) rest += hap[k]; + expected += 1.0 - rest; + } + } + } else { + const std::vector>& g = countsOf[ploidy]; + double last = 1.0; + for (int s = 0; s < nStored; ++s) { + expected += g[s][allele] * stored[s]; + last -= stored[s]; + } + expected += g[nStored][allele] * last; + } + out(i, a) = expected; + } + } + return out; +} + +/** + * @brief The sample ids of a BGEN sample identifier block. + * + * @param ids The block after its two leading counts: each id as a 2-byte + * length and that many bytes. + * @param nSamples How many ids the block holds. + */ +[[cpp11::register]] +cpp11::writable::strings bgenSampleIdsCpp(cpp11::raws ids, int nSamples) { + const unsigned char* p = RAW(static_cast(ids)); + const size_t size = ids.size(); + size_t at = 0; + cpp11::writable::strings out(nSamples); + for (int i = 0; i < nSamples; ++i) { + if (at + 2 > size) cpp11::stop("The BGEN sample block is truncated."); + size_t len = read_u16(p + at); + at += 2; + if (at + len > size) cpp11::stop("The BGEN sample block is truncated."); + out[i] = std::string(reinterpret_cast(p + at), len); + at += len; + } + return out; +} diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 9a538c073..b0f643ba1 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -5,6 +5,20 @@ #include "cpp11/declarations.hpp" #include +// bgen.cpp +cpp11::writable::doubles_matrix<> bgenDosageCpp(cpp11::raws data, int nSamples, cpp11::integers alleles); +extern "C" SEXP _pecotmr_bgenDosageCpp(SEXP data, SEXP nSamples, SEXP alleles) { + BEGIN_CPP11 + return cpp11::as_sexp(bgenDosageCpp(cpp11::as_cpp>(data), cpp11::as_cpp>(nSamples), cpp11::as_cpp>(alleles))); + END_CPP11 +} +// bgen.cpp +cpp11::writable::strings bgenSampleIdsCpp(cpp11::raws ids, int nSamples); +extern "C" SEXP _pecotmr_bgenSampleIdsCpp(SEXP ids, SEXP nSamples) { + BEGIN_CPP11 + return cpp11::as_sexp(bgenSampleIdsCpp(cpp11::as_cpp>(ids), cpp11::as_cpp>(nSamples))); + END_CPP11 +} // dentist_iterative_impute.cpp cpp11::writable::list dentistIterativeImpute(const doubles_matrix<>& ldMatR, int nSample, const doubles& zScoreR, double pValueThreshold, double propSVD, bool gcControl, int nIter, double gPvalueThreshold, int numThreads, bool correctChenEtAlBug, bool verbose, cpp11::sexp seed); extern "C" SEXP _pecotmr_dentistIterativeImpute(SEXP ldMatR, SEXP nSample, SEXP zScoreR, SEXP pValueThreshold, SEXP propSVD, SEXP gcControl, SEXP nIter, SEXP gPvalueThreshold, SEXP numThreads, SEXP correctChenEtAlBug, SEXP verbose, SEXP seed) { @@ -12,50 +26,108 @@ extern "C" SEXP _pecotmr_dentistIterativeImpute(SEXP ldMatR, SEXP nSample, SEXP return cpp11::as_sexp(dentistIterativeImpute(cpp11::as_cpp&>>(ldMatR), cpp11::as_cpp>(nSample), cpp11::as_cpp>(zScoreR), cpp11::as_cpp>(pValueThreshold), cpp11::as_cpp>(propSVD), cpp11::as_cpp>(gcControl), cpp11::as_cpp>(nIter), cpp11::as_cpp>(gPvalueThreshold), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(correctChenEtAlBug), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); END_CPP11 } +// dentist_iterative_impute.cpp +cpp11::writable::list dentistIterativeImputeFactor(const doubles_matrix<>& factorR, int nSample, const doubles& zScoreR, double pValueThreshold, double propSVD, bool gcControl, int nIter, double gPvalueThreshold, int numThreads, bool correctChenEtAlBug, bool verbose, cpp11::sexp seed); +extern "C" SEXP _pecotmr_dentistIterativeImputeFactor(SEXP factorR, SEXP nSample, SEXP zScoreR, SEXP pValueThreshold, SEXP propSVD, SEXP gcControl, SEXP nIter, SEXP gPvalueThreshold, SEXP numThreads, SEXP correctChenEtAlBug, SEXP verbose, SEXP seed) { + BEGIN_CPP11 + return cpp11::as_sexp(dentistIterativeImputeFactor(cpp11::as_cpp&>>(factorR), cpp11::as_cpp>(nSample), cpp11::as_cpp>(zScoreR), cpp11::as_cpp>(pValueThreshold), cpp11::as_cpp>(propSVD), cpp11::as_cpp>(gcControl), cpp11::as_cpp>(nIter), cpp11::as_cpp>(gPvalueThreshold), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(correctChenEtAlBug), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); + END_CPP11 +} +// lassosum_rss.cpp +cpp11::writable::list lassosumRssCpp(const doubles& zR, const list& LD, double shrink, const doubles& lambdaR, double thr, int maxiter); +extern "C" SEXP _pecotmr_lassosumRssCpp(SEXP zR, SEXP LD, SEXP shrink, SEXP lambdaR, SEXP thr, SEXP maxiter) { + BEGIN_CPP11 + return cpp11::as_sexp(lassosumRssCpp(cpp11::as_cpp>(zR), cpp11::as_cpp>(LD), cpp11::as_cpp>(shrink), cpp11::as_cpp>(lambdaR), cpp11::as_cpp>(thr), cpp11::as_cpp>(maxiter))); + END_CPP11 +} // lassosum_rss.cpp -cpp11::writable::list lassosumRssRcpp(const doubles& zR, const list& LD, const doubles& lambdaR, double thr, int maxiter); -extern "C" SEXP _pecotmr_lassosumRssRcpp(SEXP zR, SEXP LD, SEXP lambdaR, SEXP thr, SEXP maxiter) { +cpp11::writable::list lassosumRssFactorCpp(const doubles& zR, const doubles_matrix<>& factorR, double shrink, const doubles& lambdaR, double thr, int maxiter); +extern "C" SEXP _pecotmr_lassosumRssFactorCpp(SEXP zR, SEXP factorR, SEXP shrink, SEXP lambdaR, SEXP thr, SEXP maxiter) { + BEGIN_CPP11 + return cpp11::as_sexp(lassosumRssFactorCpp(cpp11::as_cpp>(zR), cpp11::as_cpp&>>(factorR), cpp11::as_cpp>(shrink), cpp11::as_cpp>(lambdaR), cpp11::as_cpp>(thr), cpp11::as_cpp>(maxiter))); + END_CPP11 +} +// ld_prune.cpp +cpp11::writable::integers ldThresholdComponents(const doubles_matrix<>& standardized, double threshold, int stripe); +extern "C" SEXP _pecotmr_ldThresholdComponents(SEXP standardized, SEXP threshold, SEXP stripe) { + BEGIN_CPP11 + return cpp11::as_sexp(ldThresholdComponents(cpp11::as_cpp&>>(standardized), cpp11::as_cpp>(threshold), cpp11::as_cpp>(stripe))); + END_CPP11 +} +// penalized_rss.cpp +cpp11::writable::list penalizedRssCpp(const doubles& zR, const list& LD, double shrink, const doubles& lambdaR, const std::string& penaltyStr, double gamma, double alpha, double lambda0, double lambda2, double thr, int maxiter, int maxSwaps); +extern "C" SEXP _pecotmr_penalizedRssCpp(SEXP zR, SEXP LD, SEXP shrink, SEXP lambdaR, SEXP penaltyStr, SEXP gamma, SEXP alpha, SEXP lambda0, SEXP lambda2, SEXP thr, SEXP maxiter, SEXP maxSwaps) { BEGIN_CPP11 - return cpp11::as_sexp(lassosumRssRcpp(cpp11::as_cpp>(zR), cpp11::as_cpp>(LD), cpp11::as_cpp>(lambdaR), cpp11::as_cpp>(thr), cpp11::as_cpp>(maxiter))); + return cpp11::as_sexp(penalizedRssCpp(cpp11::as_cpp>(zR), cpp11::as_cpp>(LD), cpp11::as_cpp>(shrink), cpp11::as_cpp>(lambdaR), cpp11::as_cpp>(penaltyStr), cpp11::as_cpp>(gamma), cpp11::as_cpp>(alpha), cpp11::as_cpp>(lambda0), cpp11::as_cpp>(lambda2), cpp11::as_cpp>(thr), cpp11::as_cpp>(maxiter), cpp11::as_cpp>(maxSwaps))); END_CPP11 } // penalized_rss.cpp -cpp11::writable::list penalizedRssRcpp(const doubles& zR, const list& LD, const doubles& lambdaR, const std::string& penaltyStr, double gamma, double alpha, double lambda0, double lambda2, double thr, int maxiter, int maxSwaps); -extern "C" SEXP _pecotmr_penalizedRssRcpp(SEXP zR, SEXP LD, SEXP lambdaR, SEXP penaltyStr, SEXP gamma, SEXP alpha, SEXP lambda0, SEXP lambda2, SEXP thr, SEXP maxiter, SEXP maxSwaps) { +cpp11::writable::list penalizedRssFactorCpp(const doubles& zR, const doubles_matrix<>& factorR, double shrink, const doubles& lambdaR, const std::string& penaltyStr, double gamma, double alpha, double lambda0, double lambda2, double thr, int maxiter, int maxSwaps); +extern "C" SEXP _pecotmr_penalizedRssFactorCpp(SEXP zR, SEXP factorR, SEXP shrink, SEXP lambdaR, SEXP penaltyStr, SEXP gamma, SEXP alpha, SEXP lambda0, SEXP lambda2, SEXP thr, SEXP maxiter, SEXP maxSwaps) { + BEGIN_CPP11 + return cpp11::as_sexp(penalizedRssFactorCpp(cpp11::as_cpp>(zR), cpp11::as_cpp&>>(factorR), cpp11::as_cpp>(shrink), cpp11::as_cpp>(lambdaR), cpp11::as_cpp>(penaltyStr), cpp11::as_cpp>(gamma), cpp11::as_cpp>(alpha), cpp11::as_cpp>(lambda0), cpp11::as_cpp>(lambda2), cpp11::as_cpp>(thr), cpp11::as_cpp>(maxiter), cpp11::as_cpp>(maxSwaps))); + END_CPP11 +} +// prscs_mcmc.cpp +cpp11::writable::list prsCsCpp(double a, double b, sexp phi, doubles bhat, sexp maf, int n, list ldBlk, int nIter, int nBurnin, int thin, bool verbose, sexp seed); +extern "C" SEXP _pecotmr_prsCsCpp(SEXP a, SEXP b, SEXP phi, SEXP bhat, SEXP maf, SEXP n, SEXP ldBlk, SEXP nIter, SEXP nBurnin, SEXP thin, SEXP verbose, SEXP seed) { BEGIN_CPP11 - return cpp11::as_sexp(penalizedRssRcpp(cpp11::as_cpp>(zR), cpp11::as_cpp>(LD), cpp11::as_cpp>(lambdaR), cpp11::as_cpp>(penaltyStr), cpp11::as_cpp>(gamma), cpp11::as_cpp>(alpha), cpp11::as_cpp>(lambda0), cpp11::as_cpp>(lambda2), cpp11::as_cpp>(thr), cpp11::as_cpp>(maxiter), cpp11::as_cpp>(maxSwaps))); + return cpp11::as_sexp(prsCsCpp(cpp11::as_cpp>(a), cpp11::as_cpp>(b), cpp11::as_cpp>(phi), cpp11::as_cpp>(bhat), cpp11::as_cpp>(maf), cpp11::as_cpp>(n), cpp11::as_cpp>(ldBlk), cpp11::as_cpp>(nIter), cpp11::as_cpp>(nBurnin), cpp11::as_cpp>(thin), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); END_CPP11 } // prscs_mcmc.cpp -cpp11::writable::list prsCsRcpp(double a, double b, sexp phi, doubles bhat, sexp maf, int n, list ldBlk, int nIter, int nBurnin, int thin, bool verbose, sexp seed); -extern "C" SEXP _pecotmr_prsCsRcpp(SEXP a, SEXP b, SEXP phi, SEXP bhat, SEXP maf, SEXP n, SEXP ldBlk, SEXP nIter, SEXP nBurnin, SEXP thin, SEXP verbose, SEXP seed) { +cpp11::writable::list prsCsFactorCpp(double a, double b, sexp phi, doubles bhat, sexp maf, int n, const doubles_matrix<>& factorR, int nIter, int nBurnin, int thin, bool verbose, sexp seed); +extern "C" SEXP _pecotmr_prsCsFactorCpp(SEXP a, SEXP b, SEXP phi, SEXP bhat, SEXP maf, SEXP n, SEXP factorR, SEXP nIter, SEXP nBurnin, SEXP thin, SEXP verbose, SEXP seed) { BEGIN_CPP11 - return cpp11::as_sexp(prsCsRcpp(cpp11::as_cpp>(a), cpp11::as_cpp>(b), cpp11::as_cpp>(phi), cpp11::as_cpp>(bhat), cpp11::as_cpp>(maf), cpp11::as_cpp>(n), cpp11::as_cpp>(ldBlk), cpp11::as_cpp>(nIter), cpp11::as_cpp>(nBurnin), cpp11::as_cpp>(thin), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); + return cpp11::as_sexp(prsCsFactorCpp(cpp11::as_cpp>(a), cpp11::as_cpp>(b), cpp11::as_cpp>(phi), cpp11::as_cpp>(bhat), cpp11::as_cpp>(maf), cpp11::as_cpp>(n), cpp11::as_cpp&>>(factorR), cpp11::as_cpp>(nIter), cpp11::as_cpp>(nBurnin), cpp11::as_cpp>(thin), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); END_CPP11 } // qtl_enrichment.cpp -cpp11::writable::list qtlEnrichmentRcpp(SEXP rGwasPip, SEXP rQtlSusieFit, double piGwas, double piQtl, int ImpN, double shrinkageLambda, bool doubleShrinkage, bool besselCorrection, int numThreads, cpp11::sexp seed); -extern "C" SEXP _pecotmr_qtlEnrichmentRcpp(SEXP rGwasPip, SEXP rQtlSusieFit, SEXP piGwas, SEXP piQtl, SEXP ImpN, SEXP shrinkageLambda, SEXP doubleShrinkage, SEXP besselCorrection, SEXP numThreads, SEXP seed) { +cpp11::writable::list qtlEnrichmentCpp(SEXP rGwasPip, SEXP rQtlSusieFit, double piGwas, double piQtl, int ImpN, double shrinkageLambda, bool doubleShrinkage, bool besselCorrection, int numThreads, cpp11::sexp seed); +extern "C" SEXP _pecotmr_qtlEnrichmentCpp(SEXP rGwasPip, SEXP rQtlSusieFit, SEXP piGwas, SEXP piQtl, SEXP ImpN, SEXP shrinkageLambda, SEXP doubleShrinkage, SEXP besselCorrection, SEXP numThreads, SEXP seed) { + BEGIN_CPP11 + return cpp11::as_sexp(qtlEnrichmentCpp(cpp11::as_cpp>(rGwasPip), cpp11::as_cpp>(rQtlSusieFit), cpp11::as_cpp>(piGwas), cpp11::as_cpp>(piQtl), cpp11::as_cpp>(ImpN), cpp11::as_cpp>(shrinkageLambda), cpp11::as_cpp>(doubleShrinkage), cpp11::as_cpp>(besselCorrection), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(seed))); + END_CPP11 +} +// sdpr.cpp +cpp11::writable::list sdprCpp(const doubles& bhatR, const list& LD, int n, sexp perVariantSampleSize, sexp array, double a, double c, int M, double a0k, double b0k, int iter, int burn, int thin, int numThreads, int optLlk, bool verbose, sexp seed); +extern "C" SEXP _pecotmr_sdprCpp(SEXP bhatR, SEXP LD, SEXP n, SEXP perVariantSampleSize, SEXP array, SEXP a, SEXP c, SEXP M, SEXP a0k, SEXP b0k, SEXP iter, SEXP burn, SEXP thin, SEXP numThreads, SEXP optLlk, SEXP verbose, SEXP seed) { BEGIN_CPP11 - return cpp11::as_sexp(qtlEnrichmentRcpp(cpp11::as_cpp>(rGwasPip), cpp11::as_cpp>(rQtlSusieFit), cpp11::as_cpp>(piGwas), cpp11::as_cpp>(piQtl), cpp11::as_cpp>(ImpN), cpp11::as_cpp>(shrinkageLambda), cpp11::as_cpp>(doubleShrinkage), cpp11::as_cpp>(besselCorrection), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(seed))); + return cpp11::as_sexp(sdprCpp(cpp11::as_cpp>(bhatR), cpp11::as_cpp>(LD), cpp11::as_cpp>(n), cpp11::as_cpp>(perVariantSampleSize), cpp11::as_cpp>(array), cpp11::as_cpp>(a), cpp11::as_cpp>(c), cpp11::as_cpp>(M), cpp11::as_cpp>(a0k), cpp11::as_cpp>(b0k), cpp11::as_cpp>(iter), cpp11::as_cpp>(burn), cpp11::as_cpp>(thin), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(optLlk), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); END_CPP11 } // sdpr.cpp -cpp11::writable::list sdprRcpp(const doubles& bhatR, const list& LD, int n, sexp perVariantSampleSize, sexp array, double a, double c, int M, double a0k, double b0k, int iter, int burn, int thin, int numThreads, int optLlk, bool verbose, sexp seed); -extern "C" SEXP _pecotmr_sdprRcpp(SEXP bhatR, SEXP LD, SEXP n, SEXP perVariantSampleSize, SEXP array, SEXP a, SEXP c, SEXP M, SEXP a0k, SEXP b0k, SEXP iter, SEXP burn, SEXP thin, SEXP numThreads, SEXP optLlk, SEXP verbose, SEXP seed) { +cpp11::writable::list sdprFactorCpp(const doubles& bhatR, const doubles_matrix<>& factorR, int n, sexp perVariantSampleSize, sexp array, double a, double c, int M, double a0k, double b0k, int iter, int burn, int thin, int numThreads, int optLlk, bool verbose, sexp seed); +extern "C" SEXP _pecotmr_sdprFactorCpp(SEXP bhatR, SEXP factorR, SEXP n, SEXP perVariantSampleSize, SEXP array, SEXP a, SEXP c, SEXP M, SEXP a0k, SEXP b0k, SEXP iter, SEXP burn, SEXP thin, SEXP numThreads, SEXP optLlk, SEXP verbose, SEXP seed) { + BEGIN_CPP11 + return cpp11::as_sexp(sdprFactorCpp(cpp11::as_cpp>(bhatR), cpp11::as_cpp&>>(factorR), cpp11::as_cpp>(n), cpp11::as_cpp>(perVariantSampleSize), cpp11::as_cpp>(array), cpp11::as_cpp>(a), cpp11::as_cpp>(c), cpp11::as_cpp>(M), cpp11::as_cpp>(a0k), cpp11::as_cpp>(b0k), cpp11::as_cpp>(iter), cpp11::as_cpp>(burn), cpp11::as_cpp>(thin), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(optLlk), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); + END_CPP11 +} +// vcf_gt.cpp +cpp11::writable::doubles_matrix<> vcfGtDosageCpp(cpp11::strings gt, cpp11::integers alleles); +extern "C" SEXP _pecotmr_vcfGtDosageCpp(SEXP gt, SEXP alleles) { BEGIN_CPP11 - return cpp11::as_sexp(sdprRcpp(cpp11::as_cpp>(bhatR), cpp11::as_cpp>(LD), cpp11::as_cpp>(n), cpp11::as_cpp>(perVariantSampleSize), cpp11::as_cpp>(array), cpp11::as_cpp>(a), cpp11::as_cpp>(c), cpp11::as_cpp>(M), cpp11::as_cpp>(a0k), cpp11::as_cpp>(b0k), cpp11::as_cpp>(iter), cpp11::as_cpp>(burn), cpp11::as_cpp>(thin), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(optLlk), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); + return cpp11::as_sexp(vcfGtDosageCpp(cpp11::as_cpp>(gt), cpp11::as_cpp>(alleles))); END_CPP11 } extern "C" { static const R_CallMethodDef CallEntries[] = { - {"_pecotmr_dentistIterativeImpute", (DL_FUNC) &_pecotmr_dentistIterativeImpute, 12}, - {"_pecotmr_lassosumRssRcpp", (DL_FUNC) &_pecotmr_lassosumRssRcpp, 5}, - {"_pecotmr_penalizedRssRcpp", (DL_FUNC) &_pecotmr_penalizedRssRcpp, 11}, - {"_pecotmr_prsCsRcpp", (DL_FUNC) &_pecotmr_prsCsRcpp, 12}, - {"_pecotmr_qtlEnrichmentRcpp", (DL_FUNC) &_pecotmr_qtlEnrichmentRcpp, 10}, - {"_pecotmr_sdprRcpp", (DL_FUNC) &_pecotmr_sdprRcpp, 17}, + {"_pecotmr_bgenDosageCpp", (DL_FUNC) &_pecotmr_bgenDosageCpp, 3}, + {"_pecotmr_bgenSampleIdsCpp", (DL_FUNC) &_pecotmr_bgenSampleIdsCpp, 2}, + {"_pecotmr_dentistIterativeImpute", (DL_FUNC) &_pecotmr_dentistIterativeImpute, 12}, + {"_pecotmr_dentistIterativeImputeFactor", (DL_FUNC) &_pecotmr_dentistIterativeImputeFactor, 12}, + {"_pecotmr_lassosumRssCpp", (DL_FUNC) &_pecotmr_lassosumRssCpp, 6}, + {"_pecotmr_lassosumRssFactorCpp", (DL_FUNC) &_pecotmr_lassosumRssFactorCpp, 6}, + {"_pecotmr_ldThresholdComponents", (DL_FUNC) &_pecotmr_ldThresholdComponents, 3}, + {"_pecotmr_penalizedRssCpp", (DL_FUNC) &_pecotmr_penalizedRssCpp, 12}, + {"_pecotmr_penalizedRssFactorCpp", (DL_FUNC) &_pecotmr_penalizedRssFactorCpp, 12}, + {"_pecotmr_prsCsCpp", (DL_FUNC) &_pecotmr_prsCsCpp, 12}, + {"_pecotmr_prsCsFactorCpp", (DL_FUNC) &_pecotmr_prsCsFactorCpp, 12}, + {"_pecotmr_qtlEnrichmentCpp", (DL_FUNC) &_pecotmr_qtlEnrichmentCpp, 10}, + {"_pecotmr_sdprCpp", (DL_FUNC) &_pecotmr_sdprCpp, 17}, + {"_pecotmr_sdprFactorCpp", (DL_FUNC) &_pecotmr_sdprFactorCpp, 17}, + {"_pecotmr_vcfGtDosageCpp", (DL_FUNC) &_pecotmr_vcfGtDosageCpp, 2}, {NULL, NULL, 0} }; } diff --git a/src/dentist_iterative_impute.cpp b/src/dentist_iterative_impute.cpp index 8524ab4b1..71357c33d 100644 --- a/src/dentist_iterative_impute.cpp +++ b/src/dentist_iterative_impute.cpp @@ -95,6 +95,31 @@ double minusLogPvalueChisq2(double stat) { return -log10(p); } +// Store one iteration's imputation for the variants in idx2: the imputed z, +// its R^2 (capped at 1, with the exceeding values collected for R to report +// once), and the outlier statistic (z - imputed) / sqrt(R_jj - rsq_j). +// `ldDiag` holds R_jj for each of idx2. +void storeIteration(const std::vector& idx2, const vec& zScore, + const vec& zScore_imp, const vec& rsq_vec, const vec& ldDiag, + vec& imputedZ, vec& rsqList, vec& zScore_e, + std::vector& rsqExceed) { + for (size_t i = 0; i < idx2.size(); ++i) { + imputedZ[idx2[i]] = zScore_imp(i); + rsqList[idx2[i]] = rsq_vec(i); + if (rsq_vec(i) >= 1) { + rsqList[idx2[i]] = std::min(rsq_vec(i), 1.0); + // Collect the exceeding value; returned to R (rsq_exceed) which + // summarizes them into a single warning, instead of emitting a + // per-occurrence warning from here. + rsqExceed.push_back(rsq_vec(i)); + } + size_t j = idx2[i]; + double denom_sq = ldDiag(i) - rsqList[j]; + if (denom_sq < 1e-8) denom_sq = 1e-8; + zScore_e[j] = (zScore[j] - imputedZ[j]) / std::sqrt(denom_sq); + } +} + // Perform one iteration of the DENTIST algorithm using Armadillo's eig_sym // (LAPACK dsyevd) for eigendecomposition. Both Eigen and Armadillo return // eigenvalues in ascending order, so the logic is identical. @@ -173,23 +198,82 @@ void oneIteration(const mat& LD_mat, const std::vector& idx, const std:: mat beta = LD_it * (ui.each_row() % wi.t()); vec zScore_imp = beta * (ui.t() * zScore_sub); vec rsq_vec = diagvec(beta * (ui.t() * LD_it.t())); + vec ldDiag(idx2.size()); + for (size_t i = 0; i < idx2.size(); ++i) ldDiag(i) = LD_mat(idx2[i], idx2[i]); + storeIteration(idx2, zScore, zScore_imp, rsq_vec, ldDiag, imputedZ, rsqList, + zScore_e, rsqExceed); +} - // Store results - for (size_t i = 0; i < idx2.size(); ++i) { - imputedZ[idx2[i]] = zScore_imp(i); - rsqList[idx2[i]] = rsq_vec(i); - if (rsq_vec(i) >= 1) { - rsqList[idx2[i]] = std::min(rsq_vec(i), 1.0); - // Collect the exceeding value; returned to R (rsq_exceed) which - // summarizes them into a single warning, instead of emitting a - // per-occurrence warning from here. - rsqExceed.push_back(rsq_vec(i)); +// One iteration from a factor F of the LD (m x p, zero-mean columns, +// crossprod(F) / (m - 1) = R) instead of R itself. With the thin SVD +// F[, idx] = U D V', R[idx, idx] = V diag(d^2 / (m - 1)) V', so the dense +// route's top-K eigenpairs are the SVD's leading K components, and +// R[idx2, idx] V_K diag(1 / lambda_K) = F[, idx2]' U_K diag(1 / d_K) +// rsq = diag(beta V_K' R[idx, idx2]) = rowSums((F[, idx2]' U_K)^2) / (m - 1) +// -- the dense route's imputation exactly, without forming any of R. The +// eigenvalues beyond the SVD's are zero, below the dense route's 1e-4 rank +// cut, so both count the same rank. +void oneIterationFactor(const mat& F, const std::vector& idx, const std::vector& idx2, + const vec& zScore, vec& imputedZ, vec& rsqList, vec& zScore_e, + size_t nSample, float probSVD, int numThreads, bool verbose, + std::vector& rsqExceed) { + if (verbose) { + Rprintf("factor: %lux%lu idx: %lu idx2: %lu\n", + (unsigned long)F.n_rows, (unsigned long)F.n_cols, + (unsigned long)idx.size(), (unsigned long)idx2.size()); + } + + int nProcessors = omp_get_max_threads(); + if (numThreads < nProcessors) nProcessors = numThreads; + omp_set_num_threads(nProcessors); + + size_t K = std::min(static_cast(idx.size()), nSample) * probSVD; + + if (idx2.size() > F.n_cols || idx.size() > F.n_cols) + cpp11::stop("Inconsistent dimensions between the LD factor and idx2/idx in oneIterationFactor()"); + for (size_t i = 0; i < idx.size(); ++i) + if (idx[i] >= zScore.size()) + cpp11::stop("Invalid index in idx: %d", (int)idx[i]); + for (size_t i = 0; i < idx2.size(); ++i) + if (idx2[i] >= zScore.size()) + cpp11::stop("Invalid index in idx2: %d", (int)idx2[i]); + + uvec aidx(idx.size()), aidx2(idx2.size()); + for (size_t i = 0; i < idx.size(); i++) aidx(i) = idx[i]; + for (size_t i = 0; i < idx2.size(); i++) aidx2(i) = idx2[i]; + + double nm1 = static_cast(F.n_rows) - 1.0; + mat U, V; + vec d; + svd_econ(U, d, V, F.cols(aidx)); + vec eigval = square(d) / nm1; // descending + + int nRank = 0; + for (uword j = 0; j < eigval.n_elem; j++) + if (eigval(j) >= 0.0001) nRank++; + if (K > static_cast(nRank)) K = nRank; + + if (verbose) + Rprintf("Rank: %d, K: %lu\n", nRank, (unsigned long)K); + + if (K <= 1) { + cpp11::warning("Rank of eigen matrix <= 1, skipping imputation for this partition"); + for (size_t i = 0; i < idx2.size(); ++i) { + imputedZ[idx2[i]] = 0.0; + rsqList[idx2[i]] = 0.0; + zScore_e[idx2[i]] = 0.0; } - size_t j = idx2[i]; - double denom_sq = LD_mat(j, j) - rsqList[j]; - if (denom_sq < 1e-8) denom_sq = 1e-8; - zScore_e[j] = (zScore[j] - imputedZ[j]) / std::sqrt(denom_sq); + return; } + + mat F2 = F.cols(aidx2); + mat G = F2.t() * U.cols(0, K - 1); // F[, idx2]' U_K + mat beta = G.each_row() / d.subvec(0, K - 1).t(); // ... diag(1 / d_K) + vec zScore_imp = beta * (V.cols(0, K - 1).t() * zScore(aidx)); + vec rsq_vec = sum(square(G), 1) / nm1; + vec ldDiag = sum(square(F2), 0).t() / nm1; + storeIteration(idx2, zScore, zScore_imp, rsq_vec, ldDiag, imputedZ, rsqList, + zScore_e, rsqExceed); } /** @@ -200,8 +284,12 @@ void oneIteration(const mat& LD_mat, const std::vector& idx, const std:: * information from a reference panel. It helps detect genotyping/imputation errors, allelic errors, and heterogeneity * between GWAS and LD reference samples, improving the reliability of subsequent analyses. * - * @param ldMatR The linkage disequilibrium (LD) matrix from a reference panel. - * @param nSample The sample size used in the GWAS whose summary statistics are being analyzed. + * The registered entry points take the reference LD either as a matrix (dentistIterativeImpute, ldMatR) or as + * a factor F with R = F'F / (nrow(F) - 1) (dentistIterativeImputeFactor, factorR); both run dentistRun. + * + * @param one The per-iteration imputation: oneIteration on R, or oneIterationFactor on F. + * @param nSample The LD reference panel's real sample size (NOT the GWAS size): it caps the SVD truncation + * rank, K = min(|idx|, nSample) * propSVD. * @param zScoreR A vector of Z-scores from GWAS summary statistics. * @param pValueThreshold Threshold for the p-value below which variants are considered for quality control. * @param propSVD Proportion of singular value decomposition (SVD) components retained in the analysis. @@ -220,16 +308,15 @@ void oneIteration(const mat& LD_mat, const std::vector& idx, const std:: * - iter_to_correct: An integer vector indicating the iteration in which each marker passed the quality control. */ -[[cpp11::register]] -cpp11::writable::list dentistIterativeImpute(const doubles_matrix<>& ldMatR, int nSample, const doubles& zScoreR, - double pValueThreshold, double propSVD, bool gcControl, int nIter, - double gPvalueThreshold, int numThreads, bool correctChenEtAlBug, - bool verbose, cpp11::sexp seed = R_NilValue) { - mat LD_mat = as_Mat(ldMatR); - vec zScore = as_Col(zScoreR); - +// The DENTIST iterations around a per-iteration imputation `one`, which is +// the dense route (oneIteration on R) or the factor route (oneIterationFactor +// on a factor of R); everything else is shared. +template +cpp11::writable::list dentistRun(const OneIteration& one, const vec& zScore, int nSample, + double pValueThreshold, double propSVD, bool gcControl, int nIter, + double gPvalueThreshold, int numThreads, bool correctChenEtAlBug, + bool verbose, cpp11::sexp seed) { if (verbose) { - Rprintf("LD_mat dimensions: %lu x %lu\n", (unsigned long)LD_mat.n_rows, (unsigned long)LD_mat.n_cols); Rprintf("nSample: %d\n", nSample); Rprintf("zScore size: %lu\n", (unsigned long)zScore.size()); Rprintf("pValueThreshold: %g\n", pValueThreshold); @@ -299,7 +386,7 @@ cpp11::writable::list dentistIterativeImpute(const doubles_matrix<>& ldMatR, int Rprintf("Performing oneIteration()\n"); } - oneIteration(LD_mat, idx, idx2, zScore, imputedZ, rsq, zScore_e, nSample, propSVD, numThreads, verbose, rsqExceed); + one(idx, idx2, zScore, imputedZ, rsq, zScore_e, nSample, propSVD, numThreads, verbose, rsqExceed); diff.resize(idx2.size()); grouping_tmp.resize(idx2.size()); @@ -377,7 +464,7 @@ cpp11::writable::list dentistIterativeImpute(const doubles_matrix<>& ldMatR, int Rprintf("Performing oneIteration() with updated sets of indices\n"); } - oneIteration(LD_mat, idx2_QCed, idx, zScore, imputedZ, rsq, zScore_e, nSample, propSVD, numThreads, verbose, rsqExceed); + one(idx2_QCed, idx, zScore, imputedZ, rsq, zScore_e, nSample, propSVD, numThreads, verbose, rsqExceed); if (verbose) { Rprintf("Recalculating differences and groupings after the iteration\n"); @@ -513,3 +600,44 @@ cpp11::writable::list dentistIterativeImpute(const doubles_matrix<>& ldMatR, int return result; } + +[[cpp11::register]] +cpp11::writable::list dentistIterativeImpute(const doubles_matrix<>& ldMatR, int nSample, const doubles& zScoreR, + double pValueThreshold, double propSVD, bool gcControl, int nIter, + double gPvalueThreshold, int numThreads, bool correctChenEtAlBug, + bool verbose, cpp11::sexp seed = R_NilValue) { + mat LD_mat = as_Mat(ldMatR); + vec zScore = as_Col(zScoreR); + if (verbose) + Rprintf("LD_mat dimensions: %lu x %lu\n", (unsigned long)LD_mat.n_rows, (unsigned long)LD_mat.n_cols); + auto one = [&LD_mat](const std::vector& a, const std::vector& b, + const vec& z, vec& imp, vec& rsq, vec& ze, size_t n, float prop, + int threads, bool verb, std::vector& exceed) { + oneIteration(LD_mat, a, b, z, imp, rsq, ze, n, prop, threads, verb, exceed); + }; + return dentistRun(one, zScore, nSample, pValueThreshold, propSVD, gcControl, nIter, + gPvalueThreshold, numThreads, correctChenEtAlBug, verbose, seed); +} + +// DENTIST from a factor of the LD (see oneIterationFactor): the same +// iterations as dentistIterativeImpute(), never forming the LD matrix. +[[cpp11::register]] +cpp11::writable::list dentistIterativeImputeFactor(const doubles_matrix<>& factorR, int nSample, const doubles& zScoreR, + double pValueThreshold, double propSVD, bool gcControl, int nIter, + double gPvalueThreshold, int numThreads, bool correctChenEtAlBug, + bool verbose, cpp11::sexp seed = R_NilValue) { + mat F = as_Mat(factorR); + vec zScore = as_Col(zScoreR); + if (F.n_cols != zScore.n_elem) + cpp11::stop("The LD factor has %d columns but there are %d z-scores.", + (int)F.n_cols, (int)zScore.n_elem); + if (verbose) + Rprintf("LD factor dimensions: %lu x %lu\n", (unsigned long)F.n_rows, (unsigned long)F.n_cols); + auto one = [&F](const std::vector& a, const std::vector& b, + const vec& z, vec& imp, vec& rsq, vec& ze, size_t n, float prop, + int threads, bool verb, std::vector& exceed) { + oneIterationFactor(F, a, b, z, imp, rsq, ze, n, prop, threads, verb, exceed); + }; + return dentistRun(one, zScore, nSample, pValueThreshold, propSVD, gcControl, nIter, + gPvalueThreshold, numThreads, correctChenEtAlBug, verbose, seed); +} diff --git a/src/lassosum_rss.cpp b/src/lassosum_rss.cpp index 998a02d37..b5c776dcb 100644 --- a/src/lassosum_rss.cpp +++ b/src/lassosum_rss.cpp @@ -2,21 +2,24 @@ // Ported from lassosum (Mak et al 2017) functions.cpp elnet()/repelnet() // // Objective: min_beta beta'R beta - 2 beta'z + 2 lambda ||beta||_1 -// where R is a (possibly pre-shrunk) LD matrix and z = bhat / sqrt(n). +// where R is the LD matrix shrunk to R_s = (1 - s) R + s I (s = `shrink`; +// 0 for an LD matrix already shrunk) and z = bhat / sqrt(n). #include #include +#include "rss_ld.h" + using namespace cpp11; using namespace arma; -// Single-block coordinate descent — mirrors lassosum elnet() -// Tracks Rbeta = R * beta as a running sum (analogous to yhat = X * beta -// in the genotype version). This avoids recomputing the full dot product -// each iteration and matches the original algorithm exactly. -static int elnet_rss(double lambda1, const vec& diag_R, - const mat& R, const vec& z, - double thr, vec& beta, vec& Rbeta, +// Single-block coordinate descent — mirrors lassosum elnet(). `ld` answers +// R's entries for the current beta (rss_ld.h). DenseLd tracks Rbeta = R * beta +// as a running sum (analogous to yhat = X * beta in the genotype version), +// which avoids recomputing the full dot product each iteration and matches the +// original algorithm exactly; FactorLd tracks F * beta instead. +template +static int elnet_rss(double lambda1, Ld& ld, const vec& z, double thr, vec& beta, int maxiter) { int p = z.n_elem; double dlx, del, t, bj; @@ -26,18 +29,19 @@ static int elnet_rss(double lambda1, const vec& diag_R, dlx = 0.0; for (int j = 0; j < p; j++) { bj = beta(j); + double v = ld.diag(j); // t = z(j) - sum_{k != j} R[j,k]*beta[k] - // = z(j) - (Rbeta(j) - R[j,j]*beta(j)) - t = z(j) - Rbeta(j) + diag_R(j) * bj; + // = z(j) - ((R beta)(j) - R[j,j]*beta(j)) + t = z(j) - ld.row(j, beta) + v * bj; // Soft-thresholding (same as lassosum line 438) beta(j) = 0.0; if (std::abs(t) - lambda1 > 0.0) - beta(j) = std::copysign(std::abs(t) - lambda1, t) / diag_R(j); + beta(j) = std::copysign(std::abs(t) - lambda1, t) / v; if (beta(j) == bj) continue; del = beta(j) - bj; dlx = std::max(dlx, std::abs(del)); - // Update running Rbeta (analogous to yhat += del * X.col(j)) - Rbeta += del * R.col(j); + // Update the running R * beta (analogous to yhat += del * X.col(j)) + ld.update(j, del); } cpp11::check_user_interrupt(); if (dlx < thr) { @@ -48,9 +52,28 @@ static int elnet_rss(double lambda1, const vec& diag_R, return conv; } +// The lambda path's results, in the shape both entry points return. +static cpp11::writable::list lassosum_path_result(const mat& beta_mat, const vec& lambda, + const Col& conv_vec, + const vec& loss_vec, + const vec& fbeta_vec) { + using namespace cpp11::literals; + writable::list result({ + "beta"_nm = as_doubles_matrix(beta_mat), + "lambda"_nm = as_doubles(lambda), + "conv"_nm = as_integers(conv_vec), + "loss"_nm = as_doubles(loss_vec), + "fbeta"_nm = as_doubles(fbeta_vec) + }); + return result; +} + +// `shrink` is s: each block is fitted against R_s = (1 - s) R + s I, which +// is never formed (DenseLd). [[cpp11::register]] -cpp11::writable::list lassosumRssRcpp(const doubles& zR, +cpp11::writable::list lassosumRssCpp(const doubles& zR, const list& LD, + double shrink, const doubles& lambdaR, double thr, int maxiter) { @@ -88,13 +111,11 @@ cpp11::writable::list lassosumRssRcpp(const doubles& zR, const mat& Rb = ld_blocks[b]; int s = block_start[b]; int e = block_end[b]; - vec diag_R = Rb.diag(); vec z_blk = z.subvec(s, e); vec beta_blk = beta.subvec(s, e); - vec Rbeta_blk = Rb * beta_blk; + DenseLd ld(Rb, shrink, beta_blk); - int conv_blk = elnet_rss(lambda(i), diag_R, Rb, z_blk, - thr, beta_blk, Rbeta_blk, maxiter); + int conv_blk = elnet_rss(lambda(i), ld, z_blk, thr, beta_blk, maxiter); beta.subvec(s, e) = beta_blk; out = std::min(out, conv_blk); } @@ -102,27 +123,58 @@ cpp11::writable::list lassosumRssRcpp(const doubles& zR, beta_mat.col(i) = beta; conv_vec(i) = out; - // Compute loss = beta'R beta - 2 z'beta (block-wise) + // Compute loss = beta'R_s beta - 2 z'beta (block-wise) double loss = -2.0 * dot(z, beta); for (int b = 0; b < n_blocks; b++) { const mat& Rb = ld_blocks[b]; int s = block_start[b]; int e = block_end[b]; vec beta_blk = beta.subvec(s, e); - loss += as_scalar(beta_blk.t() * Rb * beta_blk); + loss += (1.0 - shrink) * as_scalar(beta_blk.t() * Rb * beta_blk) + + shrink * dot(beta_blk, beta_blk); } loss_vec(i) = loss; fbeta_vec(i) = loss + 2.0 * lambda(i) * sum(abs(beta)); } - using namespace cpp11::literals; - writable::list result({ - "beta"_nm = as_doubles_matrix(beta_mat), - "lambda"_nm = as_doubles(lambda), - "conv"_nm = as_integers(conv_vec), - "loss"_nm = as_doubles(loss_vec), - "fbeta"_nm = as_doubles(fbeta_vec) - }); + return lassosum_path_result(beta_mat, lambda, conv_vec, loss_vec, fbeta_vec); +} - return result; +// lassosumRssCpp() for one LD block given by a factor F of R = F'F / (m - 1) +// and shrunk to R_s = (1 - s) R + s I: the same lambda path, the same updates, +// without forming R or R_s. +[[cpp11::register]] +cpp11::writable::list lassosumRssFactorCpp(const doubles& zR, + const doubles_matrix<>& factorR, + double shrink, + const doubles& lambdaR, + double thr, + int maxiter) { + vec z = as_Col(zR); + vec lambda = as_Col(lambdaR); + mat F = as_Mat(factorR); + if (F.n_cols != z.n_elem) + cpp11::stop("The LD factor has %d columns but there are %d z-scores.", + (int)F.n_cols, (int)z.n_elem); + + int p = z.n_elem; + int nlambda = lambda.n_elem; + mat beta_mat(p, nlambda, fill::zeros); + Col conv_vec(nlambda, fill::zeros); + vec loss_vec(nlambda, fill::zeros); + vec fbeta_vec(nlambda, fill::zeros); + + // Working beta vector — warm-started across lambda path + vec beta(p, fill::zeros); + + for (int i = 0; i < nlambda; i++) { + FactorLd ld(F, shrink, beta); + conv_vec(i) = elnet_rss(lambda(i), ld, z, thr, beta, maxiter); + beta_mat.col(i) = beta; + double loss = -2.0 * dot(z, beta) + ld.quad(beta); + loss_vec(i) = loss; + fbeta_vec(i) = loss + 2.0 * lambda(i) * sum(abs(beta)); + } + + return lassosum_path_result(beta_mat, lambda, conv_vec, loss_vec, fbeta_vec); } diff --git a/src/ld_prune.cpp b/src/ld_prune.cpp new file mode 100644 index 000000000..593f6cbb1 --- /dev/null +++ b/src/ld_prune.cpp @@ -0,0 +1,75 @@ +// Connected components of an LD threshold graph, for LD pruning. +// +// Single-linkage clustering cut at height 1 - threshold groups exactly the +// variants joined by a path of pairs with |r| >= threshold: the connected +// components of that graph. They are found here with a union-find over R's +// rows, computed a stripe at a time from the standardized dosages, so the +// p x p correlation matrix is never held. +#include +#include +#include +#include +#include + +using namespace cpp11; +using namespace arma; + +namespace { + +// The root of i's component, halving the path on the way up. +uword findRoot(std::vector& parent, uword i) { + while (parent[i] != i) { + parent[i] = parent[parent[i]]; + i = parent[i]; + } + return i; +} + +// Join the components of i and k under the smaller root, so every +// component's root is its smallest index. +void joinComponents(std::vector& parent, uword i, uword k) { + uword ri = findRoot(parent, i); + uword rk = findRoot(parent, k); + if (ri < rk) { + parent[rk] = ri; + } else if (rk < ri) { + parent[ri] = rk; + } +} + +} // namespace + +// Each variant's component in the graph joining variants whose |r| reaches +// `threshold`, labelled by the component's smallest (1-based) index. The +// correlation of columns j and k of `standardized` (samples x variants, each +// column centred and scaled to unit variance) is F_j'F_k / (m - 1). A pair is +// joined when 1 - |r| <= 1 - threshold: the test single-linkage clustering +// makes when it is cut at that height. +[[cpp11::register]] +cpp11::writable::integers ldThresholdComponents(const doubles_matrix<>& standardized, double threshold, + int stripe) { + mat F = as_Mat(standardized); + uword p = F.n_cols; + double scale = 1.0 / (static_cast(F.n_rows) - 1.0); + double cut = 1.0 - threshold; + std::vector parent(p); + std::iota(parent.begin(), parent.end(), 0); + for (uword start = 0; start < p; start += stripe) { + uword end = std::min(start + static_cast(stripe), p) - 1; + // Rows start..end of R against columns start..p-1: every pair (j, k) + // with k > j is met once, in the stripe holding j. + mat rows = F.cols(start, end).t() * F.cols(start, p - 1) * scale; + for (uword a = 0; a < rows.n_rows; ++a) { + for (uword b = a + 1; b < rows.n_cols; ++b) { + if (1.0 - std::abs(rows(a, b)) <= cut) { + joinComponents(parent, start + a, start + b); + } + } + } + } + cpp11::writable::integers labels(static_cast(p)); + for (uword i = 0; i < p; ++i) { + labels[static_cast(i)] = static_cast(findRoot(parent, i)) + 1; + } + return labels; +} diff --git a/src/penalized_rss.cpp b/src/penalized_rss.cpp index 324c0d93f..cf23efb5f 100644 --- a/src/penalized_rss.cpp +++ b/src/penalized_rss.cpp @@ -4,7 +4,8 @@ // LASSO, MCP, SCAD, L0, L0L1, L0L2 // // Objective (smooth part): min_beta beta'R beta - 2 beta'z + penalty(beta) -// where R is a (possibly pre-shrunk) LD matrix and z = bhat / sqrt(n). +// where R is the LD matrix shrunk to R_s = (1 - s) R + s I (s = `shrink`; +// 0 for an LD matrix already shrunk) and z = bhat / sqrt(n). // // The coordinate descent update is identical across penalties; only the // proximal/thresholding operator differs. MCP/SCAD operators are ported @@ -16,6 +17,8 @@ #include #include +#include "rss_ld.h" + using namespace cpp11; using namespace arma; @@ -152,11 +155,14 @@ static double compute_penalty(Penalty pen, const vec& beta, } // ---- Single-block coordinate descent ------------------------------------- +// `ld` answers R's entries for the current beta (rss_ld.h): DenseLd tracks +// R * beta as a running sum, FactorLd tracks F * beta. +template static int penalized_cd_rss(Penalty pen, double lambda, double gamma, double alpha, double lambda0, double lambda2, - const vec& diag_R, const mat& R, const vec& z, - double thr, vec& beta, vec& Rbeta, int maxiter) { + Ld& ld, const vec& z, + double thr, vec& beta, int maxiter) { int p = z.n_elem; double l1, l2; @@ -176,17 +182,18 @@ static int penalized_cd_rss(Penalty pen, double lambda, double gamma, double dlx = 0.0; for (int j = 0; j < p; j++) { double bj = beta(j); + double v = ld.diag(j); // Partial correlation: z_j - sum_{k!=j} R[j,k]*beta[k] - double t = z(j) - Rbeta(j) + diag_R(j) * bj; + double t = z(j) - ld.row(j, beta) + v * bj; // Apply penalty-specific thresholding - beta(j) = apply_threshold(pen, t, diag_R(j), l1, l2, gamma, lambda0); + beta(j) = apply_threshold(pen, t, v, l1, l2, gamma, lambda0); if (beta(j) == bj) continue; double del = beta(j) - bj; dlx = std::max(dlx, std::abs(del)); - // Update running Rbeta - Rbeta += del * R.col(j); + // Update the running R * beta + ld.update(j, del); } cpp11::check_user_interrupt(); if (dlx < thr) { @@ -202,9 +209,10 @@ static int penalized_cd_rss(Penalty pen, double lambda, double gamma, // with zero ones that have higher correlation with the residual. // Ported from L0Learn CDL012Swaps.cpp. +template static bool l0_swap_round(double lambda0, double l1, double l2, - const vec& diag_R, const mat& R, const vec& z, - double thr, vec& beta, vec& Rbeta, int maxiter) { + Ld& ld, const vec& z, + double thr, vec& beta, int maxiter) { int p = beta.n_elem; bool found_better = false; @@ -217,7 +225,7 @@ static bool l0_swap_round(double lambda0, double l1, double l2, int i = nnz_idx[ii]; // Compute partial correlation for all variables with beta[i] added back // riX_j = z_j - Rbeta_j + R_ji * beta_i - vec riX = z - Rbeta + R.col(i) * beta(i); + vec riX = z - ld.product(beta) + ld.column(i) * beta(i); double max_corr = -1.0; int max_idx = -1; @@ -230,23 +238,23 @@ static bool l0_swap_round(double lambda0, double l1, double l2, if (max_idx < 0) continue; // Check if swap is worthwhile - double denom = diag_R(max_idx) + 2.0 * l2; + double denom = ld.diag(max_idx) + 2.0 * l2; if (max_corr > denom * std::abs(beta(i)) + l1) { // Perform swap: zero out i, set j to optimal double old_bi = beta(i); beta(i) = 0.0; - Rbeta -= old_bi * R.col(i); + ld.update(i, -old_bi); - double t_j = z(max_idx) - Rbeta(max_idx) + diag_R(max_idx) * 0.0; - beta(max_idx) = l0_thresh(t_j, lambda0, l1, l2, diag_R(max_idx)); + double t_j = z(max_idx) - ld.row(max_idx, beta) + ld.diag(max_idx) * 0.0; + beta(max_idx) = l0_thresh(t_j, lambda0, l1, l2, ld.diag(max_idx)); if (beta(max_idx) != 0.0) { - Rbeta += beta(max_idx) * R.col(max_idx); + ld.update(max_idx, beta(max_idx)); } // Re-run CD from swapped solution. // For PEN_L0: inside penalized_cd_rss, l1 = lambda param, l2 = lambda2. penalized_cd_rss(PEN_L0, l1, 0.0, 1.0, lambda0, l2, - diag_R, R, z, thr, beta, Rbeta, maxiter); + ld, z, thr, beta, maxiter); found_better = true; break; // restart from scratch } @@ -254,12 +262,52 @@ static bool l0_swap_round(double lambda0, double l1, double l2, return found_better; } -// ---- Registered entry point ---------------------------------------------- +// ---- One block at one lambda: coordinate descent, then the L0 swaps ------ + +template +static int penalized_block(Penalty pen, double lambda, double gamma, + double alpha, double lambda0, double lambda2, + Ld& ld, const vec& z, double thr, vec& beta, + int maxiter, int maxSwaps) { + int conv = penalized_cd_rss(pen, lambda, gamma, alpha, lambda0, lambda2, + ld, z, thr, beta, maxiter); + // L0 swap phase (per block) + if (pen == PEN_L0 && maxSwaps > 0) { + for (int sw = 0; sw < maxSwaps; sw++) { + bool improved = l0_swap_round(lambda0, lambda, lambda2, ld, z, thr, + beta, maxiter); + if (!improved) break; + } + } + return conv; +} + +// The lambda path's results, in the shape both entry points return. +static cpp11::writable::list penalized_path_result(const mat& beta_mat, + const vec& lambda, + const Col& conv_vec, + const vec& loss_vec, + const vec& fbeta_vec) { + using namespace cpp11::literals; + writable::list result({ + "beta"_nm = as_doubles_matrix(beta_mat), + "lambda"_nm = as_doubles(lambda), + "conv"_nm = as_integers(conv_vec), + "loss"_nm = as_doubles(loss_vec), + "fbeta"_nm = as_doubles(fbeta_vec) + }); + return result; +} +// ---- Registered entry points --------------------------------------------- + +// `shrink` is s: each block is fitted against R_s = (1 - s) R + s I, which +// is never formed (DenseLd). [[cpp11::register]] -cpp11::writable::list penalizedRssRcpp( +cpp11::writable::list penalizedRssCpp( const doubles& zR, const list& LD, + double shrink, const doubles& lambdaR, const std::string& penaltyStr, double gamma, @@ -305,26 +353,13 @@ cpp11::writable::list penalizedRssRcpp( const mat& Rb = ld_blocks[b]; int s = block_start[b]; int e = block_end[b]; - vec diag_R = Rb.diag(); vec z_blk = z.subvec(s, e); vec beta_blk = beta.subvec(s, e); - vec Rbeta_blk = Rb * beta_blk; - - int conv_blk = penalized_cd_rss(pen, lambda(i), gamma, alpha, - lambda0, lambda2, - diag_R, Rb, z_blk, thr, - beta_blk, Rbeta_blk, maxiter); - - // L0 swap phase (per block) - if (pen == PEN_L0 && maxSwaps > 0) { - for (int sw = 0; sw < maxSwaps; sw++) { - bool improved = l0_swap_round(lambda0, lambda(i), lambda2, - diag_R, Rb, z_blk, thr, - beta_blk, Rbeta_blk, maxiter); - if (!improved) break; - } - } + DenseLd ld(Rb, shrink, beta_blk); + int conv_blk = penalized_block(pen, lambda(i), gamma, alpha, lambda0, + lambda2, ld, z_blk, thr, beta_blk, + maxiter, maxSwaps); beta.subvec(s, e) = beta_blk; out = std::min(out, conv_blk); } @@ -332,28 +367,70 @@ cpp11::writable::list penalizedRssRcpp( beta_mat.col(i) = beta; conv_vec(i) = out; - // Compute loss = beta'R beta - 2 z'beta (block-wise) + // Compute loss = beta'R_s beta - 2 z'beta (block-wise) double loss = -2.0 * dot(z, beta); for (int b = 0; b < n_blocks; b++) { const mat& Rb = ld_blocks[b]; int s = block_start[b]; int e = block_end[b]; vec beta_blk = beta.subvec(s, e); - loss += as_scalar(beta_blk.t() * Rb * beta_blk); + loss += (1.0 - shrink) * as_scalar(beta_blk.t() * Rb * beta_blk) + + shrink * dot(beta_blk, beta_blk); } loss_vec(i) = loss; fbeta_vec(i) = loss + compute_penalty(pen, beta, lambda(i), alpha, gamma, lambda0, lambda2); } - using namespace cpp11::literals; - writable::list result({ - "beta"_nm = as_doubles_matrix(beta_mat), - "lambda"_nm = as_doubles(lambda), - "conv"_nm = as_integers(conv_vec), - "loss"_nm = as_doubles(loss_vec), - "fbeta"_nm = as_doubles(fbeta_vec) - }); + return penalized_path_result(beta_mat, lambda, conv_vec, loss_vec, fbeta_vec); +} - return result; +// penalizedRssCpp() for one LD block given by a factor F of R = F'F / (m - 1) +// and shrunk to R_s = (1 - s) R + s I: the same lambda path, the same updates +// and swaps, without forming R or R_s. +[[cpp11::register]] +cpp11::writable::list penalizedRssFactorCpp( + const doubles& zR, + const doubles_matrix<>& factorR, + double shrink, + const doubles& lambdaR, + const std::string& penaltyStr, + double gamma, + double alpha, + double lambda0, + double lambda2, + double thr, + int maxiter, + int maxSwaps) { + + Penalty pen = parse_penalty(penaltyStr); + vec z = as_Col(zR); + vec lambda = as_Col(lambdaR); + mat F = as_Mat(factorR); + if (F.n_cols != z.n_elem) + cpp11::stop("The LD factor has %d columns but there are %d z-scores.", + (int)F.n_cols, (int)z.n_elem); + + int p = z.n_elem; + int nlambda = lambda.n_elem; + mat beta_mat(p, nlambda, fill::zeros); + Col conv_vec(nlambda, fill::zeros); + vec loss_vec(nlambda, fill::zeros); + vec fbeta_vec(nlambda, fill::zeros); + + // Working beta — warm-started across lambda path + vec beta(p, fill::zeros); + + for (int i = 0; i < nlambda; i++) { + FactorLd ld(F, shrink, beta); + conv_vec(i) = penalized_block(pen, lambda(i), gamma, alpha, lambda0, + lambda2, ld, z, thr, beta, maxiter, maxSwaps); + beta_mat.col(i) = beta; + double loss = -2.0 * dot(z, beta) + ld.quad(beta); + loss_vec(i) = loss; + fbeta_vec(i) = loss + compute_penalty(pen, beta, lambda(i), alpha, + gamma, lambda0, lambda2); + } + + return penalized_path_result(beta_mat, lambda, conv_vec, loss_vec, fbeta_vec); } diff --git a/src/prscs_mcmc.cpp b/src/prscs_mcmc.cpp index 9f934f241..7c6e6834f 100644 --- a/src/prscs_mcmc.cpp +++ b/src/prscs_mcmc.cpp @@ -1,39 +1,26 @@ /** - * @file prs_cs_wrapper.cpp - * @brief cpp11 wrapper for the prs_cs function. + * @file prscs_mcmc.cpp + * @brief cpp11 entry points for the PRS-CS sampler (prscs_mcmc.h). */ #include #include +#include +#include #include "prscs_mcmc.h" using namespace cpp11; using namespace arma; -/** - * @brief cpp11 wrapper for the prs_cs function. - * - * @param a Shape parameter for the prior distribution of psi. - * @param b Scale parameter for the prior distribution of psi. - * @param phi Global shrinkage parameter. If NULL, it will be estimated automatically. - * @param bhat Vector of effect sizes. - * @param maf Vector of minor allele frequencies. If NULL, it is assumed to be a vector of zeros. - * @param n Sample size. - * @param ldBlk List of LD blocks. - * @param nIter Number of MCMC iterations. - * @param nBurnin Number of burn-in iterations. - * @param thin Thinning interval. - * @param verbose Whether to print verbose output. - * @param seed Random seed. If NULL, no seed is set. - * @return A list containing the posterior estimates. - */ -[[cpp11::register]] -cpp11::writable::list prsCsRcpp(double a, double b, sexp phi, - doubles bhat, sexp maf, - int n, list ldBlk, - int nIter, int nBurnin, int thin, - bool verbose, sexp seed) { - // Convert cpp11 types to C++ types +namespace { + +// Run the sampler on `ld_blk` with the arguments as R passes them: a NULL +// `maf` is a vector of zeros, a NULL `phi` is learned from the data, and a +// NULL `seed` draws one. +template +cpp11::writable::list prs_cs_run(double a, double b, sexp phi, doubles bhat, sexp maf, int n, + const std::vector& ld_blk, int nIter, int nBurnin, + int thin, bool verbose, sexp seed) { std::vector bhat_vec = cpp11::as_cpp>(bhat); std::vector maf_vec; if (maf != R_NilValue) { @@ -42,11 +29,6 @@ cpp11::writable::list prsCsRcpp(double a, double b, sexp phi, maf_vec = std::vector(bhat_vec.size(), 0.0); // Populate with zeros if maf is NULL } - std::vector ld_blk_vec; - for (int i = 0; i < ldBlk.size(); ++i) { - ld_blk_vec.push_back(as_Mat(doubles_matrix<>(ldBlk[i]))); - } - // Use stack variable to avoid heap allocation and memory leak risk. double phi_val = 0.0; double* phi_ptr = nullptr; @@ -62,10 +44,9 @@ cpp11::writable::list prsCsRcpp(double a, double b, sexp phi, seed_val = std::random_device{}(); } - std::map output = prs_cs_mcmc(a, b, phi_ptr, bhat_vec, maf_vec, n, ld_blk_vec, - nIter, nBurnin, thin, verbose, seed_val); + std::map output = prs_cs_mcmc(a, b, phi_ptr, bhat_vec, maf_vec, n, ld_blk, + nIter, nBurnin, thin, verbose, seed_val); - // Convert the output to a list using namespace cpp11::literals; writable::list result({ "betaEst"_nm = as_doubles(output["beta_est"]), @@ -73,6 +54,58 @@ cpp11::writable::list prsCsRcpp(double a, double b, sexp phi, "sigmaEst"_nm = cpp11::as_sexp(output["sigma_est"](0)), "phiEst"_nm = cpp11::as_sexp(output["phi_est"](0)) }); - return result; } + +} // namespace + +/** + * @brief PRS-CS from LD matrices. + * + * @param a Shape parameter for the prior distribution of psi. + * @param b Scale parameter for the prior distribution of psi. + * @param phi Global shrinkage parameter. If NULL, it will be estimated automatically. + * @param bhat Vector of effect sizes. + * @param maf Vector of minor allele frequencies. If NULL, it is assumed to be a vector of zeros. + * @param n Sample size. + * @param ldBlk List of LD blocks. + * @param nIter Number of MCMC iterations. + * @param nBurnin Number of burn-in iterations. + * @param thin Thinning interval. + * @param verbose Whether to print verbose output. + * @param seed Random seed. If NULL, no seed is set. + * @return A list containing the posterior estimates. + */ +[[cpp11::register]] +cpp11::writable::list prsCsCpp(double a, double b, sexp phi, + doubles bhat, sexp maf, + int n, list ldBlk, + int nIter, int nBurnin, int thin, + bool verbose, sexp seed) { + std::vector ld_blk_vec; + for (int i = 0; i < ldBlk.size(); ++i) { + ld_blk_vec.emplace_back(as_Mat(doubles_matrix<>(ldBlk[i]))); + } + return prs_cs_run(a, b, phi, bhat, maf, n, ld_blk_vec, nIter, nBurnin, thin, verbose, seed); +} + +/** + * @brief PRS-CS from a factor F of one LD block, R = F'F / (m - 1), never forming R. + * + * The arguments are prsCsCpp()'s with `factorR` in place of the LD blocks. The chain + * targets the same posterior as prsCsCpp() on R but draws differently (FactorLdBlock). + */ +[[cpp11::register]] +cpp11::writable::list prsCsFactorCpp(double a, double b, sexp phi, + doubles bhat, sexp maf, + int n, const doubles_matrix<>& factorR, + int nIter, int nBurnin, int thin, + bool verbose, sexp seed) { + mat F = as_Mat(factorR); + if (F.n_cols != static_cast(bhat.size())) + cpp11::stop("The LD factor has %d columns but there are %d effects.", + (int)F.n_cols, (int)bhat.size()); + std::vector ld_blk_vec; + ld_blk_vec.emplace_back(F / std::sqrt(static_cast(F.n_rows) - 1.0)); + return prs_cs_run(a, b, phi, bhat, maf, n, ld_blk_vec, nIter, nBurnin, thin, verbose, seed); +} diff --git a/src/prscs_mcmc.h b/src/prscs_mcmc.h index 70e9c9ad5..ae44b1e44 100644 --- a/src/prscs_mcmc.h +++ b/src/prscs_mcmc.h @@ -7,6 +7,7 @@ #define MCMC_HPP #include +#include #include #include #include @@ -171,6 +172,84 @@ double gigrnd(double p, double a, double b, std::mt19937& rng) { return result; } +/** + * @brief One LD block's update of beta in the PRS-CS sampler, from the block's LD matrix R. + * + * Draws beta ~ N(A^-1 b, (sigma / n) A^-1) with A = R + diag(1 / psi) and b the block's + * marginal effects, through the Cholesky factor of A, and returns beta'A beta for the + * update of sigma. + */ +class DenseLdBlock { +public: + explicit DenseLdBlock(arma::mat R) : R_(std::move(R)) {} + + arma::uword size() const { return R_.n_rows; } + + double draw(const arma::vec& psi, const arma::vec& b, double scale, + std::normal_distribution& normal_dist, std::mt19937& rng, + arma::vec& beta) const { + arma::mat dinvt = R_ + arma::diagmat(1.0 / psi); + arma::mat dinvt_chol = arma::chol(dinvt); + arma::vec beta_tmp = arma::solve(arma::trimatl(dinvt_chol.t()), b) + + arma::vec(R_.n_rows).transform([&](double) { + return normal_dist(rng); + }) * std::sqrt(scale); + beta = arma::solve(arma::trimatu(dinvt_chol), beta_tmp); + return arma::as_scalar(beta.t() * dinvt * beta); + } + +private: + arma::mat R_; +}; + +/** + * @brief One LD block's update of beta in the PRS-CS sampler, from a factor W of the + * block's LD, R = W'W (W is m x p). + * + * The same draw as DenseLdBlock without forming R or A. With D = diag(psi) and + * M = W D W' + I (m x m), Woodbury gives A^-1 = D - D W' M^-1 W D, so the mean A^-1 b + * costs one solve against M, and the noise comes from the sampler of Bhattacharya, + * Chakraborty and Mallick (2016): u ~ N(0, D), delta ~ N(0, I), v = W u + delta, + * theta = u - D W' M^-1 v is N(0, A^-1). One Cholesky factor of M serves both, at + * O(m^2 p + m^3) per draw instead of the O(p^3) of factoring A. The draws consume the + * random stream differently from DenseLdBlock's, so the two samplers agree in + * distribution, not draw for draw. + */ +class FactorLdBlock { +public: + explicit FactorLdBlock(arma::mat W) : W_(std::move(W)) {} + + arma::uword size() const { return W_.n_cols; } + + double draw(const arma::vec& psi, const arma::vec& b, double scale, + std::normal_distribution& normal_dist, std::mt19937& rng, + arma::vec& beta) const { + arma::uword p = W_.n_cols; + arma::uword m = W_.n_rows; + arma::mat WD = W_.each_row() % psi.t(); + arma::mat M = WD * W_.t(); + M.diag() += 1.0; + arma::mat L = arma::chol(M, "lower"); + arma::vec mean = psi % b - WD.t() * solveChol(L, WD * b); + arma::vec u = arma::sqrt(psi) % arma::vec(p).transform([&](double) { + return normal_dist(rng); + }); + arma::vec delta = arma::vec(m).transform([&](double) { return normal_dist(rng); }); + arma::vec theta = u - WD.t() * solveChol(L, W_ * u + delta); + beta = mean + std::sqrt(scale) * theta; + arma::vec Wbeta = W_ * beta; + return arma::dot(Wbeta, Wbeta) + arma::sum(arma::square(beta) / psi); + } + +private: + arma::mat W_; + + // M^-1 x from the lower Cholesky factor L of M. + static arma::vec solveChol(const arma::mat& L, const arma::vec& x) { + return arma::solve(arma::trimatu(L.t()), arma::solve(arma::trimatl(L), x)); + } +}; + /** * @brief Markov Chain Monte Carlo (MCMC) sampler for polygenic prediction with continuous shrinkage (CS) priors. * @@ -180,7 +259,7 @@ double gigrnd(double p, double a, double b, std::mt19937& rng) { * @param bhat Vector of effect sizes. * @param maf Vector of minor allele frequencies. * @param n Sample size. - * @param ld_blk List of LD blocks. + * @param ld_blk The LD blocks, each a DenseLdBlock or each a FactorLdBlock. * @param n_iter Number of MCMC iterations. * @param n_burnin Number of burn-in iterations. * @param thin Thinning interval. @@ -188,9 +267,10 @@ double gigrnd(double p, double a, double b, std::mt19937& rng) { * @param seed Random seed. If nullptr, no seed is set. * @return A map containing the posterior estimates. */ +template std::map prs_cs_mcmc(double a, double b, double* phi, const std::vector& bhat, const std::vector& maf, - int n, const std::vector& ld_blk, + int n, const std::vector& ld_blk, int n_iter, int n_burnin, int thin, bool verbose, unsigned int seed) { if (verbose) { @@ -199,7 +279,6 @@ std::map prs_cs_mcmc(double a, double b, double* phi, // Derived statistics arma::vec beta_mrg(bhat); - // std::cout << "beta_mrg " << beta_mrg << std::endl; int n_pst = (n_iter - n_burnin) / thin; int p = beta_mrg.n_elem; @@ -234,29 +313,19 @@ std::map prs_cs_mcmc(double a, double b, double* phi, int mm = 0; double quad = 0.0; for (std::size_t kk = 0; kk < ld_blk.size(); ++kk) { - if (ld_blk[kk].n_rows == 0) { + if (ld_blk[kk].size() == 0) { continue; } - arma::uvec idx_blk = arma::regspace(mm, mm + ld_blk[kk].n_rows - 1); - mm += ld_blk[kk].n_rows; - - arma::mat dinvt = ld_blk[kk] + arma::diagmat(1.0 / psi.elem(idx_blk)); - - arma::mat dinvt_chol = arma::chol(dinvt); - - arma::vec beta_tmp = arma::solve(arma::trimatl(dinvt_chol.t()), beta_mrg(idx_blk)) + - arma::vec(ld_blk[kk].n_rows).transform([&](double) { - return normal_dist(rng); - }) * std::sqrt(sigma / n); - // std::cout << "beta_tmp " << beta_tmp << std::endl; - beta(idx_blk) = arma::solve(arma::trimatu(dinvt_chol), beta_tmp); + arma::uvec idx_blk = arma::regspace(mm, mm + ld_blk[kk].size() - 1); + mm += ld_blk[kk].size(); - quad += arma::as_scalar(beta(idx_blk).t() * dinvt * beta(idx_blk)); - // std::cout << "quad " << quad << std::endl; + arma::vec beta_blk; + quad += ld_blk[kk].draw(psi.elem(idx_blk), beta_mrg(idx_blk), sigma / n, + normal_dist, rng, beta_blk); + beta(idx_blk) = beta_blk; } - // std::cout << "beta " << beta << std::endl; - double err = std::max(n / 2.0 * (1.0 - 2.0 * arma::dot(beta, beta_mrg) + quad), + double err = std::max(n / 2.0 * (1.0 - 2.0 * arma::dot(beta, beta_mrg) + quad), n / 2.0 * arma::sum(arma::pow(beta, 2) / psi)); // Original PRS-CS (Ge et al.): sigma = 1/Gamma((n+p)/2, scale=1/err) diff --git a/src/qtl_enrichment.cpp b/src/qtl_enrichment.cpp index 6efa5f0cc..6fad0cce0 100644 --- a/src/qtl_enrichment.cpp +++ b/src/qtl_enrichment.cpp @@ -1,7 +1,7 @@ #include "qtl_enrichment.h" [[cpp11::register]] -cpp11::writable::list qtlEnrichmentRcpp( +cpp11::writable::list qtlEnrichmentCpp( SEXP rGwasPip, SEXP rQtlSusieFit, double piGwas = 0, double piQtl = 0, int ImpN = 25, double shrinkageLambda = 1.0, diff --git a/src/rss_ld.h b/src/rss_ld.h new file mode 100644 index 000000000..e69116797 --- /dev/null +++ b/src/rss_ld.h @@ -0,0 +1,89 @@ +// rss_ld.h -- the LD a coordinate-descent RSS solve reads. +// +// The solvers in lassosum_rss.cpp and penalized_rss.cpp minimise +// beta'R_s beta - 2 beta'z + penalty(beta) for R_s = (1 - s) R + s I. They +// only ever ask R_s four things: a diagonal entry, one entry of R_s beta for +// the current beta, the effect of changing one coordinate, and (for the L0 +// swaps) a whole column or product. Each class below answers those from one +// way of holding R_s, so a solver templated on it runs unchanged on either. +#pragma once + +#include + +// R held whole, with R_s = (1 - s) R + s I applied on the fly and Rbeta = +// R beta kept as a running sum (the genotype-free analogue of tracking +// yhat = X beta), so a shrinkage grid reuses the one matrix rather than +// forming R_s for each s. With s = 0 every answer is R's own, bit for bit. +class DenseLd { +public: + DenseLd(const arma::mat& R, double s, const arma::vec& beta) + : R_(R), s_(s), c_(1.0 - s), Rbeta_(R * beta) {} + + double diag(arma::uword j) const { return c_ * R_(j, j) + s_; } + + // (R_s beta)_j for the current beta. + double row(arma::uword j, const arma::vec& beta) const { + return c_ * Rbeta_(j) + s_ * beta(j); + } + + // Coordinate j of beta changed by `del`. + void update(arma::uword j, double del) { Rbeta_ += del * R_.col(j); } + + // R_s beta for the current beta, and column j of R_s. + arma::vec product(const arma::vec& beta) const { return c_ * Rbeta_ + s_ * beta; } + arma::vec column(arma::uword j) const { + arma::vec col = c_ * R_.col(j); + col(j) += s_; + return col; + } + + // beta'R_s beta, recomputed from R. + double quad(const arma::vec& beta) const { + return c_ * arma::as_scalar(beta.t() * R_ * beta) + s_ * arma::dot(beta, beta); + } + +private: + const arma::mat& R_; + double s_; + double c_; + arma::vec Rbeta_; +}; + +// R = F'F / (m - 1) held as its factor F (m x p), with R_s = (1 - s) R + s I. +// It keeps u = F beta instead of R_s beta, so with c = (1 - s) / (m - 1), +// (R_s beta)_j = c f_j'u + s beta_j: a coordinate step costs O(m) rather than +// O(p), and neither R nor R_s is ever formed. +class FactorLd { +public: + FactorLd(const arma::mat& F, double s, const arma::vec& beta) + : F_(F), s_(s), c_((1.0 - s) / (static_cast(F.n_rows) - 1.0)), u_(F * beta), + diag_(c_ * arma::sum(arma::square(F), 0).t() + s) {} + + double diag(arma::uword j) const { return diag_(j); } + + double row(arma::uword j, const arma::vec& beta) const { + return c_ * arma::dot(F_.col(j), u_) + s_ * beta(j); + } + + void update(arma::uword j, double del) { u_ += del * F_.col(j); } + + arma::vec product(const arma::vec& beta) const { return c_ * (F_.t() * u_) + s_ * beta; } + + arma::vec column(arma::uword j) const { + arma::vec col = c_ * (F_.t() * F_.col(j)); + col(j) += s_; + return col; + } + + double quad(const arma::vec& beta) const { + arma::vec Fb = F_ * beta; + return c_ * arma::dot(Fb, Fb) + s_ * arma::dot(beta, beta); + } + +private: + const arma::mat& F_; + double s_; + double c_; + arma::vec u_; + arma::vec diag_; +}; diff --git a/src/sdpr.cpp b/src/sdpr.cpp index 80830920d..6ba35b40b 100644 --- a/src/sdpr.cpp +++ b/src/sdpr.cpp @@ -7,9 +7,55 @@ using namespace cpp11; using namespace arma; +namespace { + +// The per-SNP data as R passes it: the marginal betas deflated by `c`, a NULL +// perVariantSampleSize is n for every SNP, and a NULL array is array 1 for +// every SNP. +mcmc_data sdpr_data(const doubles& bhatR, const std::vector& block_sizes, + int n, sexp perVariantSampleSize, sexp array, double c) { + std::vector bhat = cpp11::as_cpp>(bhatR); + // Deflation correction + for (size_t i = 0; i < bhat.size(); i++) { + bhat[i] /= c; + } + std::vector sz; + std::vector arr; + if (perVariantSampleSize != R_NilValue) { + sz = cpp11::as_cpp>(perVariantSampleSize); + } else { + sz = std::vector(bhat.size(), n); + } + if (array != R_NilValue) { + arr = cpp11::as_cpp>(array); + } else { + arr = std::vector(bhat.size(), 1); + } + return mcmc_data(bhat, block_sizes, sz, arr); +} + +// The seed R passes, or a drawn one for NULL. +unsigned int sdpr_seed(sexp seed) { + if (seed != R_NilValue) { + return cpp11::as_cpp(seed); + } + return std::random_device{}(); +} + +cpp11::writable::list sdpr_output(std::unordered_map& results) { + using namespace cpp11::literals; + writable::list output({ + "betaEst"_nm = as_doubles(results["beta"]), + "h2"_nm = as_doubles(results["h2"]) + }); + return output; +} + +} // namespace + // cpp11 interface function [[cpp11::register]] -cpp11::writable::list sdprRcpp( +cpp11::writable::list sdprCpp( const doubles& bhatR, const list& LD, int n, @@ -28,51 +74,66 @@ cpp11::writable::list sdprRcpp( bool verbose = true, sexp seed = R_NilValue ) { - // Convert inputs to C++ types - std::vector bhat = cpp11::as_cpp>(bhatR); - // Convert list to std::vector std::vector ref_ld_mat; + std::vector block_sizes; for (int i = 0; i < LD.size(); i++) { ref_ld_mat.push_back(as_Mat(doubles_matrix<>(LD[i]))); + block_sizes.push_back(ref_ld_mat.back().n_rows); } - // Initialize perVariantSampleSize and array if NULL - std::vector sz; - std::vector arr; - if (perVariantSampleSize != R_NilValue) { - sz = cpp11::as_cpp>(perVariantSampleSize); - } else { - sz = std::vector(bhat.size(), n); - } - if (array != R_NilValue) { - arr = cpp11::as_cpp>(array); - } else { - arr = std::vector(bhat.size(), 1); - } - - // Resolve seed - unsigned int seed_val = 0; - if (seed != R_NilValue) { - seed_val = cpp11::as_cpp(seed); - } else { - seed_val = std::random_device{}(); - } - - // Create mcmc_data object - mcmc_data data(bhat, ref_ld_mat, sz, arr); + mcmc_data data = sdpr_data(bhatR, block_sizes, n, perVariantSampleSize, array, c); + std::vector blocks = + sdpr_dense_blocks(data, std::move(ref_ld_mat), a, n, optLlk); - // Call the mcmc function std::unordered_map results = mcmc( - data, n, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed_val + data, blocks, M, a0k, b0k, iter, burn, thin, numThreads, verbose, + sdpr_seed(seed) ); + return sdpr_output(results); +} - // Convert results to list - using namespace cpp11::literals; - writable::list output({ - "betaEst"_nm = as_doubles(results["beta"]), - "h2"_nm = as_doubles(results["h2"]) - }); +/** + * @brief SDPR from a factor F of the LD, R = F'F / (m - 1), never forming R. + * + * The arguments are sdprCpp()'s with `factorR` (m x p) in place of the LD + * blocks; the window is one block. The sampler is SDPR's own, run on the + * low-rank form of its matrices (sdpr_factor_block()), so it draws as + * sdprCpp() does on the matrix the factor gives. + */ +[[cpp11::register]] +cpp11::writable::list sdprFactorCpp( + const doubles& bhatR, + const doubles_matrix<>& factorR, + int n, + sexp perVariantSampleSize = R_NilValue, + sexp array = R_NilValue, + double a = 0.1, + double c = 1.0, + int M = 1000, + double a0k = 0.5, + double b0k = 0.5, + int iter = 1000, + int burn = 200, + int thin = 5, + int numThreads = 1, + int optLlk = 1, + bool verbose = true, + sexp seed = R_NilValue + ) { + mat F = as_Mat(factorR); + if (F.n_cols != static_cast(bhatR.size())) + cpp11::stop("The LD factor has %d columns but there are %d effects.", + (int)F.n_cols, (int)bhatR.size()); - return output; + mcmc_data data = sdpr_data(bhatR, {F.n_cols}, n, perVariantSampleSize, array, c); + std::vector blocks = { + sdpr_factor_block(data, F, a, n, optLlk) + }; + + std::unordered_map results = mcmc( + data, blocks, M, a0k, b0k, iter, burn, thin, numThreads, verbose, + sdpr_seed(seed) + ); + return sdpr_output(results); } diff --git a/src/sdpr_mcmc.cpp b/src/sdpr_mcmc.cpp index 0abd42bc2..e09c5b1e8 100644 --- a/src/sdpr_mcmc.cpp +++ b/src/sdpr_mcmc.cpp @@ -4,7 +4,7 @@ // (https://github.com/eldronzhou/SDPR), which used GSL + x86 SSE intrinsics. // // Translation strategy: -// GSL gsl_blas_dsymv -> arma::symmatu(M) * v +// GSL gsl_blas_dsymv -> M * v, with M symmetrized once when it is built // GSL gsl_blas_dgemv -> A.t() * v // GSL gsl_blas_dgemm -> A * B // GSL gsl_blas_dtrsv -> arma::solve(trimatl(L), v) @@ -22,6 +22,10 @@ // (arma::log, arma::exp, arma::max, arma::accu) which delegate to // platform-optimal SIMD (NEON on ARM, SSE/AVX on x86) through the // underlying BLAS/compiler auto-vectorization. +// +// The sampler reads each LD block through a block type (sdpr_mcmc.h): the +// dense matrices SDPR itself precomputes (sdpr_dense_blocks()), or their +// low-rank form from a factor of the LD (sdpr_factor_block()). #include #include @@ -40,7 +44,9 @@ using std::thread; using std::ref; using std::vector; using std::ofstream; using std::string; using std::min; -#define square(x) ((x)*(x)) +// A function rather than the original macro, which would also expand inside +// arma::square(). +static inline double square(double x) { return x * x; } // --------------------------------------------------------------------------- // sample_sigma2: Sample cluster variances from inverse-gamma posterior @@ -72,20 +78,20 @@ void MCMC_state::sample_sigma2() { // gsl_blas_dsymv(CblasUpper, -eta*eta, B, beta, eta*eta, b) // gsl_blas_daxpy(eta, calc_b_tmp, b) // --------------------------------------------------------------------------- +template void MCMC_state::calc_b(size_t j, const mcmc_data &dat, - const ldmat_data &ldmat_dat) { + const std::vector &blocks) { size_t start_i = dat.boundary[j].first; size_t end_i = dat.boundary[j].second; arma::vec beta_j = beta.subvec(start_i, end_i - 1); - arma::vec diag_B = ldmat_dat.B[j].diag(); // Original GSL: b = eta^2 * diag(B)*beta; // b = eta^2*b - eta^2 * B*beta (via dsymv with alpha=-eta^2, beta=eta^2) // b += eta * calc_b_tmp - arma::vec b_j = eta * eta * (diag_B % beta_j - - arma::symmatu(ldmat_dat.B[j]) * beta_j) - + eta * ldmat_dat.calc_b_tmp[j]; + arma::vec b_j = eta * eta * (blocks[j].diag_B % beta_j + - blocks[j].B_times(beta_j)) + + eta * blocks[j].calc_b_tmp; b.subvec(start_i, end_i - 1) = b_j; } @@ -103,8 +109,9 @@ void MCMC_state::calc_b(size_t j, const mcmc_data &dat, // C_k = eta^2 * N * B[i,i] * var_k + 1 // log P(z_i=k) = -0.5*log(C_k) + log(p_k) + (N*b_i)^2 * var_k / (2*C_k) // --------------------------------------------------------------------------- +template void MCMC_state::sample_assignment(size_t j, const mcmc_data &dat, - const ldmat_data &ldmat_dat) { + const std::vector &blocks) { size_t start_i = dat.boundary[j].first; size_t end_i = dat.boundary[j].second; size_t n_snp_blk = end_i - start_i; @@ -124,7 +131,7 @@ void MCMC_state::sample_assignment(size_t j, const mcmc_data &dat, } for (size_t i = 0; i < n_snp_blk; i++) { - float Bjj_i = static_cast(ldmat_dat.B[j](i, i)); + float Bjj_i = static_cast(blocks[j].diag_B(i)); float bj_i = static_cast(b(start_i + i)); float rnd_i = unif(r); @@ -249,8 +256,9 @@ void MCMC_state::sample_alpha() { // Original: mcmc.cpp lines 239-329 // Uses gsl_linalg_cholesky_decomp1, gsl_blas_dtrsv for forward/back-solve // --------------------------------------------------------------------------- +template void MCMC_state::sample_beta(size_t j, const mcmc_data &dat, - ldmat_data &ldmat_dat) { + const std::vector &blocks) { size_t start_i = dat.boundary[j].first; size_t end_i = dat.boundary[j].second; @@ -266,8 +274,8 @@ void MCMC_state::sample_beta(size_t j, const mcmc_data &dat, beta.subvec(start_i, end_i - 1).zeros(); if (causal_list.empty()) { - ldmat_dat.num[j] = 0; - ldmat_dat.denom[j] = 0; + num[j] = 0; + denom[j] = 0; return; } @@ -276,15 +284,14 @@ void MCMC_state::sample_beta(size_t j, const mcmc_data &dat, if (causal_list.size() == 1) { double var_k = cluster_var[cls_assgn[causal_list[0]]]; double bj = b(causal_list[0]); - double Bjj = ldmat_dat.B[j](causal_list[0] - start_i, - causal_list[0] - start_i); + double Bjj = blocks[j].diag_B(causal_list[0] - start_i); // C = var_k / (N * var_k * eta^2 * Bjj + 1) double C_val = var_k / (N * var_k * square(eta) * Bjj + 1.0); std::normal_distribution dist(0.0, std::sqrt(C_val)); double rv = dist(r) + C_val * N * bj; beta(causal_list[0]) = rv; - ldmat_dat.num[j] = bj * rv; - ldmat_dat.denom[j] = square(rv) * Bjj; + num[j] = bj * rv; + denom[j] = square(rv) * Bjj; return; } @@ -298,22 +305,15 @@ void MCMC_state::sample_beta(size_t j, const mcmc_data &dat, // Build precision matrix B_gamma and A_vec // Original: mcmc.cpp lines 278-289 - arma::mat B_gamma(nc, nc); + arma::uvec causal_idx(nc); for (size_t i = 0; i < nc; i++) { - size_t idx_i = causal_list[i] - start_i; - A_vec(i) = N * eta * ldmat_dat.calc_b_tmp[j](idx_i); - - for (size_t k = 0; k < nc; k++) { - size_t idx_k = causal_list[k] - start_i; - if (i != k) { - // Off-diagonal: eta^2 * N * B[i,k] - B_gamma(i, k) = C_coeff * ldmat_dat.B[j](idx_i, idx_k); - } else { - // Diagonal: eta^2 * N * B[i,i] + 1/var_k - B_gamma(i, k) = C_coeff * ldmat_dat.B[j](idx_i, idx_i) - + 1.0 / cluster_var[cls_assgn[causal_list[i]]]; - } - } + causal_idx(i) = causal_list[i] - start_i; + A_vec(i) = N * eta * blocks[j].calc_b_tmp(causal_idx(i)); + } + // Off-diagonal: eta^2 * N * B[i,k]; diagonal: eta^2 * N * B[i,i] + 1/var_k + arma::mat B_gamma = C_coeff * blocks[j].B_sub(causal_idx); + for (size_t i = 0; i < nc; i++) { + B_gamma(i, i) += 1.0 / cluster_var[cls_assgn[causal_list[i]]]; } arma::vec A_vec2 = A_vec; // Save for eta computation @@ -344,17 +344,16 @@ void MCMC_state::sample_beta(size_t j, const mcmc_data &dat, // Original: mcmc.cpp lines 312-321 // Restore diagonal of B_gamma to eta^2 * N * B[i,i] (without 1/var_k) for (size_t i = 0; i < nc; i++) { - size_t idx_i = causal_list[i] - start_i; - B_gamma(i, i) = C_coeff * ldmat_dat.B[j](idx_i, idx_i); + B_gamma(i, i) = C_coeff * blocks[j].diag_B(causal_idx(i)); } // num = A_vec2^T * beta_c / eta - ldmat_dat.num[j] = arma::dot(A_vec2, beta_c) / eta; + num[j] = arma::dot(A_vec2, beta_c) / eta; // denom = beta_c^T * B_gamma * beta_c / eta^2 // Original: gsl_blas_dsymv(CblasUpper, 1.0, &B, beta_c, 0, A_vec) - arma::vec tmp = arma::symmatu(B_gamma) * beta_c; - ldmat_dat.denom[j] = arma::dot(beta_c, tmp) / square(eta); + arma::vec tmp = B_gamma * beta_c; + denom[j] = arma::dot(beta_c, tmp) / square(eta); // Write sampled betas back for (size_t i = 0; i < nc; i++) { @@ -366,15 +365,16 @@ void MCMC_state::sample_beta(size_t j, const mcmc_data &dat, // compute_h2: Compute heritability h2 = sum_j beta_j^T * R_j * beta_j // Original: mcmc.cpp lines 331-343 // --------------------------------------------------------------------------- -void MCMC_state::compute_h2(const mcmc_data &dat) { +template +void MCMC_state::compute_h2(const mcmc_data &dat, + const std::vector &blocks) { h2 = 0; - for (size_t j = 0; j < dat.ref_ld_mat.size(); j++) { + for (size_t j = 0; j < blocks.size(); j++) { size_t start_i = dat.boundary[j].first; size_t end_i = dat.boundary[j].second; arma::vec beta_j = beta.subvec(start_i, end_i - 1); // Original: gsl_blas_dsymv(CblasUpper, 1.0, ref_ld_mat, beta, 0, tmp) - arma::vec tmp = arma::symmatu(dat.ref_ld_mat[j]) * beta_j; - h2 += arma::dot(tmp, beta_j); + h2 += blocks[j].R_quad(beta_j); } } @@ -383,11 +383,9 @@ void MCMC_state::compute_h2(const mcmc_data &dat) { // eta ~ N(num_sum/denom_sum, 1/denom_sum) // Original: mcmc.cpp lines 345-352 // --------------------------------------------------------------------------- -void MCMC_state::sample_eta(const ldmat_data &ldmat_dat) { - double num_sum = std::accumulate(ldmat_dat.num.begin(), - ldmat_dat.num.end(), 0.0); - double denom_sum = std::accumulate(ldmat_dat.denom.begin(), - ldmat_dat.denom.end(), 0.0); +void MCMC_state::sample_eta() { + double num_sum = std::accumulate(num.begin(), num.end(), 0.0); + double denom_sum = std::accumulate(denom.begin(), denom.end(), 0.0); denom_sum += 1e-6; std::normal_distribution dist(num_sum / denom_sum, @@ -396,68 +394,86 @@ void MCMC_state::sample_eta(const ldmat_data &ldmat_dat) { } // --------------------------------------------------------------------------- -// solve_ldmat: Precompute LD-derived matrices A, B, L for each block -// opt_llk=1: B = (R + aI); A = B^{-1} R * sz; B = R*A; L = R.*R -// opt_llk=2: Multi-array with eigenvalue correction +// sdpr_llk2_matrix: The optLlk = 2 matrix B2 from one block's LD +// Each pair's LD is scaled by min(N_i, N_j) / (1.1 * N_i * N_j) and zeroed +// between arrays 1 and 2; the diagonal is then set to 1 / N_i, raised by +// 1.1 times the scaled matrix's most negative eigenvalue, if any, to keep +// B2 positive definite. // -// Original: mcmc.cpp lines 354-431 -// Uses gsl_linalg_cholesky_decomp1, gsl_blas_dtrsm for matrix solves +// Original: mcmc.cpp lines 368-402 // --------------------------------------------------------------------------- -void solve_ldmat(const mcmc_data &dat, ldmat_data &ldmat_dat, - const double a, unsigned sz, int opt_llk) { - for (size_t i = 0; i < dat.ref_ld_mat.size(); i++) { - size_t blk_size = dat.boundary[i].second - dat.boundary[i].first; - arma::mat A = dat.ref_ld_mat[i]; - arma::mat B = dat.ref_ld_mat[i]; - arma::mat L = dat.ref_ld_mat[i]; // Will become R .* R (element-wise square) - - if (opt_llk == 1) { - // B = R + a*I (diagonal shrinkage) - // Original: gsl_vector_add_constant(&diag.vector, a) - B.diag() += a; - } - else { - // Multi-array: scale by min(N_i, N_j) / (1.1 * N_i * N_j) - // Original: mcmc.cpp lines 368-402 - for (size_t j = 0; j < blk_size; j++) { - for (size_t k = 0; k < blk_size; k++) { - size_t idx1 = j + dat.boundary[i].first; - size_t idx2 = k + dat.boundary[i].first; - if ((dat.array[idx1] == 1 && dat.array[idx2] == 2) || - (dat.array[idx1] == 2 && dat.array[idx2] == 1)) { - B(j, k) = 0; - } else { - B(j, k) *= min(dat.sz[idx1], dat.sz[idx2]) - / (1.1 * dat.sz[idx1] * dat.sz[idx2]); - } - } +static arma::mat sdpr_llk2_matrix(arma::mat B, const mcmc_data &dat, + size_t start) { + size_t blk_size = B.n_rows; + for (size_t j = 0; j < blk_size; j++) { + for (size_t k = 0; k < blk_size; k++) { + size_t idx1 = j + start; + size_t idx2 = k + start; + if ((dat.array[idx1] == 1 && dat.array[idx2] == 2) || + (dat.array[idx1] == 2 && dat.array[idx2] == 1)) { + B(j, k) = 0; + } else { + B(j, k) *= min(dat.sz[idx1], dat.sz[idx2]) + / (1.1 * dat.sz[idx1] * dat.sz[idx2]); } + } + } - // Force positive definite via eigenvalue correction - arma::vec eval; - arma::mat evec; - arma::eig_sym(eval, evec, B); - double eval_min = eval.min(); + // Force positive definite via eigenvalue correction. Only the smallest + // eigenvalue is read, so no eigenvectors are computed. + double eval_min = arma::eig_sym(B).min(); - // Restore symmetry (eig_sym may modify lower triangle) - B = arma::symmatu(B); + // Restore exact symmetry before the diagonal is reset + B = arma::symmatu(B); - // Add to diagonal to ensure PD - for (size_t j = 0; j < blk_size; j++) { - double diag_val = 1.0 / dat.sz[j + dat.boundary[i].first]; - if (eval_min < 0) diag_val -= 1.1 * eval_min; - B(j, j) = diag_val; - } + // Add to diagonal to ensure PD + for (size_t j = 0; j < blk_size; j++) { + double diag_val = 1.0 / dat.sz[j + start]; + if (eval_min < 0) diag_val -= 1.1 * eval_min; + B(j, j) = diag_val; + } + return B; +} + +// --------------------------------------------------------------------------- +// sdpr_dense_blocks: Precompute LD-derived matrices B and A' beta_mrg for +// each block +// opt_llk=1: B0 = R + aI; A = B0^{-1} R * sz; B = R * A +// opt_llk=2: B0 = sdpr_llk2_matrix(R); A = B0^{-1} R; B = R * A +// +// Original: mcmc.cpp lines 354-431 (solve_ldmat) +// Uses gsl_linalg_cholesky_decomp1, gsl_blas_dtrsm for matrix solves. The +// original also kept A and R .* R per block, which nothing reads after +// this, so neither is kept here. +// --------------------------------------------------------------------------- +std::vector sdpr_dense_blocks(const mcmc_data &dat, + std::vector ref_ld_mat, + double a, unsigned sz, + int opt_llk) { + std::vector blocks; + for (size_t i = 0; i < ref_ld_mat.size(); i++) { + size_t start = dat.boundary[i].first; + size_t blk_size = dat.boundary[i].second - start; + const arma::mat &R = ref_ld_mat[i]; + + arma::mat B0; + if (opt_llk == 1) { + // B0 = R + a*I (diagonal shrinkage) + // Original: gsl_vector_add_constant(&diag.vector, a) + B0 = R; + B0.diag() += a; + } else { + B0 = sdpr_llk2_matrix(R, dat, start); } - // Cholesky: B = L_chol * L_chol^T + // Cholesky: B0 = L_chol * L_chol^T // Original: gsl_linalg_cholesky_decomp1(B) - arma::mat L_chol = arma::chol(B, "lower"); + arma::mat L_chol = arma::chol(B0, "lower"); - // A = B^{-1} * R via forward then back-solve + // A = B0^{-1} * R via forward then back-solve // Original: gsl_blas_dtrsm(Left, Lower, NoTrans, NonUnit, 1.0, B, A) // gsl_blas_dtrsm(Left, Lower, Trans, NonUnit, 1.0, B, A) - A = arma::solve(arma::trimatl(L_chol), A); + arma::mat A = arma::solve(arma::trimatl(L_chol), R); A = arma::solve(arma::trimatu(L_chol.t()), A); // Scale by sample size for opt_llk=1 @@ -465,68 +481,195 @@ void solve_ldmat(const mcmc_data &dat, ldmat_data &ldmat_dat, A *= sz; } - // B = R * A (overwrite B with the product) - // Original: gsl_blas_dgemm(NoTrans, NoTrans, 1.0, L, A, 0, B) - // Note: L still holds the original R at this point - B = L * A; - - // L = R .* R (element-wise square) - // Original: gsl_matrix_mul_elements(L, L) - L %= L; - // Precompute A^T * beta_mrg for calc_b() // Original: gsl_blas_dgemv(CblasTrans, 1.0, A, beta_mrg, 0, b_tmp) arma::vec beta_mrg(blk_size); for (size_t j = 0; j < blk_size; j++) { - beta_mrg(j) = dat.beta_mrg[j + dat.boundary[i].first]; + beta_mrg(j) = dat.beta_mrg[j + start]; } - arma::vec b_tmp = A.t() * beta_mrg; - - ldmat_dat.A.push_back(A); - ldmat_dat.B.push_back(B); - ldmat_dat.L.push_back(L); - ldmat_dat.calc_b_tmp.push_back(b_tmp); - ldmat_dat.beta_mrg.push_back(beta_mrg); - ldmat_dat.denom.push_back(0); - ldmat_dat.num.push_back(0); + + SdprDenseBlock blk; + // B = R * A. The sampler reads it as symmetric (the original through + // dsymv), so it is symmetrized once here rather than on every product. + // Original: gsl_blas_dgemm(NoTrans, NoTrans, 1.0, L, A, 0, B) + blk.B = arma::symmatu(R * A); + blk.diag_B = blk.B.diag(); + blk.calc_b_tmp = A.t() * beta_mrg; + blk.R = arma::symmatu(R); + blocks.push_back(std::move(blk)); + } + return blocks; +} + +// --------------------------------------------------------------------------- +// sdpr_factor_root: R = Z Z' for the factor F (m x p) of R = F'F / (m - 1) +// Z (p x r) has orthogonal columns with Z'Z = diag(lambda), lambda the +// nonzero eigenvalues of R, from the eigendecomposition of the smaller of +// G G' and G'G (G = F / sqrt(m - 1)). Eigenvalues at the rounding level of +// that decomposition are dropped. +// --------------------------------------------------------------------------- +static arma::mat sdpr_factor_root(const arma::mat &F) { + arma::mat G = F / std::sqrt(static_cast(F.n_rows) - 1.0); + bool wide = G.n_rows <= G.n_cols; + arma::mat gram = wide ? arma::mat(G * G.t()) : arma::mat(G.t() * G); + arma::vec lam; + arma::mat Q; + arma::eig_sym(lam, Q, gram); + double tol = lam.is_empty() ? 0.0 + : lam.max() * gram.n_rows * arma::datum::eps; + arma::uvec keep = arma::find(lam > tol); + if (wide) { + return G.t() * Q.cols(keep); + } + return Q.cols(keep) * arma::diagmat(arma::sqrt(lam(keep))); +} + +// --------------------------------------------------------------------------- +// sdpr_llk2_solve: B2^{-1} rhs for the block R = Z Z', with B2 as +// sdpr_llk2_matrix() builds it, without forming B2 while it has a narrow +// low-rank part +// B2 = T - diag(T) + D0 with T = R .* S .* Mask, D0 = diag(1 / N) + fix. +// S_ij = 1 / (1.1 max(N_i, N_j)) is a sum over the K distinct sample sizes +// n_1 < ... < n_K, +// S = sum_l Delta_l 1_l 1_l' / 1.1, 1_l = [N_i <= n_l], +// Delta_l = 1 / n_l - 1 / n_(l+1) (1 / n_K for l = K), +// so R .* S = U_S U_S' with U_S = [sqrt(Delta_l / 1.1) diag(1_l) Z]_l. +// The array mask keeps the pairs within arrays {0, 1} and within {0, 2}, +// which counts the pairs within array 0 twice, so T = U Sigma U' with +// U = [P01 U_S, P02 U_S, P0 U_S] and Sigma = diag(I, I, -I). +// While U is narrower than p, T is singular, its most negative eigenvalue +// is that of the small (U'U)^(1/2) Sigma (U'U)^(1/2), and the Woodbury +// identity solves B2 = U Sigma U' + D through an inner matrix as wide as U. +// Otherwise B2 is formed exactly as the dense route forms it. +// --------------------------------------------------------------------------- +static arma::mat sdpr_llk2_solve(const mcmc_data &dat, const arma::mat &Z, + const arma::mat &rhs) { + size_t p = Z.n_rows; + size_t r = Z.n_cols; + arma::vec sz(dat.sz); + arma::ivec arr = arma::conv_to::from(dat.array); + arma::vec levels = arma::unique(sz); + size_t K = levels.n_elem; + bool masked = arma::any(arr == 1) && arma::any(arr == 2); + size_t width = (masked ? 3 : 1) * K * r; + + if (width >= p) { + arma::mat L_chol = arma::chol(sdpr_llk2_matrix(Z * Z.t(), dat, 0), + "lower"); + arma::mat Y = arma::solve(arma::trimatl(L_chol), rhs); + return arma::solve(arma::trimatu(L_chol.t()), Y); + } + + arma::mat U_S(p, K * r); + for (size_t l = 0; l < K; l++) { + double next = (l + 1 < K) ? 1.0 / levels(l + 1) : 0.0; + double delta = 1.0 / levels(l) - next; + arma::vec in_l = arma::conv_to::from(sz <= levels(l)); + U_S.cols(l * r, (l + 1) * r - 1) = + std::sqrt(delta / 1.1) * (Z.each_col() % in_l); } + + arma::mat U = U_S; + arma::vec sigma(width, arma::fill::ones); + // Unmasked, T = U_S U_S' is positive semidefinite (and singular), so its + // smallest eigenvalue is 0 and B2 needs no fix. + double eval_min = 0.0; + if (masked) { + arma::vec p01 = arma::conv_to::from(arr != 2); + arma::vec p02 = arma::conv_to::from(arr != 1); + arma::vec p0 = arma::conv_to::from(arr == 0); + U = arma::join_rows(U_S.each_col() % p01, U_S.each_col() % p02, + U_S.each_col() % p0); + sigma.tail(K * r).fill(-1.0); + arma::vec omega; + arma::mat P; + arma::eig_sym(omega, P, U.t() * U); + arma::mat root = P + * arma::diagmat(arma::sqrt(arma::clamp(omega, 0.0, + arma::datum::inf))) + * P.t(); + arma::vec small = arma::eig_sym(root * arma::diagmat(sigma) * root); + eval_min = std::min(0.0, small.min()); + } + + // D: 1 / N_i in place of T's own diagonal R_ii / (1.1 N_i), plus the fix. + arma::vec d = 1.0 / sz - arma::sum(arma::square(Z), 1) / (1.1 * sz); + if (eval_min < 0) d -= 1.1 * eval_min; + + arma::mat UD = U.each_col() / d; + arma::mat D_rhs = rhs.each_col() / d; + arma::mat inner = arma::diagmat(sigma) + U.t() * UD; + return D_rhs - UD * arma::solve(inner, U.t() * D_rhs); +} + +// --------------------------------------------------------------------------- +// sdpr_factor_block: The one block's B and A' beta_mrg from a factor of R +// With R = Z Z' = V diag(lambda) V': +// opt_llk=1: A = n (R + aI)^{-1} R = n V diag(lambda / (lambda + a)) V' and +// B = R A = W W', W = sqrt(n) V diag(lambda / sqrt(lambda + a)). +// opt_llk=2: A = B2^{-1} R and B = R A = Z H Z', H = Z' B2^{-1} Z (r x r), +// so W = Z H^(1/2) and B2^{-1} is needed only on Z and beta_mrg. +// --------------------------------------------------------------------------- +SdprFactorBlock sdpr_factor_block(const mcmc_data &dat, const arma::mat &F, + double a, unsigned sz, int opt_llk) { + SdprFactorBlock blk; + blk.Z = sdpr_factor_root(F); + const arma::mat &Z = blk.Z; + size_t p = Z.n_rows; + size_t r = Z.n_cols; + arma::vec beta_mrg(dat.beta_mrg); + + if (r == 0) { + // No LD at all (every variant monomorphic): B and A vanish. + blk.W.zeros(p, 0); + blk.calc_b_tmp.zeros(p); + } else if (opt_llk == 1) { + double n = static_cast(sz); + arma::vec lam = arma::sum(arma::square(Z), 0).t(); + arma::mat V = Z.each_row() / arma::sqrt(lam).t(); + blk.W = std::sqrt(n) + * (V.each_row() % (lam / arma::sqrt(lam + a)).t()); + blk.calc_b_tmp = n * (V * ((lam / (lam + a)) % (V.t() * beta_mrg))); + } else { + arma::mat Y = sdpr_llk2_solve(dat, Z, arma::join_rows(Z, beta_mrg)); + arma::mat H = Z.t() * Y.head_cols(r); + H = 0.5 * (H + H.t()); + arma::vec h; + arma::mat Q; + arma::eig_sym(h, Q, H); + blk.W = Z * Q + * arma::diagmat(arma::sqrt(arma::clamp(h, 0.0, arma::datum::inf))); + blk.calc_b_tmp = Z * (Z.t() * Y.col(r)); + } + blk.diag_B = arma::sum(arma::square(blk.W), 1); + return blk; } // --------------------------------------------------------------------------- // mcmc: Main MCMC loop // Original: mcmc.cpp lines 434-513 // --------------------------------------------------------------------------- +template std::unordered_map mcmc( - mcmc_data& data, - unsigned sz, - double a, - double c, - size_t M, - double a0k, - double b0k, - int iter, - int burn, - int thin, - unsigned n_threads, - int opt_llk, - bool verbose, - unsigned int seed + const mcmc_data& data, + const std::vector& blocks, + size_t M, + double a0k, + double b0k, + int iter, + int burn, + int thin, + unsigned n_threads, + bool verbose, + unsigned int seed ) { int n_pst = (iter - burn) / thin; - ldmat_data ldmat_dat; - - MCMC_state state(data.beta_mrg.size(), M, a0k, b0k, sz, seed); - - // Deflation correction - for (size_t i = 0; i < data.beta_mrg.size(); i++) { - data.beta_mrg[i] /= c; - } + MCMC_state state(data.beta_mrg.size(), M, blocks.size(), a0k, b0k, seed); MCMC_samples samples(data.beta_mrg.size()); - solve_ldmat(data, ldmat_dat, a, sz, opt_llk); state.update_suffstats(); Function_pool func_pool(n_threads); @@ -534,8 +677,8 @@ std::unordered_map mcmc( for (int j = 1; j < iter + 1; j++) { state.sample_sigma2(); - for (size_t i = 0; i < data.ref_ld_mat.size(); i++) { - state.calc_b(i, data, ldmat_dat); + for (size_t i = 0; i < blocks.size(); i++) { + state.calc_b(i, data, blocks); } // sample_assignment dispatched to thread pool across LD blocks. @@ -544,9 +687,10 @@ std::unordered_map mcmc( // (eldronzhou/SDPR) which has the same issue with gsl_rng. The // default n_threads=1 avoids the race. For safe parallelism, each // block would need its own RNG seeded from the shared one. - for (size_t i = 0; i < data.ref_ld_mat.size(); i++) { - func_pool.push(std::bind(&MCMC_state::sample_assignment, - &state, i, ref(data), ref(ldmat_dat))); + for (size_t i = 0; i < blocks.size(); i++) { + func_pool.push(std::bind(&MCMC_state::sample_assignment, + &state, i, std::cref(data), + std::cref(blocks))); } func_pool.waitFinished(); @@ -555,21 +699,21 @@ std::unordered_map mcmc( state.update_p(); state.sample_alpha(); - for (size_t i = 0; i < data.ref_ld_mat.size(); i++) { - state.sample_beta(i, data, ldmat_dat); + for (size_t i = 0; i < blocks.size(); i++) { + state.sample_beta(i, data, blocks); } - state.sample_eta(ldmat_dat); + state.sample_eta(); // Collect posterior samples if ((j > burn) && (j % thin == 0)) { - state.compute_h2(data); + state.compute_h2(data, blocks); samples.h2 += state.h2 * square(state.eta) / n_pst; samples.beta += state.eta / n_pst * state.beta; } if (verbose && j % 100 == 0) { - state.compute_h2(data); + state.compute_h2(data, blocks); Rprintf("%d iter. h2: %g max beta: %g\n", j, state.h2 * square(state.eta), arma::max(state.beta) * state.eta); @@ -586,3 +730,10 @@ std::unordered_map mcmc( return results; } + +template std::unordered_map mcmc( + const mcmc_data&, const std::vector&, size_t, double, + double, int, int, int, unsigned, bool, unsigned int); +template std::unordered_map mcmc( + const mcmc_data&, const std::vector&, size_t, double, + double, int, int, int, unsigned, bool, unsigned int); diff --git a/src/sdpr_mcmc.h b/src/sdpr_mcmc.h index 46f0ddd42..0797bd801 100644 --- a/src/sdpr_mcmc.h +++ b/src/sdpr_mcmc.h @@ -5,16 +5,6 @@ #include #include -typedef struct { - std::vector A; - std::vector B; - std::vector L; - std::vector beta_mrg; - std::vector calc_b_tmp; - std::vector num; - std::vector denom; -} ldmat_data; - class beta_distribution { public: // Constructor that takes alpha and beta parameters @@ -37,79 +27,90 @@ std::gamma_distribution b_distribution; /** * @class mcmc_data - * @brief Represents the data used in the MCMC algorithm. - * - * The mcmc_data class holds the necessary data for the MCMC algorithm, including - * the marginal beta values, LD matrix, sample sizes, and genotyping array information. - * - * @details - * The mcmc_data class is designed to store and manage the data required for the MCMC - * algorithm. It includes the following member variables: - * - beta_mrg: A vector of marginal beta values for each SNP. - * - ref_ld_mat: A vector of LD matrices, where each matrix corresponds to a subset of SNPs. - * - sz: A vector of sample sizes for each SNP. - * - array: A vector of genotyping array information for each SNP. - * - * The class also computes the boundary indices for each LD matrix, which represent the - * start and end positions of the SNPs in the full set of SNPs. - * - * @param beta_mrg A vector of marginal beta values for each SNP. - * @param ref_ld_mat A vector of LD matrices, where each matrix corresponds to a subset of SNPs. - * @param sz A vector of sample sizes for each SNP. - * @param array A vector of genotyping array information for each SNP. + * @brief The per-SNP data the MCMC algorithm reads, and where each LD block's + * SNPs sit in it. * - * @note The `array` parameter is used to store information about the genotyping array for each SNP. - * It is typically an integer value that represents the specific array used for genotyping. - * For example, 1 may represent the Affymetrix array, while 2 may represent the Illumina array. - * - * @note The `sz` parameter represents the sample size for each SNP. It is used to scale the - * elements of the LD matrix based on the sample sizes of the SNPs. + * - beta_mrg: the marginal beta values for each SNP, deflated by `c`. + * - boundary: the [start, end) positions of each LD block's SNPs. + * - sz: the sample size of each SNP. + * - array: the genotyping array of each SNP (0 = every cohort, 1 or 2 = the + * cohorts genotyped on that array). Pairs of SNPs on arrays 1 and 2 share + * no samples, so the optLlk = 2 likelihood zeroes their LD. * * Example usage: * @code * std::vector beta_mrg = {0.1, 0.2, 0.3, 0.4, 0.5}; - * std::vector ref_ld_mat = {arma::mat(2, 2, arma::fill::eye), arma::mat(3, 3, arma::fill::eye)}; + * std::vector block_sizes = {2, 3}; * std::vector sz = {1000, 1000, 1500, 1500, 1500}; * std::vector array = {1, 1, 2, 2, 2}; * - * mcmc_data data(beta_mrg, ref_ld_mat, sz, array); + * mcmc_data data(beta_mrg, block_sizes, sz, array); * @endcode */ class mcmc_data { public: std::vector beta_mrg; std::vector > boundary; -std::vector ref_ld_mat; std::vector sz; std::vector array; -/** - * @brief Constructs an mcmc_data object. - * - * @param beta_mrg A vector of marginal beta values for each SNP. - * @param ref_ld_mat A vector of LD matrices, where each matrix corresponds to a subset of SNPs. - * @param sz A vector of sample sizes for each SNP. - * @param array A vector of genotyping array information for each SNP. - */ -mcmc_data(const std::vector& beta_mrg, - const std::vector& ref_ld_mat, - const std::vector& sz, - const std::vector& array) - : beta_mrg(beta_mrg), ref_ld_mat(ref_ld_mat), sz(sz), array(array) { - compute_boundary(); -} - -private: -void compute_boundary() { +mcmc_data(const std::vector& beta_mrg, + const std::vector& block_sizes, + const std::vector& sz, + const std::vector& array) + : beta_mrg(beta_mrg), sz(sz), array(array) { size_t start = 0; - for (const auto& mat : ref_ld_mat) { - size_t end = start + mat.n_rows; - boundary.emplace_back(start, end); - start = end; + for (size_t size : block_sizes) { + boundary.emplace_back(start, start + size); + start += size; } } }; +// What the sampler reads from one LD block, R. B is the matrix of the +// likelihood: n R (R + aI)^{-1} R for optLlk = 1, R B2^{-1} R for optLlk = 2 +// (B2 the scaled R of solve_ldmat), and calc_b_tmp the matching +// A' beta_mrg. The sampler asks B for its diagonal, a product B beta, and the +// submatrix over the causal SNPs, and R for beta'R beta (the heritability). +// Each block type below answers those from one way of holding the matrices, +// so the sampler runs unchanged on either. + +// B and R held whole, each symmetrized once. +struct SdprDenseBlock { + arma::mat B; + arma::mat R; + arma::vec diag_B; + arma::vec calc_b_tmp; + + arma::vec B_times(const arma::vec& beta) const { return B * beta; } + arma::mat B_sub(const arma::uvec& idx) const { return B.submat(idx, idx); } + double R_quad(const arma::vec& beta) const { + return arma::dot(R * beta, beta); + } +}; + +// R = Z Z' with Z (p x r) from a factor of R, and B = W W'. B has rank at +// most r under either likelihood, since it is R times a matrix times R, so a +// product costs O(pr) and neither p x p matrix is formed. +struct SdprFactorBlock { + arma::mat W; + arma::mat Z; + arma::vec diag_B; + arma::vec calc_b_tmp; + + arma::vec B_times(const arma::vec& beta) const { + return W * (W.t() * beta); + } + arma::mat B_sub(const arma::uvec& idx) const { + arma::mat W_c = W.rows(idx); + return W_c * W_c.t(); + } + double R_quad(const arma::vec& beta) const { + arma::vec t = Z.t() * beta; + return arma::dot(t, t); + } +}; + class MCMC_state { public: double alpha; @@ -125,11 +126,14 @@ std::vector log_p; std::vector cluster_var; std::vector suff_stats; std::vector sumsq; -MCMC_state(size_t num_snp, size_t max_cluster, \ - double a0, double b0, double sz, unsigned int seed) { - a0k = a0; b0k = b0; N = sz; +// Each block's terms of the eta update, from sample_beta(). +std::vector num; +std::vector denom; +MCMC_state(size_t num_snp, size_t max_cluster, size_t num_blocks, \ + double a0, double b0, unsigned int seed) { + a0k = a0; b0k = b0; // Changed May 20 2021 - // Now N (sz) is absorbed into A, B; so set to 1. + // N (sz) is absorbed into A, B; so set to 1. N = 1.0; n_snp = num_snp; @@ -148,6 +152,8 @@ MCMC_state(size_t num_snp, size_t max_cluster, \ suff_stats.assign(max_cluster, 0); sumsq.assign(max_cluster, 0.0); V.assign(max_cluster, 0.0); + num.assign(num_blocks, 0.0); + denom.assign(num_blocks, 0.0); // Initialize all SNPs to the null cluster (k=0). The original SDPR // used random initialization (uniform over 0..M-1), but this causes // the first sample_beta() call to allocate an enormous dense matrix @@ -159,17 +165,21 @@ MCMC_state(size_t num_snp, size_t max_cluster, \ } void sample_sigma2(); -void calc_b(size_t j, const mcmc_data &dat, const ldmat_data &ldmat_dat); +template +void calc_b(size_t j, const mcmc_data &dat, const std::vector &blocks); +template void sample_assignment(size_t j, const mcmc_data &dat, \ - const ldmat_data &ldmat_dat); + const std::vector &blocks); void update_suffstats(); void sample_V(); void update_p(); void sample_alpha(); +template void sample_beta(size_t j, const mcmc_data &dat, \ - ldmat_data &ldmat_dat); -void compute_h2(const mcmc_data &dat); -void sample_eta(const ldmat_data &ldmat_dat); + const std::vector &blocks); +template +void compute_h2(const mcmc_data &dat, const std::vector &blocks); +void sample_eta(); private: double a0k; @@ -188,13 +198,41 @@ MCMC_samples(size_t num_snps) { } }; +/** + * @brief The dense LD blocks of the SDPR likelihood (solve_ldmat). + * + * @param dat The per-SNP data, with beta_mrg already deflated by `c`. + * @param ref_ld_mat The LD matrix of each block, taken over. + * @param a Factor to shrink the reference LD matrix (optLlk = 1). + * @param sz The sample size of the GWAS (optLlk = 1). + * @param opt_llk 1 for equation 6 (slightly shrink the correlation of SNPs) + * and 2 for equation 5 (SNPs genotyped on different arrays in a separate + * cohort). + */ +std::vector sdpr_dense_blocks(const mcmc_data &dat, + std::vector ref_ld_mat, + double a, unsigned sz, + int opt_llk); + +/** + * @brief The one LD block of the SDPR likelihood from a factor of its LD, + * R = F'F / (m - 1), never forming R or B. + * + * The arguments are sdpr_dense_blocks()'s with the factor F (m x p) in place + * of the LD matrices. B and A' beta_mrg agree with the dense block's to + * rounding: optLlk = 1 has them in closed form from the eigenvalues of R; + * optLlk = 2 applies B2^{-1} to r + 1 vectors, through the Woodbury identity + * while B2's low-rank part is narrower than p, and otherwise by forming B2. + */ +SdprFactorBlock sdpr_factor_block(const mcmc_data &dat, const arma::mat &F, + double a, unsigned sz, int opt_llk); + /** * @brief Perform Markov Chain Monte Carlo (MCMC) for estimating effect sizes. * - * @param data The `mcmc_data` object containing the necessary data for the MCMC algorithm. - * @param sz The sample size of the GWAS. - * @param a Factor to shrink the reference LD matrix. Default is 0.1. - * @param c Factor to correct for the deflation. Default is 1. + * @param data The `mcmc_data` object, with beta_mrg deflated by `c`. + * @param blocks The LD blocks, one per `data.boundary` entry + * (sdpr_dense_blocks() or sdpr_factor_block()). * @param M Max number of variance components. Default is 1000. * @param a0k Hyperparameter for inverse gamma distribution. Default is 0.5. * @param b0k Hyperparameter for inverse gamma distribution. Default is 0.5. @@ -202,58 +240,23 @@ MCMC_samples(size_t num_snps) { * @param burn Number of burn-in iterations for MCMC. Default is 200. * @param thin Thinning interval for MCMC. Default is 5. * @param n_threads Number of threads to use. Default is 1. - * @param opt_llk Which likelihood to evaluate. 1 for equation 6 (slightly shrink the correlation of SNPs) - * and 2 for equation 5 (SNPs genotyped on different arrays in a separate cohort). - * Default is 1. * @param verbose Whether to print verbose output. Default is true. + * @param seed Seed of the sampler's random number generator. * - * @return An `std::unordered_map` containing the estimated effect sizes (beta) and heritability (h2). - * - * @details - * This function performs Markov Chain Monte Carlo (MCMC) to estimate effect sizes and heritability - * based on the provided `mcmc_data` object and other parameters. - * - * The `mcmc_data` object should contain the following: - * - `beta_mrg`: A vector of marginal beta values for each SNP. - * - `ref_ld_mat`: A vector of LD matrices, where each matrix corresponds to a subset of SNPs. - * - `sz`: A vector of sample sizes for each SNP. - * - `array`: A vector of genotyping array information for each SNP. - * - * The function returns an `std::unordered_map` with the following key-value pairs: - * - "beta": An `arma::vec` containing the estimated effect sizes for each SNP. - * - "h2": An `arma::vec` containing the estimated heritability. - * - * Additional parameters: - * - `sz`: The sample size of the GWAS. - * - `a`: Factor to shrink the reference LD matrix. Default is 0.1. - * - `c`: Factor to correct for the deflation. Default is 1. - * - `M`: Max number of variance components. Default is 1000. - * - `a0k`, `b0k`: Hyperparameters for the inverse gamma distribution. Default is 0.5 for both. - * - `iter`: Number of iterations for MCMC. Default is 1000. - * - `burn`: Number of burn-in iterations for MCMC. Default is 200. - * - `thin`: Thinning interval for MCMC. Default is 5. - * - `n_threads`: Number of threads to use. Default is 1. - * - `opt_llk`: Which likelihood to evaluate. 1 for equation 6 (slightly shrink the correlation of SNPs) - * and 2 for equation 5 (SNPs genotyped on different arrays in a separate cohort). - * Default is 1. - * - `verbose`: Whether to print verbose output. Default is true. - * - * @note The `mcmc` function assumes the existence of the `Function_pool` class and its member functions, - * as well as the `mcmc.h` header file with the necessary class and struct definitions. + * @return An `std::unordered_map` with "beta", the estimated effect sizes, + * and "h2", the estimated heritability. */ +template std::unordered_map mcmc( - mcmc_data& data, - unsigned sz, - double a, - double c, - size_t M, - double a0k, - double b0k, - int iter, - int burn, - int thin, - unsigned n_threads, - int opt_llk, - bool verbose, - unsigned int seed + const mcmc_data& data, + const std::vector& blocks, + size_t M, + double a0k, + double b0k, + int iter, + int burn, + int thin, + unsigned n_threads, + bool verbose, + unsigned int seed ); diff --git a/src/vcf_gt.cpp b/src/vcf_gt.cpp new file mode 100644 index 000000000..97019eb75 --- /dev/null +++ b/src/vcf_gt.cpp @@ -0,0 +1,69 @@ +/** + * @file vcf_gt.cpp + * @brief Allele counts from VCF GT strings. + * + * The R side (R/GenotypeDosageSeed.R) reads a block of records' GT field + * through VariantAnnotation, which hands it back as strings ("0/1", "1|2", + * "./.", "1"), and asks here how many copies of one ALT allele each call + * carries. A row of the block may ask about any of its record's ALT alleles, + * which is how a record with several ALT alleles is read as one variant per + * ALT allele. + */ + +#include + +namespace { + +// The copies of allele `allele` in one GT string: its alleles, of any ploidy, +// separated by '/' or '|'. A call with a missing allele ("./.", "0|.", ".") +// is missing as a whole, as PLINK reads a half-call, and so is anything that +// is not a GT call. +double gt_copies(SEXP call, int allele) { + if (call == NA_STRING) return NA_REAL; + const char* p = CHAR(call); + if (*p == '\0') return NA_REAL; + int copies = 0; + while (true) { + if (*p < '0' || *p > '9') return NA_REAL; + long value = 0; + while (*p >= '0' && *p <= '9') { + value = value * 10 + (*p - '0'); + ++p; + } + if (value == allele) ++copies; + if (*p == '\0') break; + if (*p != '/' && *p != '|') return NA_REAL; + ++p; + } + return copies; +} + +} // namespace + +/** + * @brief The dosage of each row's ALT allele in a block of GT calls. + * + * @param gt A records x samples character matrix of GT calls, as + * VariantAnnotation::geno() returns it. + * @param alleles For each row, the 1-based index of the ALT allele it + * counts (1 for the first ALT allele). + * @return A numeric matrix the shape of `gt`: each call's copies of its + * row's ALT allele, NA where the call is missing. + */ +[[cpp11::register]] +cpp11::writable::doubles_matrix<> vcfGtDosageCpp(cpp11::strings gt, + cpp11::integers alleles) { + const R_xlen_t nRow = alleles.size(); + const R_xlen_t nCell = gt.size(); + if (nRow == 0) return cpp11::writable::doubles_matrix<>(0, 0); + if (nCell % nRow != 0) + cpp11::stop("The GT block does not have one row per allele."); + const R_xlen_t nCol = nCell / nRow; + cpp11::writable::doubles_matrix<> out(nRow, nCol); + for (R_xlen_t c = 0; c < nCol; ++c) { + for (R_xlen_t r = 0; r < nRow; ++r) { + out(r, c) = gt_copies(STRING_ELT(gt, r + c * nRow), alleles[r]); + } + } + return out; +} diff --git a/tests/testthat/helper-bgen.R b/tests/testthat/helper-bgen.R new file mode 100644 index 000000000..94281889a --- /dev/null +++ b/tests/testthat/helper-bgen.R @@ -0,0 +1,288 @@ +# A minimal BGEN writer for the BGEN reader's tests (R/genotypeIo.R), of +# either layout: diploid, unphased, biallelic records whose stored +# probability values are given as integers, so the expected dosages are +# known exactly. + +# Little-endian unsigned integers as raw bytes. +.bgw_u16 <- function(x) { + as.raw(c(x %% 256, (x %/% 256) %% 256)) +} + +.bgw_u32 <- function(x) { + as.raw(c( + x %% 256, + (x %/% 256) %% 256, + (x %/% 65536) %% 256, + x %/% 16777216 + )) +} + +# A string as a 2- or 4-byte length and its bytes. +.bgw_str <- function(x, width = 2L) { + bytes <- charToRaw(x) + len <- if (width == 2L) .bgw_u16(length(bytes)) else .bgw_u32(length(bytes)) + c(len, bytes) +} + +# B-bit values packed least significant bit first, padded to whole bytes. +.bgw_pack <- function(values, bits) { + bitsOf <- unlist(lapply(values, function(v) { + as.integer(intToBits(v))[seq_len(bits)] + })) + pad <- (8L - length(bitsOf) %% 8L) %% 8L + packBits(as.raw(c(bitsOf, rep(0L, pad))), "raw") +} + +.bgw_compress <- function(data, compression) { + if (compression == 0L) { + return(data) + } + if (compression == 1L) { + return(memCompress(data, type = "gzip")) + } + tf <- tempfile(fileext = ".zst") + con <- archive::archive_write(tf, "data", format = "raw", filter = "zstd") + writeBin(data, con) + close(con) + readBin(tf, "raw", file.size(tf)) +} + +# One variant record. `values` is an nSamples x 2 integer matrix of the +# stored P(AA) and P(AB) values (out of 2^bits - 1, or 32768 in layout 1); +# `missing` flags samples with no data. +.bgw_record <- function( + chrom, + pos, + rsid, + a1, + a2, + values, + missing, + bits, + compression, + layout = 2L +) { + if (layout == 1L) { + return(.bgw_record1( + chrom, + pos, + rsid, + a1, + a2, + values, + missing, + compression + )) + } + n <- nrow(values) + ploidy <- as.raw(ifelse(missing, 2L + 128L, 2L)) + stored <- values + stored[missing, ] <- 0L + probs <- c( + .bgw_u32(n), + .bgw_u16(2), + as.raw(2L), + as.raw(2L), + ploidy, + as.raw(0L), + as.raw(bits), + .bgw_pack(as.vector(t(stored)), bits) + ) + packed <- .bgw_compress(probs, compression) + genotype <- if (compression == 0L) { + c(.bgw_u32(length(packed)), packed) + } else { + c(.bgw_u32(length(packed) + 4L), .bgw_u32(length(probs)), packed) + } + c( + .bgw_str(rsid), + .bgw_str(rsid), + .bgw_str(chrom), + .bgw_u32(pos), + .bgw_u16(2), + .bgw_str(a1, 4L), + .bgw_str(a2, 4L), + genotype + ) +} + +# A layout-1 record: the sample count, the identifying data without an +# allele count, and three 16-bit probabilities (AA, AB, BB) per sample out of +# 32768, all zero for a missing sample, zlib-compressed behind their length +# or stored as they are. +.bgw_record1 <- function( + chrom, + pos, + rsid, + a1, + a2, + values, + missing, + compression +) { + n <- nrow(values) + stored <- cbind(values, 32768L - values[, 1L] - values[, 2L]) + stored[missing, ] <- 0L + probs <- writeBin( + as.integer(t(stored)), + raw(), + size = 2L, + endian = "little" + ) + genotype <- if (compression == 0L) { + probs + } else { + packed <- memCompress(probs, type = "gzip") + c(.bgw_u32(length(packed)), packed) + } + c( + .bgw_u32(n), + .bgw_str(rsid), + .bgw_str(rsid), + .bgw_str(chrom), + .bgw_u32(pos), + .bgw_str(a1, 4L), + .bgw_str(a2, 4L), + genotype + ) +} + +# Write a BGEN file and its .bgi index. `variants` is a data frame with +# chrom, pos, rsid, a1, a2; `values` a list of nSamples x 2 integer matrices +# (one per variant); `missing` a logical nSamples x nVariants matrix. +# `storeIds = FALSE` leaves the sample ids out of the file. +.bgw_write <- function( + path, + variants, + values, + missing, + sampleIds, + bits = 8L, + compression = 1L, + storeIds = TRUE, + layout = 2L +) { + n <- length(sampleIds) + flags <- compression + layout * 4L + flagBytes <- .bgw_u32(flags) + if (storeIds) { + flagBytes[[4L]] <- as.raw(128L) + } + header <- c( + .bgw_u32(20L), + .bgw_u32(nrow(variants)), + .bgw_u32(n), + charToRaw("bgen"), + flagBytes + ) + sampleBlock <- if (storeIds) { + ids <- unlist(lapply(sampleIds, .bgw_str)) + c(.bgw_u32(length(ids) + 8L), .bgw_u32(n), ids) + } + offset <- length(header) + length(sampleBlock) + records <- lapply(seq_len(nrow(variants)), function(j) { + .bgw_record( + variants$chrom[[j]], + variants$pos[[j]], + variants$rsid[[j]], + variants$a1[[j]], + variants$a2[[j]], + values[[j]], + missing[, j], + bits, + compression, + layout + ) + }) + bytes <- c(.bgw_u32(offset), header, sampleBlock, unlist(records)) + writeBin(bytes, path) + starts <- 4L + offset + c(0L, cumsum(lengths(records)))[seq_along(records)] + con <- DBI::dbConnect(RSQLite::SQLite(), paste0(path, ".bgi")) + on.exit(DBI::dbDisconnect(con)) + DBI::dbWriteTable( + con, + "Variant", + data.frame( + chromosome = variants$chrom, + position = variants$pos, + rsid = variants$rsid, + number_of_alleles = rep(2L, nrow(variants)), + allele1 = variants$a1, + allele2 = variants$a2, + file_start_position = starts, + size_in_bytes = lengths(records) + ) + ) + invisible(path) +} + +# The expected A1 (second allele) dosages of `values` out of `scale`: P(AB) + +# 2 P(BB), with P(BB) one minus the stored two. +.bgw_dosage <- function(values, missing, scale) { + out <- vapply( + seq_along(values), + function(j) { + p <- values[[j]] / scale + p[, 2] + 2 * (1 - p[, 1] - p[, 2]) + }, + numeric(nrow(missing)) + ) + out[missing] <- NA + out +} + +# A small fixture: `nVar` variants of `n` samples with random stored values +# that sum to at most the layout's scale, one missing sample, written to a +# tempfile. +.bgw_fixture <- function( + n = 6L, + nVar = 5L, + bits = 8L, + compression = 1L, + storeIds = TRUE, + seed = 1L, + layout = 2L +) { + set.seed(seed) + scale <- if (layout == 1L) 32768 else 2^bits - 1 + values <- lapply(seq_len(nVar), function(j) { + aa <- sample(0:scale, n, replace = TRUE) + ab <- vapply(scale - aa, function(r) sample(0:r, 1L), numeric(1)) + cbind(aa, ab) + }) + missing <- matrix(FALSE, n, nVar) + missing[2L, 3L] <- TRUE + variants <- data.frame( + chrom = "01", + pos = 100L * seq_len(nVar), + rsid = c(".", sprintf("rs%d", seq_len(nVar - 1L))), + a1 = "A", + a2 = "G" + ) + ids <- sprintf("s%d", seq_len(n)) + dir <- withr::local_tempdir(.local_envir = parent.frame()) + path <- file.path(dir, "fixture.bgen") + .bgw_write( + path, + variants, + values, + missing, + ids, + bits, + compression, + storeIds, + layout + ) + if (!storeIds) { + writeLines( + c("ID_1 ID_2 missing", "0 0 0", paste(ids, ids, 0)), + file.path(dir, "fixture.sample") + ) + } + list( + path = path, + ids = ids, + variants = variants, + dosage = .bgw_dosage(values, missing, scale) + ) +} diff --git a/tests/testthat/helper-cfgForwarding.R b/tests/testthat/helper-cfgForwarding.R index c34fd15a3..060fc0ded 100644 --- a/tests/testthat/helper-cfgForwarding.R +++ b/tests/testthat/helper-cfgForwarding.R @@ -55,3 +55,57 @@ rec(body(f)) unique(out) } + +# The arguments an S4 method takes, minus `data` and `...`. A method whose +# signature differs from its generic's is stored as a wrapper around an inner +# `.local`, whose formals are the ones the caller sees. +.methodFormalNames <- function(generic, cls) { + f <- methods::getMethod(generic, cls)@.Data + b <- body(f) + isLocal <- is.call(b) && + identical(b[[1]], as.name("{")) && + is.call(b[[2]]) && + identical(b[[2]][[2]], as.name(".local")) + if (isLocal) { + f <- eval(b[[2]][[3]]) + } + setdiff(names(formals(f)), c("data", "...")) +} + +# Stand in for the joint engine's entry point and record what each joint +# dispatcher hands it: the data form, the dataset, the pipeline config and the +# engine `args`. One record per call in `cap$calls`. It returns NULL (no fits), +# so a run whose joint phase consumed every method then stops with "no joint +# fits produced" -- the tests expect that and read the records afterwards. +.captureJointEngine <- function(cap, env = parent.frame()) { + cap$calls <- list() + testthat::local_mocked_bindings( + .runJointSpecs = function( + parsedJointSpec, + data, + dataForm, + pipeline, + jointMethods, + contexts, + traitIds, + args = list() + ) { + cap$calls[[length(cap$calls) + 1L]] <- list( + dataForm = dataForm, + data = data, + config = pecotmr:::.jpConfig(pipeline), + args = args, + jointMethods = jointMethods + ) + NULL + }, + .package = "pecotmr", + .env = env + ) +} + +# The recorded call for one data form ("individual" / "sumstats"). +.capturedCall <- function(cap, dataForm) { + hits <- Filter(function(r) identical(r$dataForm, dataForm), cap$calls) + if (length(hits) == 0L) NULL else hits[[1L]] +} diff --git a/tests/testthat/helper-h2Classes.R b/tests/testthat/helper-h2Classes.R index db5426f7c..a685dce52 100644 --- a/tests/testthat/helper-h2Classes.R +++ b/tests/testthat/helper-h2Classes.R @@ -63,8 +63,8 @@ makeTestAnnotationMeta <- function() { .testGenotypeHandle <- function() { new( "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", + path = "/tmp/test", + format = "plink2", snpInfo = data.frame(), nSamples = 0L, sampleIds = character(), @@ -112,7 +112,7 @@ makeGwasSumStatsFromDf <- function( studyName = traitName, entry = list(.dfToSumstatsGr(df)), genome = genome, - ldSketch = .testGenotypeHandle(), + ldReference = .testGenotypeHandle(), varY = varY ) } @@ -165,7 +165,7 @@ makeGwasBlock <- function( studyName = "trait1", entry = list(.dfToSumstatsGr(df)), genome = genome, - ldSketch = .blockGenotypeHandle(bp), + ldReference = .blockGenotypeHandle(bp), blockId = blockId, qcInfo = list( timestamp = NA_character_, @@ -178,80 +178,115 @@ makeGwasBlock <- function( # ============================================================================= -# LdData fixtures for buildLdEigen() / buildLdScore() +# LdMatrix fixtures for buildLdEigen() / buildLdScore() # ============================================================================= -# The mcols a loadLdMatrix() LdData carries: variant_id rather than SNP, and -# allele_freq rather than MAF. The builders have to cope with that shape. +# One block's variants as LdMatrix() takes them: SNP ids, alleles and an AF +# column, at 100 bp spacing. .testLdVariants <- function(n, chrom, startBp) { bp <- seq(startBp, by = 100L, length.out = n) - gr <- GenomicRanges::GRanges( - seqnames = chrom, - ranges = IRanges::IRanges(start = as.integer(bp), width = 1L) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - variant_id = paste0(chrom, ":", bp, ":C:T"), - A1 = rep("T", n), - A2 = rep("C", n), - allele_freq = seq(0.2, 0.8, length.out = n) + data.frame( + chrom = chrom, + pos = as.integer(bp), + SNP = paste0(chrom, ":", bp, ":C:T"), + A1 = "T", + A2 = "C", + AF = seq(0.2, 0.8, length.out = n) ) - gr } .testArBlock <- function(n, rho) { rho^abs(outer(seq_len(n), seq_len(n), "-")) } -.testBlockMetadata <- function(sizes, chrom, gr) { - ends <- cumsum(sizes) - starts <- ends - sizes + 1L - tibble::tibble( - blockId = seq_along(sizes), - chrom = sub("^chr", "", chrom), - blockStart = as.integer(GenomicRanges::start(gr)[starts]), - blockEnd = as.integer(GenomicRanges::start(gr)[ends]), - size = as.integer(sizes), - startIdx = as.integer(starts), - endIdx = as.integer(ends) - ) -} - -# One block: correlation is a single matrix. -makeTestLdData <- function( +# One LD block: an LdMatrix with AR(1) LD. +makeTestLdMatrix <- function( n = 6L, chrom = "chr1", startBp = 1000L, rho = 0.5, nSamples = 500L ) { - gr <- .testLdVariants(n, chrom, startBp) - R <- .testArBlock(n, rho) - dimnames(R) <- list( - S4Vectors::mcols(gr)$variant_id, - S4Vectors::mcols(gr)$variant_id - ) - LdData( - correlation = R, - variants = gr, - blockMetadata = .testBlockMetadata(n, chrom, gr), + LdMatrix( + .testArBlock(n, rho), + variants = .testLdVariants(n, chrom, startBp), nSamples = nSamples ) } -# Several blocks in one LdData: correlation is a list of per-block matrices -# and blockMetadata carries the startIdx/endIdx mapping into the variants. -makeTestLdDataMultiBlock <- function( +# Several consecutive LD blocks along one chromosome, one LdMatrix each. +makeTestLdMatrixBlocks <- function( sizes = c(4L, 3L), chrom = "chr1", startBp = 1000L, rho = 0.5, nSamples = 500L ) { - gr <- .testLdVariants(sum(sizes), chrom, startBp) - LdData( - correlation = map(sizes, .testArBlock, rho = rho), - variants = gr, - blockMetadata = .testBlockMetadata(sizes, chrom, gr), - nSamples = nSamples + starts <- startBp + 100L * c(0L, cumsum(head(sizes, -1L))) + map2( + sizes, + starts, + function(n, s) makeTestLdMatrix(n, chrom, s, rho, nSamples) ) } + +# A genotype panel of 100 samples cut into three LD blocks of 60, 140 and 100 +# variants, with the same blocks' LD as LdMatrix objects: a statistic read +# from the panel should agree with one built from the matrices. The middle +# block has more variants than the panel has samples, so its LD has 40 zero +# eigenvalues that the SVD of the panel's factor does not list. +.h2PanelFixture <- function() { + panel <- readGenotypes(test_path("test_data", "test_variants.bed")) + gr <- SummarizedExperiment::rowRanges(panel) + pos <- GenomicRanges::start(gr) + cuts <- list(1:60, 61:200, 201:300) + blocks <- data.frame( + chrom = "chr21", + start = map_int(cuts, function(i) pos[[min(i)]]), + end = map_int(cuts, function(i) pos[[max(i)]]) + ) + ld <- map(cuts, function(i) { + LdMatrix( + unname(computeLd(panel, snpIdx = i)), + variants = gr[i], + nSamples = ncol(panel) + ) + }) + list(panel = panel, blocks = blocks, ld = ld) +} + +# Two baseline annotations (binary and continuous) and one candidate over the +# variants of `ref`. +.h2PanelAnnotations <- function(ref) { + set.seed(11) + p <- length(ref) + mat <- cbind( + coding = rbinom(p, 1, 0.3), + cons = runif(p), + cand = rbinom(p, 1, 0.2) + ) + AnnotationMatrix( + mat, + GenomicRanges::granges(ref, use.mcols = FALSE), + data.frame( + name = colnames(mat), + tier = c("baseline", "baseline", "candidate"), + type = c("binary", "continuous", "binary") + ), + genome = "hg19" + ) +} + +# GWAS z-scores over the fixture's blocks with heritability `h2`: +# z = sqrt(n) R beta + e, e ~ N(0, R), block by block. +.h2PanelZ <- function(ld, n, h2, seed = 3) { + set.seed(seed) + M <- sum(map_int(ld, length)) + list_c(map(ld, function(x) { + R <- ldMatrix(x) + beta <- rnorm(nrow(R), sd = sqrt(h2 / M)) + e <- eigen(R, symmetric = TRUE) + noise <- e$vectors %*% (sqrt(pmax(e$values, 0)) * rnorm(nrow(R))) + as.vector(sqrt(n) * R %*% beta + noise) + })) +} diff --git a/tests/testthat/helper-rrwFixtures.R b/tests/testthat/helper-rrwFixtures.R index 50a420575..fb657019c 100644 --- a/tests/testthat/helper-rrwFixtures.R +++ b/tests/testthat/helper-rrwFixtures.R @@ -18,7 +18,9 @@ list(X = X, y = y, n = n, p = p) } -# Single-context summary statistics + LD for the *_rss_weights(stat, LD) contract. +# Single-context summary statistics + LD for the RSS weights contract: +# `stat` names its variants, and `ldReference` holds the same LD as an +# LdMatrix for the weight functions to match them to. .rrwStatLd <- function(n = 50, p = 6, seed = 1) { d <- .rrwXy(n, p, seed) bhat <- map_dbl( @@ -40,7 +42,7 @@ var_y = 1, variantNames = colnames(LD) ) - list(stat = stat, LD = LD, p = p, n = n) + list(stat = stat, LD = LD, ldReference = LdMatrix(LD), p = p, n = n) } # Multi-context (variants x conditions) fixture for mr.mash / mvSuSiE wrappers. @@ -66,5 +68,24 @@ }) ) colnames(Z) <- colnames(Y) - list(X = X, Y = Y, LD = cor(X), stat = list(z = Z, n = n), p = p, K = K) + list( + X = X, + Y = Y, + LD = cor(X), + ldReference = LdMatrix(cor(X)), + stat = list(z = Z, n = n, variantNames = colnames(X)), + p = p, + K = K + ) +} + +# Variant ids chr1:100:A:G, chr1:200:A:G, ... for p variants, and an LdMatrix +# over `R` named by them, for tests that build their own statistics and LD. +.rrwIds <- function(p) { + sprintf("chr1:%d:A:G", 100L * seq_len(p)) +} + +.rrwLdMatrix <- function(R) { + ids <- .rrwIds(nrow(R)) + LdMatrix(`dimnames<-`(R, list(ids, ids))) } diff --git a/tests/testthat/helper-s4Constructors.R b/tests/testthat/helper-s4Constructors.R index bfade90e5..2b161b102 100644 --- a/tests/testthat/helper-s4Constructors.R +++ b/tests/testthat/helper-s4Constructors.R @@ -7,8 +7,8 @@ context("s4Constructors") .sc_makeGenotypeHandle <- function(snp_n = 5L) { new( "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", + path = "/tmp/test", + format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), CHR = rep("1", snp_n), diff --git a/tests/testthat/helper-showMethods.R b/tests/testthat/helper-showMethods.R index e20ea6236..1714e1be2 100644 --- a/tests/testthat/helper-showMethods.R +++ b/tests/testthat/helper-showMethods.R @@ -7,8 +7,8 @@ context("show methods") .sh_makeGenotypeHandle <- function(snp_n = 3L) { new( "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", + path = "/tmp/test", + format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), CHR = rep("1", snp_n), diff --git a/tests/testthat/helper-vcf.R b/tests/testthat/helper-vcf.R new file mode 100644 index 000000000..d3ddbb6b1 --- /dev/null +++ b/tests/testthat/helper-vcf.R @@ -0,0 +1,125 @@ +# Small VCF and SeqArray GDS files for the VCF / GDS readers' tests +# (R/GenotypeDosageSeed.R, R/genotypeIo.R): written, bgzipped and +# tabix-indexed at test time, so every record's expected dosage is known. + +# A bgzipped, tabix-indexed VCF of `records` (a data frame of CHROM, POS, ID, +# REF, ALT and one FORMAT column per sample, holding the FORMAT values as +# text). `format` names the FORMAT keys the records carry, `ds` the Number +# FORMAT/DS is declared with (NULL declares no DS), and `gt = FALSE` leaves +# FORMAT/GT undeclared. Returns the .vcf.gz path. +.writeTestVcf <- function( + records, + samples, + format = "GT", + ds = NULL, + gt = TRUE, + contigs = unique(records$CHROM), + dir = tempfile("vcf_") +) { + dir.create(dir, showWarnings = FALSE) + header <- c( + "##fileformat=VCFv4.2", + paste0("##contig="), + if (gt) { + '##FORMAT=' + }, + if (!is.null(ds)) { + paste0( + "##FORMAT=' + ) + }, + paste( + c( + "#CHROM", + "POS", + "ID", + "REF", + "ALT", + "QUAL", + "FILTER", + "INFO", + "FORMAT", + samples + ), + collapse = "\t" + ) + ) + fields <- c( + list( + records$CHROM, + records$POS, + records$ID, + records$REF, + records$ALT, + ".", + "PASS", + ".", + paste(format, collapse = ":") + ), + unname(as.list(records[samples])) + ) + plain <- file.path(dir, "test.vcf") + writeLines(c(header, do.call(paste, c(fields, sep = "\t"))), plain) + gz <- Rsamtools::bgzip(plain, paste0(plain, ".gz"), overwrite = TRUE) + Rsamtools::indexTabix(gz, format = "vcf") + gz +} + +# The records the readers' tests share: a SNP; a deletion whose REF spans the +# SNP after it; two records at one position, the halves of a split +# multi-allelic site, both named rs4; and one record with two ALT alleles. +# Every way a record can overlap another, which is what a range read must +# see through. GT and DS (one value per ALT allele) agree, apart from s1's +# first record, whose DS carries an imputed fraction. +.vcfOverlapRecords <- function() { + data.frame( + CHROM = "22", + POS = c(100L, 200L, 202L, 300L, 300L, 400L), + ID = c(".", "rs2", "rs3", "rs4", "rs4", "rs6"), + REF = c("A", "ACGTA", "G", "C", "C", "A"), + ALT = c("G", "A", "T", "T", "G", "C,G"), + s1 = c("0/0:0.1", "0/1:1", "1|1:2", "0/1:1", "0/0:0", "1/2:1,1"), + s2 = c("0/1:0.9", "0/0:0", "0|1:1", "0/0:0", "0/1:1", "0/2:0,1"), + s3 = c("1/1:1.8", "./.:.", "0|0:0", "0/1:1", "1/1:2", "0|1:1,0"), + stringsAsFactors = FALSE + ) +} + +# The dosage of each of .vcfOverlapRecords()'s seven variants (rows: the +# two-ALT record splits in two) from its GT calls and from its DS values. +.vcfOverlapGt <- function() { + rbind( + c(0, 1, 2), + c(1, 0, NA), + c(2, 1, 0), + c(1, 0, 1), + c(0, 1, 2), + c(1, 0, 1), + c(1, 1, 0) + ) +} + +.vcfOverlapDs <- function() { + `[<-`(.vcfOverlapGt(), 1L, , value = c(0.1, 0.9, 1.8)) +} + +# Keep only the GT subfield of each sample column. +.vcfGtOnly <- function(records, samples = c("s1", "s2", "s3")) { + gt <- lapply(records[samples], sub, pattern = ":.*$", replacement = "") + `[<-`(records, samples, value = gt) +} + +# A SeqArray GDS converted from the VCF at `vcf`, importing FORMAT/DS when +# `ds` is TRUE. +.writeTestSeqArray <- function(vcf, ds = FALSE) { + out <- tempfile(fileext = ".gds") + SeqArray::seqVCF2GDS( + vcf, + out, + fmt.import = if (ds) "DS" else character(), + verbose = FALSE + ) + out +} diff --git a/tests/testthat/test_AllClasses.R b/tests/testthat/test_AllClasses.R index 4d3e45ed7..cd2c097c0 100644 --- a/tests/testthat/test_AllClasses.R +++ b/tests/testthat/test_AllClasses.R @@ -13,8 +13,8 @@ context("AllClasses (virtual base classes)") .alc_makeHandle <- function(snp_n = 3L) { new( "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", + path = "/tmp/test", + format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), CHR = rep("1", snp_n), @@ -52,7 +52,7 @@ context("AllClasses (virtual base classes)") studyName = "g1", entry = list(.alc_makeGr()), genome = "hg19", - ldSketch = .alc_makeHandle(), + ldReference = .alc_makeHandle(), qcInfo = qcInfo ) } @@ -189,7 +189,7 @@ test_that("FineMappingResultBase: adjustPips on a zero-row collection returns th trait = c("t1", "t2"), method = c("susie", "susie"), entry = list(.alc_makeFmEntry(), .alc_makeFmEntry()), - ldSketch = .alc_makeHandle() + ldReference = .alc_makeHandle() ) } @@ -240,7 +240,7 @@ test_that("FineMappingResultBase aggregate view: an empty collection yields a 0- trait = character(0), method = character(0), entry = list(), - ldSketch = .alc_makeHandle() + ldReference = .alc_makeHandle() ) expect_equal(nrow(credibleSets(empty)), 0L) }) @@ -250,15 +250,30 @@ test_that("FineMappingResultBase aggregate view: an empty collection yields a 0- # Variant reconciliation: intersectVariants + retainedMass # =========================================================================== -.rc_makeFmr <- function(vids, studyName = "s1", maxNumSingleEffects = 3L, seed = 3L) { +.rc_makeFmr <- function( + vids, + studyName = "s1", + maxNumSingleEffects = 3L, + seed = 3L +) { set.seed(seed) p <- length(vids) - lbf <- matrix(rnorm(maxNumSingleEffects * p, sd = 3), maxNumSingleEffects, p, dimnames = list(NULL, vids)) + lbf <- matrix( + rnorm(maxNumSingleEffects * p, sd = 3), + maxNumSingleEffects, + p, + dimnames = list(NULL, vids) + ) alpha <- lbfToAlpha(lbf) pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) e <- fineMappingRow( vids, - list(pip = pip, alpha = alpha, lbf_variable = lbf, V = rep(1, maxNumSingleEffects)), + list( + pip = pip, + alpha = alpha, + lbf_variable = lbf, + V = rep(1, maxNumSingleEffects) + ), data.frame(variant_id = vids, pip = pip, stringsAsFactors = FALSE) ) QtlFineMappingResult( @@ -544,13 +559,17 @@ test_that("an empty collection has no variants", { setClass( "RcEmptyKid", contains = "RangedTupleList", - representation(genome = "character", ldSketch = "ANY", qcInfo = "list") + representation( + genome = "character", + ldReference = "ANY", + qcInfo = "list" + ) ) empty <- new( "RcEmptyKid", GenomicRanges::GRangesList(), genome = "hg38", - ldSketch = NULL, + ldReference = NULL, qcInfo = list() ) expect_equal(nrow(empty), 0L) diff --git a/tests/testthat/test_ColocResult.R b/tests/testthat/test_ColocResult.R index 3dda7f111..cd1919f4d 100644 --- a/tests/testthat/test_ColocResult.R +++ b/tests/testthat/test_ColocResult.R @@ -284,6 +284,7 @@ test_that("show on an empty ColocResult stops after the header", { # =========================================================================== .cr_panel <- function() { + skip_if_not_installed("PlinkMatrix") readGenotypes( test_path("test_data", "test_variants"), format = "plink1" @@ -293,7 +294,7 @@ test_that("show on an empty ColocResult stops after the header", { .cr_panelIds <- function(n = 3L) { panel <- .cr_panel() normalizeVariantId( - .refVariantsFromSketch(.ldSketchHandle(panel))$variant_id + .refVariantsFromLdRef(panel)$variant_id )[seq_len(n)] } diff --git a/tests/testthat/test_GenotypeDosageSeed.R b/tests/testthat/test_GenotypeDosageSeed.R new file mode 100644 index 000000000..5ad2ea8e7 --- /dev/null +++ b/tests/testthat/test_GenotypeDosageSeed.R @@ -0,0 +1,303 @@ +context("GenotypeDosageSeed") + +# The seed's reads, against dosages known from the records written for each +# test (helper-vcf.R): every way one VCF record can overlap another, both +# FORMAT/DS shapes, both SNPRelate storage orders, and SeqArray's 2-bit +# planes. + +samples3 <- c("s1", "s2", "s3") + +.seedOf <- function(panel) { + DelayedArray::seed(SummarizedExperiment::assay(panel, "dosage")) +} + +.dose <- function(panel) { + unname(as.matrix(SummarizedExperiment::assay(panel, "dosage"))) +} + +# .vcfOverlapRecords() with one DS value per record: its first ALT allele's. +.oneValueDs <- function() { + recs <- .vcfOverlapRecords() + recs[samples3] <- lapply( + recs[samples3], + sub, + pattern = ",.*$", + replacement = "" + ) + recs +} + +test_that("a VCF seed picks each record out of what its range returns", { + skip_if_not_installed("VariantAnnotation") + vcf <- .writeTestVcf(.vcfGtOnly(.vcfOverlapRecords()), samples3) + panel <- suppressWarnings(readGenotypes(vcf)) + seed <- .seedOf(panel) + expect_s4_class(seed, "GenotypeDosageSeed") + expect_equal(pecotmr:::.gdSeedField(seed), "vcfGt") + expect_equal(dim(seed), c(7L, 3L)) + expect_equal(dimnames(seed)[[2L]], samples3) + expect_equal(.dose(panel), .vcfOverlapGt()) + # One record at a time: its range also returns every record overlapping + # it -- the SNP inside the deletion, the other half of the split site -- + # and none of them may stand in for it. + for (i in seq_len(7L)) { + expect_equal( + unname(S4Arrays::extract_array(seed, list(i, NULL))), + .vcfOverlapGt()[i, , drop = FALSE] + ) + } +}) + +test_that("a VCF seed reads FORMAT/DS, one value per ALT allele", { + skip_if_not_installed("VariantAnnotation") + vcf <- .writeTestVcf( + .vcfOverlapRecords(), + samples3, + format = c("GT", "DS"), + ds = "A" + ) + panel <- suppressWarnings(readGenotypes(vcf)) + expect_equal(pecotmr:::.gdSeedField(.seedOf(panel)), "vcfDs") + expect_equal(.dose(panel), .vcfOverlapDs()) +}) + +test_that("a one-value FORMAT/DS is its record's first ALT allele's", { + skip_if_not_installed("VariantAnnotation") + vcf <- .writeTestVcf( + .oneValueDs(), + samples3, + format = c("GT", "DS"), + ds = "1" + ) + panel <- suppressWarnings(readGenotypes(vcf)) + # The two-ALT record's second ALT allele has no value of its own. + expect_equal(.dose(panel), `[<-`(.vcfOverlapDs(), 7L, , value = NA)) +}) + +test_that("a seed lays a block out as asked, repeats included", { + skip_if_not_installed("VariantAnnotation") + vcf <- .writeTestVcf(.vcfGtOnly(.vcfOverlapRecords()), samples3) + seed <- .seedOf(suppressWarnings(readGenotypes(vcf))) + i <- c(5L, 2L, 2L, 7L) + j <- c(3L, 1L, 3L) + expect_equal( + unname(S4Arrays::extract_array(seed, list(i, j))), + .vcfOverlapGt()[i, j] + ) + empty <- S4Arrays::extract_array(seed, list(integer(0), NULL)) + expect_equal(dim(empty), c(0L, 3L)) + expect_equal( + dim(S4Arrays::extract_array(seed, list(NULL, integer(0)))), + c(7L, 0L) + ) +}) + +test_that("a missing GT call reads as NA", { + skip_if_not_installed("VariantAnnotation") + records <- data.frame( + CHROM = "21", + POS = c(1000L, 2000L), + ID = c("chr1:100:A:G", "chr1:200:A:G"), + REF = c("A", "C"), + ALT = c("G", "T"), + S1 = c("0/1", "0|0"), + S2 = c("./.", "1|1"), + S3 = c("1/1", "./."), + stringsAsFactors = FALSE + ) + panel <- readGenotypes(.writeTestVcf(records, c("S1", "S2", "S3"))) + expect_equal(.dose(panel), matrix(c(1, NA, 2, 0, 2, NA), 2L, byrow = TRUE)) +}) + +test_that("a VCF that no longer holds the panel's records is refused", { + skip_if_not_installed("VariantAnnotation") + vcf <- .writeTestVcf(.vcfGtOnly(.vcfOverlapRecords()), samples3) + seed <- .seedOf(suppressWarnings(readGenotypes(vcf))) + # A record ranked past those starting at its position is not in the + # file, as after the file was rewritten. + records <- pecotmr:::.gdSeedRecords(seed) + S4Vectors::mcols(records)$posRank[[1L]] <- 2L + stale <- methods::initialize(seed, records = records) + expect_error( + S4Arrays::extract_array(stale, list(1L, NULL)), + "no longer holds the records" + ) +}) + +test_that("a seed cut to some rows carries only their records", { + skip_if_not_installed("VariantAnnotation") + vcf <- .writeTestVcf(.vcfGtOnly(.vcfOverlapRecords()), samples3) + seed <- .seedOf(suppressWarnings(readGenotypes(vcf))) + keep <- c(2L, 6L, 7L) + cut <- pecotmr:::.gdSeedRows(seed, keep) + expect_equal(dim(cut), c(3L, 3L)) + # Rows 6 and 7 are the two ALT alleles of one record. + expect_equal(length(pecotmr:::.gdSeedRecords(cut)), 2L) + expect_equal(dimnames(cut)[[1L]], dimnames(seed)[[1L]][keep]) + expect_equal( + unname(S4Arrays::extract_array(cut, list(NULL, NULL))), + .vcfOverlapGt()[keep, ] + ) +}) + +test_that("a saved VCF or GDS panel reads the same once loaded again", { + skip_if_not_installed("VariantAnnotation") + skip_if_not_installed("GDSArray") + vcf <- .writeTestVcf(.vcfGtOnly(.vcfOverlapRecords()), samples3) + gds <- test_path("test_data", "test_variants.gds") + for (panel in list( + suppressWarnings(readGenotypes(vcf)), + readGenotypes(gds) + )) { + f <- tempfile(fileext = ".rds") + saveRDS(panel, f) + expect_equal(.dose(readRDS(f)), .dose(panel)) + } +}) + +test_that("a SNPRelate GDS seed reads either storage order, 3 as missing", { + skip_if_not_installed("SNPRelate") + skip_if_not_installed("GDSArray") + codes <- matrix(c(0L, 1L, 2L, 3L, 1L, 0L), nrow = 2L) # SNPs x samples + for (snpFirst in c(TRUE, FALSE)) { + f <- tempfile(fileext = ".gds") + SNPRelate::snpgdsCreateGeno( + f, + genmat = if (snpFirst) codes else t(codes), + sample.id = c("a", "b", "c"), + snp.id = c("v1", "v2"), + snp.chromosome = c(1L, 1L), + snp.position = c(10L, 20L), + snp.allele = c("A/G", "C/T"), + snpfirstdim = snpFirst + ) + panel <- readGenotypes(f) + expect_equal( + pecotmr:::.gdSeedField(.seedOf(panel)), + if (snpFirst) "snpGdsSnpOrder" else "snpGdsSampleOrder" + ) + expect_equal( + .dose(panel), + matrix(c(0, 2, 1, 1, NA, 0), 2L, byrow = TRUE) + ) + # The codes count each SNP's first allele, which is therefore A1. + expect_equal(SummarizedExperiment::rowRanges(panel)$A1, c("A", "C")) + } +}) + +test_that("a SeqArray GDS seed decodes its 2-bit planes", { + skip_if_not_installed("SeqArray") + skip_if_not_installed("GDSArray") + vcf <- .writeTestVcf(.vcfGtOnly(.vcfOverlapRecords()), samples3) + panel <- suppressWarnings(readGenotypes(.writeTestSeqArray(vcf))) + expect_equal(pecotmr:::.gdSeedField(.seedOf(panel)), "seqArrayGt") + expect_equal(.dose(panel), .vcfOverlapGt()) +}) + +test_that("a record with too many alleles for one plane is read across two", { + skip_if_not_installed("SeqArray") + skip_if_not_installed("GDSArray") + # Four alleles need a second 2-bit plane, and a missing allele sets every + # bit of both. SeqArray stores a haploid call in a diploid file with a + # missing second allele, so it is missing too, as SeqArray reads it. + records <- data.frame( + CHROM = "22", + POS = c(100L, 500L, 600L), + ID = c("rs1", "rs9", "."), + REF = "A", + ALT = c("G", "C,G,T", "C"), + s1 = c("0/.", "./.", "0/1"), + s2 = c("1", "0/.", "1/1"), + s3 = c("./.", "1|3", "0/0"), + stringsAsFactors = FALSE + ) + gds <- .writeTestSeqArray(.writeTestVcf(records, samples3)) + panel <- suppressWarnings(readGenotypes(gds)) + expect_equal( + .dose(panel), + matrix( + c(NA, NA, NA, NA, NA, 1, NA, NA, 0, NA, NA, 1, 1, 2, 0), + ncol = 3L, + byrow = TRUE + ) + ) +}) + +test_that("a SeqArray GDS seed reads FORMAT/DS per ALT allele", { + skip_if_not_installed("SeqArray") + skip_if_not_installed("GDSArray") + vcf <- .writeTestVcf( + .vcfOverlapRecords(), + samples3, + format = c("GT", "DS"), + ds = "A" + ) + panel <- suppressWarnings(readGenotypes(.writeTestSeqArray(vcf, ds = TRUE))) + expect_equal(pecotmr:::.gdSeedField(.seedOf(panel)), "seqArrayDs") + # SeqArray stores DS as 32-bit floats. + expect_equal(.dose(panel), .vcfOverlapDs(), tolerance = 1e-6) +}) + +test_that("a SeqArray DS row with no value of its own is missing", { + skip_if_not_installed("SeqArray") + skip_if_not_installed("GDSArray") + vcf <- .writeTestVcf( + .oneValueDs(), + samples3, + format = c("GT", "DS"), + ds = "1" + ) + panel <- suppressWarnings(readGenotypes(.writeTestSeqArray(vcf, ds = TRUE))) + want <- `[<-`(.vcfOverlapDs(), 7L, , value = NA) + expect_equal(.dose(panel), want, tolerance = 1e-6) + # A block of only such rows is answered without reading the file. + seed <- .seedOf(panel) + expect_true(all(is.na(S4Arrays::extract_array(seed, list(7L, NULL))))) +}) + +test_that("a GT call counts one ALT allele, and is missing if any allele is", { + # Only "./." used to read as missing, so ".|." read as 2 and "0|." and + # "." as 1; and any non-reference allele counted, so "0/2" read as one + # copy of the first ALT allele. + gt <- c("./.", ".|.", "0|.", ".", NA, "0/0", "0/1", "1|1", "1", "0/2") + count <- function(allele) { + pecotmr:::vcfGtDosageCpp( + matrix(gt, ncol = 1L), + rep(allele, length(gt)) + )[, 1L] + } + expect_equal(count(1L), c(NA, NA, NA, NA, NA, 0, 1, 2, 1, 0)) + expect_equal(count(2L), c(NA, NA, NA, NA, NA, 0, 0, 0, 0, 1)) + # Any ploidy, multi-digit allele indices, and anything that is not a GT + # call read as missing. + odd <- matrix(c("1/1/0", "10|12", "", "1/a", "1/"), ncol = 1L) + expect_equal( + pecotmr:::vcfGtDosageCpp(odd, c(1L, 12L, 1L, 1L, 1L))[, 1L], + c(2, 1, NA, NA, NA) + ) + # Each row counts its own allele, across every sample. + block <- matrix(c("0/1", "1/2", "2/2", "0/0"), 2L) + expect_equal( + pecotmr:::vcfGtDosageCpp(block, c(1L, 2L)), + matrix(c(1, 1, 0, 0), 2L) + ) +}) + + +# ---- PLINK1 ---------------------------------------------------------------- + +test_that("a PLINK1 seed reads any request through PlinkMatrix", { + # Each distinct row and sample is read once, in file order, then laid + # out as asked, repeats and all. + skip_if_not_installed("PlinkMatrix") + stem <- test_path("test_data", "test_variants") + seed <- pecotmr:::.panelSeed(readGenotypes(plink1Prefix = stem)) + expect_identical(pecotmr:::.gdSeedField(seed), "plinkBed") + all <- S4Arrays::extract_array(seed, list(NULL, NULL)) + got <- S4Arrays::extract_array(seed, list(c(5L, 2L, 5L), c(9L, 1L))) + expect_equal(got, all[c(5L, 2L, 5L), c(9L, 1L)]) + expect_equal( + dim(S4Arrays::extract_array(seed, list(integer(0), NULL))), + c(0L, ncol(all)) + ) +}) diff --git a/tests/testthat/test_GenotypeMixture.R b/tests/testthat/test_GenotypeMixture.R new file mode 100644 index 000000000..ea3cf3cc1 --- /dev/null +++ b/tests/testthat/test_GenotypeMixture.R @@ -0,0 +1,377 @@ +# Tests for the GenotypeMixture class (R/GenotypeMixture.R) and the LD +# reference dispatch it plugs into. + +# Two "cohorts": the two halves of one real genotype panel's samples. +.gmPanels <- function() { + panel <- readGenotypes(test_path("test_data", "test_variants.bed")) + list(a = panel[, 1:40], b = panel[, 41:100], full = panel) +} + +test_that("GenotypeMixture aligns its panels to the variants they share", { + p <- .gmPanels() + mix <- GenotypeMixture(list(a = p$a, b = p$b), mixtureWeights = c(0.3, 0.7)) + expect_s4_class(mix, "GenotypeMixture") + expect_s4_class(mix, "MultiAssayExperiment") + expect_equal(pecotmr:::.ldRefNVariants(mix), nrow(p$full)) + expect_equal(mixtureWeights(mix), c(a = 0.3, b = 0.7)) + comps <- as.list(MultiAssayExperiment::experiments(mix)) + expect_named(comps, c("a", "b")) + expect_equal(map_int(comps, ncol), c(a = 40L, b = 60L)) + expect_equal(map_int(comps, nrow), c(a = nrow(p$full), b = nrow(p$full))) + expect_identical( + variantIds(mix), + as.character(SummarizedExperiment::rowRanges(p$full)$SNP) + ) + # Each panel records its allele coding against the first's; these two + # halves of one panel code every variant alike. + expect_true(all(pecotmr:::.gmSign(mix) == 1)) + expect_equal(dim(pecotmr:::.gmSign(mix)), c(nrow(p$full), 2L)) + expect_true(validObject(mix)) + out <- capture.output(show(mix)) + expect_true(any(grepl("from 2 genotype panels", out))) + expect_true(any(grepl("panels a, b", out))) +}) + +test_that("a mixture names its samples by cohort", { + # Cohorts can reuse sample ids (every sketch does), so the primary names + # carry the cohort; the panels keep their own column names. + p <- .gmPanels() + mix <- GenotypeMixture(list(a = p$a, b = p$a), mixtureWeights = c(0.5, 0.5)) + sm <- MultiAssayExperiment::sampleMap(mix) + ids <- colnames(p$a) + expect_equal( + as.character(sm$primary), + c(str_c("a_", ids), str_c("b_", ids)) + ) + expect_equal(as.character(sm$colname), c(ids, ids)) + cd <- MultiAssayExperiment::colData(mix) + expect_equal(rownames(cd), as.character(sm$primary)) + expect_equal(cd$cohort, rep(c("a", "b"), each = length(ids))) +}) + +test_that("mixture weights are matched to panels by name", { + p <- .gmPanels() + byName <- GenotypeMixture( + list(a = p$a, b = p$b), + mixtureWeights = c(b = 0.7, a = 0.3) + ) + expect_equal(mixtureWeights(byName), c(a = 0.3, b = 0.7)) + expect_error( + GenotypeMixture( + list(a = p$a, b = p$b), + mixtureWeights = c(a = 0.3, c = 0.7) + ), + "must name each panel once: a, b" + ) +}) + +test_that("a mixture's LD is the weighted average of its panels' LD", { + p <- .gmPanels() + mix <- GenotypeMixture(list(a = p$a, b = p$b), mixtureWeights = c(0.3, 0.7)) + idx <- c(5L, 1L, 20L, 7L) + ldA <- unname(computeLd(p$a, snpIdx = idx)) + ldB <- unname(computeLd(p$b, snpIdx = idx)) + want <- 0.3 * ldA + 0.7 * ldB + expect_equal(pecotmr:::.ldRefLdAt(mix, idx), want) + ids <- names(SummarizedExperiment::rowRanges(p$full))[idx] + expect_equal(unname(pecotmr:::.ldFromRef(mix, ids, label = "t")), want) +}) + +test_that("a mixture's factor reproduces its LD exactly", { + # Each panel standardized on its own and weighted: the stacked factor's + # crossproduct is (N - 1) times the mixture's LD. + p <- .gmPanels() + mix <- GenotypeMixture(list(a = p$a, b = p$b), mixtureWeights = c(0.3, 0.7)) + idx <- 1:12 + f <- pecotmr:::.ldRefFactor(mix, idx) + expect_equal(nrow(f), 100L) + expect_equal( + unname(crossprod(f)) / (nrow(f) - 1), + pecotmr:::.ldRefLdAt(mix, idx) + ) +}) + +test_that("a panel-monomorphic variant is padded with a zero-mean pair", { + # The pair adds the panel's weight to the variant's own variance and + # nothing to its mean or its LD with anything else. + block <- cbind(c(1, -1, 0.5, -0.5), 0, c(-1, 1, 0, 0)) + rows <- pecotmr:::.gmMonomorphicRows(block, 0.3) + expect_equal(dim(rows), c(2L, 3L)) + expect_equal(colSums(rows), rep(0, 3)) + expect_equal(crossprod(rows), diag(c(0, 0.3, 0))) + p <- .gmPanels() + mix <- GenotypeMixture(list(a = p$a, b = p$b), mixtureWeights = c(0.3, 0.7)) + f <- pecotmr:::.ldRefFactor(mix, 1:12) + expect_equal(unname(colMeans(f)), rep(0, 12)) +}) + +test_that("a mixture answers sizes and statistics from its panels", { + p <- .gmPanels() + w <- c(0.3, 0.7) + mix <- GenotypeMixture(list(a = p$a, b = p$b), mixtureWeights = w) + # Noise n: one panel whose LD is as noisy; count n: the pooled samples. + expect_equal( + pecotmr:::.ldRefNoiseN(mix), + as.integer(round(1 / sum(w^2 / c(40, 60)))) + ) + expect_equal(pecotmr:::.ldRefRealNSamples(mix), 100L) + # A variant's MAF is its smallest in any panel, its missingness the + # largest, so a cutoff drops a variant that fails anywhere. + st <- pecotmr:::.ldRefVariantStats(mix, 1:10, TRUE, "t") + sa <- pecotmr:::.ldRefVariantStats(p$a, 1:10, TRUE, "t") + sb <- pecotmr:::.ldRefVariantStats(p$b, 1:10, TRUE, "t") + expect_equal(st$maf, pmin(sa$maf, sb$maf)) + expect_equal(st$missRate, pmax(sa$missRate, sb$missRate)) + expect_equal(pecotmr:::.ldRefMacSamples(mix, 5), 40L) + # The genotype variance is the weighted within-panel average. + vA <- pecotmr:::.ldRefVariance(p$a, 1:5) + vB <- pecotmr:::.ldRefVariance(p$b, 1:5) + expect_equal(pecotmr:::.ldRefVariance(mix, 1:5), w[[1]] * vA + w[[2]] * vB) + # Real panels record no frequencies, so neither does their mixture. + expect_null(pecotmr:::.ldRefAf(mix)) +}) + +test_that("subsetting a mixture's rows subsets every panel with it", { + p <- .gmPanels() + mix <- GenotypeMixture(list(a = p$a, b = p$b), mixtureWeights = c(0.5, 0.5)) + sub <- mix[c(3L, 1L), ] + expect_s4_class(sub, "GenotypeMixture") + expect_equal(pecotmr:::.ldRefNVariants(sub), 2L) + comps <- as.list(MultiAssayExperiment::experiments(sub)) + expect_equal(map_int(comps, nrow), c(a = 2L, b = 2L)) + expect_equal(dim(pecotmr:::.gmSign(sub)), c(2L, 2L)) + expect_equal( + pecotmr:::.ldRefLdAt(sub, 1:2), + pecotmr:::.ldRefLdAt(mix, c(3L, 1L)) + ) + expect_true(validObject(sub)) + # By variant id and by range, every panel is cut to the same variants. + ids <- names(SummarizedExperiment::rowRanges(p$full))[c(3L, 1L)] + expect_equal(variantIds(mix[ids, ]), variantIds(sub)) + gr <- SummarizedExperiment::rowRanges(p$full)[2:4] + expect_equal(pecotmr:::.ldRefNVariants(mix[gr, ]), 3L) + # A range is turned into positions like any other subscript: one naming + # no variant empties the panels as positions do, seeds and all. + none <- mix[GenomicRanges::GRanges("chr21", IRanges::IRanges(1L, 1L)), ] + expect_equal(pecotmr:::.ldRefNVariants(none), 0L) + expect_true(validObject(none)) + expect_true(all(map_lgl( + map( + as.list(MultiAssayExperiment::experiments(none)), + pecotmr:::.panelSeed + ), + is.null + ))) + # One index per panel could cut the panels to different variants, so + # such subscripts are refused, as is anything else that names no rows. + refused <- "subset by position, logical mask, variant id or GRanges" + expect_error(mix[list(a = 1:3, b = 1:2), ], refused) + expect_error(mix[IRanges::IntegerList(a = 1:3, b = 1:2), ], refused) + expect_error(mix[factor("x"), ], refused) + # Emptying drops every panel's variants, and their seeds with them, but + # keeps the samples the sampleMap names and what each panel was read + # from. + empty <- pecotmr:::.emptyLdRef(mix) + expect_equal(pecotmr:::.ldRefNVariants(empty), 0L) + expect_true(validObject(empty)) + emptied <- as.list(MultiAssayExperiment::experiments(empty)) + expect_equal(map_int(emptied, ncol), c(a = 40L, b = 60L)) + expect_true(all(map_lgl(map(emptied, pecotmr:::.panelSeed), is.null))) + expect_equal( + map_chr(emptied, pecotmr:::.ldRefFormat), + c(a = "plink1", b = "plink1") + ) +}) + +test_that("subsetting a mixture's samples narrows its panels", { + p <- .gmPanels() + mix <- GenotypeMixture(list(a = p$a, b = p$b), mixtureWeights = c(0.5, 0.5)) + keep <- c( + str_c("a_", colnames(p$a)[1:10]), + str_c("b_", colnames(p$b)[1:20]) + ) + sub <- mix[, keep] + comps <- as.list(MultiAssayExperiment::experiments(sub)) + expect_equal(map_int(comps, ncol), c(a = 10L, b = 20L)) + want <- 0.5 * + unname(computeLd(p$a[, 1:10], snpIdx = 1:5)) + + 0.5 * unname(computeLd(p$b[, 1:20], snpIdx = 1:5)) + expect_equal(pecotmr:::.ldRefLdAt(sub, 1:5), want) +}) + +test_that("a mixture's panels cannot be dropped", { + # The weights describe every panel, so dropping one would leave them + # describing a mixture that is no longer there. + p <- .gmPanels() + mix <- GenotypeMixture(list(a = p$a, b = p$b), mixtureWeights = c(0.5, 0.5)) + expect_error(mix[,, "a"], "panels cannot be subset") +}) + +test_that("a mixture is checked against other references by its panels", { + p <- .gmPanels() + mix <- GenotypeMixture(list(a = p$a, b = p$b), mixtureWeights = c(0.5, 0.5)) + # Two QC'd subsets of one mixture pass, warning only that they overlap + # in part. + rlang::reset_warning_verbosity("pecotmrLdReferenceOverlap-pipe") + expect_warning( + pecotmr:::.requireMatchingLdRefs(mix[1:200], mix[100:349], "pipe"), + "share 101 variant" + ) + reweighted <- GenotypeMixture( + list(a = p$a, b = p$b), + mixtureWeights = c(0.4, 0.6) + ) + expect_error( + pecotmr:::.requireMatchingLdRefs(mix, reweighted, "pipe"), + "average different panels or weight them differently" + ) + expect_error( + pecotmr:::.requireMatchingLdRefs(mix, p$full, "pipe"), + "is a GenotypeMixture and the other's a genotype panel" + ) +}) + +test_that("raiss imputes from a mixture through the SVD route", { + p <- .gmPanels() + mix <- GenotypeMixture( + list(a = p$a[1:30, ], b = p$b[1:30, ]), + mixtureWeights = c(0.4, 0.6) + ) + set.seed(2) + ref <- pecotmr:::.refVariantsFromLdRef(mix) + known <- ref[seq_len(30L) %% 3L != 0L, ] + known$z <- rnorm(nrow(known)) + viaGenotypes <- raiss( + knownZscores = known, + genotypes = mix, + svdTol = 1e-12, + r2Threshold = 0, + minimumLd = 0, + verbose = FALSE + ) + # Both routes drop the same weak eigen-directions (`rcond`), so at the + # defaults they are the same imputation. + viaLd <- raiss( + ref, + known, + ldMatrix = pecotmr:::.ldRefLdAt(mix, seq_len(30L)), + r2Threshold = 0, + minimumLd = 0, + verbose = FALSE + ) + expect_equal( + viaGenotypes$resultNofilter$z, + viaLd$resultNofilter$z, + tolerance = 1e-8 + ) +}) + +test_that("GenotypeMixture refuses bad inputs", { + p <- .gmPanels() + expect_error( + GenotypeMixture(list(a = p$a), mixtureWeights = 1), + "at least two genotype panels" + ) + expect_error( + GenotypeMixture(list(p$a, p$b), mixtureWeights = c(0.5, 0.5)), + "must be a named list" + ) + expect_error( + GenotypeMixture(list(a = p$a, a = p$b), mixtureWeights = c(0.5, 0.5)), + "must be a named list" + ) + ld <- LdMatrix( + diag(2), + variants = data.frame(chrom = "1", pos = 1:2, A1 = "A", A2 = "G") + ) + expect_error( + GenotypeMixture(list(a = p$a, b = ld), mixtureWeights = c(0.5, 0.5)), + "must be a genotype panel" + ) + expect_error( + GenotypeMixture(list(a = p$a, b = p$b), mixtureWeights = c(0.5, 0.6)), + "summing to 1" + ) + expect_error( + GenotypeMixture( + list(a = p$a[1:10, ], b = p$b[11:20, ]), + mixtureWeights = c(0.5, 0.5) + ), + "share no variant to combine over" + ) +}) + +test_that("an experiment added with c() leaves the mixture invalid", { + # The weights describe the panels the mixture was built over, so c() + # cannot extend it: whatever is added, validity refuses the result. + p <- .gmPanels() + mix <- GenotypeMixture(list(a = p$a, b = p$b), mixtureWeights = c(0.5, 0.5)) + se <- SummarizedExperiment::SummarizedExperiment( + matrix(1, 2L, 2L, dimnames = list(c("r1", "r2"), colnames(p$a)[1:2])) + ) + expect_error(c(mix, extra = se), "at least two genotype panels") + expect_error( + c(mix, extra = p$b[1:5, ]), + "every panel must hold exactly the mixture's variants" + ) + expect_error(c(mix, extra = p$b), "must carry `mixtureSign`") + expect_error(c(mix, extra = p$b), "one weight per panel, named after it") + unnamed <- mix + S4Vectors::metadata(unnamed)$mixtureWeights <- c(0.5, 0.5) + expect_error(validObject(unnamed), "one weight per panel, named after it") +}) + +test_that("a mixture's allele frequency is its panels' weighted average", { + # A stochastic sketch records its A1 frequencies; the second half gets + # its own, so the weights matter. + sk <- readGenotypes(test_path("test_data", "test_harmonize_regions.pgen")) + half <- seq_len(ncol(sk) / 2) + a <- sk[, half] + b <- sk[, -half] + rd <- SummarizedExperiment::rowData(b) + rd$AF <- seq(0.1, 0.8, length.out = nrow(b)) + SummarizedExperiment::rowData(b) <- rd + mix <- GenotypeMixture(list(a = a, b = b), mixtureWeights = c(0.25, 0.75)) + expect_equal( + pecotmr:::.ldRefAf(mix), + 0.25 * pecotmr:::.ldRefAf(a) + 0.75 * rd$AF + ) + # A panel coding a variant the other way round contributes the + # frequency of the first panel's A1: the complement of its own. + expect_equal( + pecotmr:::.gmAlignedAf( + 2L, + list(c(0.1, 0.2), c(0.3, 0.4)), + cbind(c(1, 1), c(1, -1)) + ), + c(0.3, 0.6) + ) +}) + +test_that("an LD statistic reads a mixture's blocks as LdMatrix ones", { + p <- .gmPanels() + mix <- GenotypeMixture(list(a = p$a, b = p$b), mixtureWeights = c(0.3, 0.7)) + gr <- SummarizedExperiment::rowRanges(p$full) + pos <- GenomicRanges::start(gr) + cuts <- list(1:100, 101:250) + blocks <- data.frame( + chrom = "chr21", + start = c(pos[[1L]], pos[[101L]]), + end = c(pos[[100L]], pos[[250L]]) + ) + lazy <- buildLdScore(mix, ldBlocks = blocks, genome = "hg19") + expect_identical(ldReference(lazy), mix) + ld <- map(cuts, function(i) { + LdMatrix( + pecotmr:::.ldRefLdAt(mix, i), + variants = gr[i], + nSamples = ldPanelNSamples(lazy) + ) + }) + stored <- buildLdScore(ld, genome = "hg19") + expect_equal( + S4Vectors::mcols(lazy)$ldScores, + S4Vectors::mcols(stored)$ldScores, + tolerance = 1e-10 + ) +}) diff --git a/tests/testthat/test_GwasFineMappingResult.R b/tests/testthat/test_GwasFineMappingResult.R index 6da3c2a5e..4946b03ed 100644 --- a/tests/testthat/test_GwasFineMappingResult.R +++ b/tests/testthat/test_GwasFineMappingResult.R @@ -159,19 +159,19 @@ test_that("show.GwasFineMappingResult prints (study, method) summary", { out <- capture.output(show(res)) expect_true(any(grepl("GwasFineMappingResult: 2 entries", out))) expect_true(any(grepl("1 studies.*2 methods", out))) - expect_true(any(grepl("LD sketch: NULL", out))) + expect_true(any(grepl("LD reference: NULL", out))) }) -test_that("show.GwasFineMappingResult reports the ldSketch source when present", { +test_that("show.GwasFineMappingResult reports the ldReference source", { res <- GwasFineMappingResult( studyName = "g1", method = "susie", entry = list(.sh_makeFmEntry()), - ldSketch = .sh_makeGenotypeHandle() + ldReference = .sh_makeGenotypeHandle() ) out <- capture.output(show(res)) - expect_true(any(grepl("LD sketch: gds @ /tmp/test.gds", out))) + expect_true(any(grepl("LD reference: plink2 @ /tmp/test", out))) }) @@ -287,7 +287,12 @@ test_that("GwasFineMappingResult: credibleSets aggregates CS across blocks", { ) expect_true(all(is.na(cs$context))) # region= pins one block -> bare table - bare <- credibleSets(res, studyName = "g1", method = "susie", region = "chr1:1-100") + bare <- credibleSets( + res, + studyName = "g1", + method = "susie", + region = "chr1:1-100" + ) expect_false("blockId" %in% names(bare)) }) @@ -304,7 +309,10 @@ test_that("GwasFineMappingResult: .tupleSelectRowGwasFmr requires both selectors pip(res, studyName = c("g1", "g2"), method = "susie"), "Must have length 1" ) - expect_error(pip(res, studyName = "ghost", method = "susie"), "No entry for") + expect_error( + pip(res, studyName = "ghost", method = "susie"), + "No entry for" + ) }) diff --git a/tests/testthat/test_GwasSumStats.R b/tests/testthat/test_GwasSumStats.R index 5b84026e1..53c3a8886 100644 --- a/tests/testthat/test_GwasSumStats.R +++ b/tests/testthat/test_GwasSumStats.R @@ -152,7 +152,7 @@ test_that("subsetChr() preserves study-level nCase/nControl/nSample scalars", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .sh_makeGenotypeHandle(), + ldReference = .sh_makeGenotypeHandle(), nCase = 5000, nControl = 15000, nSample = 20000 @@ -209,11 +209,11 @@ test_that("show.GwasSumStats prints nrow and genome build", { studyName = c("g1", "g2"), entry = list(.sh_makeQtlSumstatsGr(), .sh_makeQtlSumstatsGr()), genome = "hg19", - ldSketch = .sh_makeGenotypeHandle() + ldReference = .sh_makeGenotypeHandle() ) out <- capture.output(show(ss)) expect_true(any(grepl("GwasSumStats: 2 studies, genome build hg19", out))) - expect_true(any(grepl("LD sketch: gds @ /tmp/test.gds", out))) + expect_true(any(grepl("LD reference: plink2 @ /tmp/test", out))) }) # === Tests migrated from test_h2ClassesSumstats.R (showMethods) === @@ -234,7 +234,7 @@ test_that("GwasSumStats() errors when genome is not a single string", { studyName = "g1", entry = list(.sh_makeQtlSumstatsGr()), genome = c("hg19", "hg38"), - ldSketch = .sh_makeGenotypeHandle() + ldReference = .sh_makeGenotypeHandle() ), "single character string" ) @@ -246,7 +246,7 @@ test_that("GwasSumStats() errors when entry is not a list", { studyName = "g1", entry = "not_a_list", genome = "hg19", - ldSketch = .sh_makeGenotypeHandle() + ldReference = .sh_makeGenotypeHandle() ), "must be a list" ) @@ -258,7 +258,7 @@ test_that("GwasSumStats() errors when length(entry) != length(study)", { studyName = c("g1", "g2"), entry = list(.sh_makeQtlSumstatsGr()), genome = "hg19", - ldSketch = .sh_makeGenotypeHandle() + ldReference = .sh_makeGenotypeHandle() ), "must equal length" ) @@ -270,7 +270,7 @@ test_that("GwasSumStats() errors when a per-study column has a bad length", { studyName = c("g1", "g2"), entry = list(.sh_makeQtlSumstatsGr(), .sh_makeQtlSumstatsGr()), genome = "hg19", - ldSketch = .sh_makeGenotypeHandle(), + ldReference = .sh_makeGenotypeHandle(), nCase = c(1, 2, 3) ), "must have length 1 or length" @@ -282,7 +282,7 @@ test_that("GwasSumStats() attaches extra per-study columns via ...", { studyName = c("g1", "g2"), entry = list(.sh_makeQtlSumstatsGr(), .sh_makeQtlSumstatsGr()), genome = "hg19", - ldSketch = .sh_makeGenotypeHandle(), + ldReference = .sh_makeGenotypeHandle(), extraCols = list(cohort = c("UKB", "FinnGen")) ) expect_equal(as.character(obj$cohort), c("UKB", "FinnGen")) @@ -304,7 +304,7 @@ test_that("sumStats() errors on an empty GwasSumStats", { studyName = character(0), entry = list(), genome = "hg19", - ldSketch = .sh_makeGenotypeHandle(), + ldReference = .sh_makeGenotypeHandle(), varY = numeric(0) ) expect_equal(nrow(empty), 0L) @@ -316,29 +316,29 @@ test_that("sumStats() on a multi-study GwasSumStats needs a study selector", { studyName = c("g1", "g2"), entry = list(.sh_makeQtlSumstatsGr(), .sh_makeQtlSumstatsGr()), genome = "hg19", - ldSketch = .sh_makeGenotypeHandle() + ldReference = .sh_makeGenotypeHandle() ) expect_error(sumStats(two), "studies. Pass") expect_error(sumStats(two, studyName = "ghost"), "Unknown study") }) -test_that("GwasSumStats: ldSketch is optional (NULL for LD-free workflows)", { +test_that("GwasSumStats: ldReference is optional (NULL when LD-free)", { ss <- GwasSumStats( studyName = "g1", entry = list(.sh_makeQtlSumstatsGr()), genome = "hg19" - ) # ldSketch omitted -> NULL - expect_null(ldSketch(ss)) + ) # ldReference omitted -> NULL + expect_null(ldReference(ss)) expect_output(show(ss), "none \\(LD-free\\)") }) -test_that("GwasSumStats: a non-GenotypeHandle ldSketch is rejected", { +test_that("GwasSumStats: a non-GenotypeHandle ldReference is rejected", { expect_error( GwasSumStats( studyName = "g1", entry = list(.sh_makeQtlSumstatsGr()), genome = "hg19", - ldSketch = "not_a_handle" + ldReference = "not_a_handle" ), "must be a genotype panel" ) @@ -571,19 +571,19 @@ test_that("combineGwasSumStats() unions the per-block LD panels", { # Keeping only the first block's panel would leave a two-block collection # whose LD reference covers one block. - expect_equal(nrow(ldSketch(out)), 8L) + expect_equal(nrow(ldReference(out)), 8L) expect_equal( - rownames(ldSketch(out)), - c(rownames(ldSketch(a)), rownames(ldSketch(b))) + rownames(ldReference(out)), + c(rownames(ldReference(a)), rownames(ldReference(b))) ) }) -test_that("combineGwasSumStats() honours an explicit ldSketch", { +test_that("combineGwasSumStats() honours an explicit ldReference", { a <- makeGwasBlock("chr1_1_1000", 100L) b <- makeGwasBlock("chr1_1001_2000", 1100L) - out <- combineGwasSumStats(a, b, ldSketch = ldSketch(a)) - expect_identical(ldSketch(out), ldSketch(a)) + out <- combineGwasSumStats(a, b, ldReference = ldReference(a)) + expect_identical(ldReference(out), ldReference(a)) }) @@ -613,11 +613,11 @@ test_that("combineGwasSumStats() rejects collection-level disagreement", { expect_error(combineGwasSumStats(a, noQc), "carry no QC record") noLd <- makeGwasBlock("chr1_1001_2000", 1100L) - noLd@ldSketch <- NULL - expect_error(combineGwasSumStats(a, noLd), "carry no ldSketch") + noLd@ldReference <- NULL + expect_error(combineGwasSumStats(a, noLd), "carry no ldReference") other <- makeGwasBlock("chr1_1001_2000", 1100L) - other@ldSketch <- pecotmr:::.asLdSketch( + other@ldReference <- pecotmr:::.asLdRef( .blockGenotypeHandle( seq(1100L, by = 100L, length.out = 5L), path = "/tmp/other.pgen" diff --git a/tests/testthat/test_H2Estimate.R b/tests/testthat/test_H2Estimate.R index ea89e721f..c5b2685e3 100644 --- a/tests/testthat/test_H2Estimate.R +++ b/tests/testthat/test_H2Estimate.R @@ -41,3 +41,41 @@ test_that("show(H2Estimate) does not error", { ) expect_output(show(h2), "H2Estimate") }) + +test_that("H2Estimate types its optional slots", { + # Each optional slot is a type-or-NULL union, so a tibble fills the table + # slots while a value of the wrong type is refused when the object is + # built. + h2 <- function(...) { + new( + "H2Estimate", + estimate = 0.3, + estimateSe = 0.05, + intercept = 1.0, + interceptSe = 0.01, + method = "lder", + nSnps = 1000L, + traitName = "test", + ... + ) + } + local <- tibble::tibble(blockId = 1L, h2Local = 0.1, h2LocalSe = 0.01) + expect_identical(localH2Blocks(h2(localBlocks = local)), local) + expect_null(localH2Blocks(h2())) + expect_error( + h2(localBlocks = list(blockId = 1L)), + 'invalid object for slot "localBlocks"' + ) + expect_error( + h2(enrichment = "none"), + 'invalid object for slot "enrichment"' + ) + expect_error( + h2(annotationJackknifeCoefs = c(0.1, 0.2)), + 'invalid object for slot "annotationJackknifeCoefs"' + ) + expect_error( + h2(scoreStats = c(z = 1.5)), + 'invalid object for slot "scoreStats"' + ) +}) diff --git a/tests/testthat/test_JointGroup.R b/tests/testthat/test_JointGroup.R index 3b3d3f3b6..2f7458ec8 100644 --- a/tests/testthat/test_JointGroup.R +++ b/tests/testthat/test_JointGroup.R @@ -30,13 +30,51 @@ test_that("JointGroup subclasses construct from a conditions table", { "SumStatsJointGroup", conditions = .jg_cond(), Z = Z, - ldSketch = NULL, + ldReference = NULL, N = c(100, 120) ) expect_s4_class(sg, "JointGroup") expect_s4_class(sg, "SumStatsJointGroup") }) +test_that(".jgKeepConditions subsets each condition's column with it", { + X <- matrix(0, 4, 1, dimnames = list(paste0("s", 1:4), "chr1:100:A:G")) + Y <- matrix( + as.numeric(1:12), + 4, + 3, + dimnames = list(paste0("s", 1:4), c("c1", "c2", "c3")) + ) + g <- new( + "IndividualJointGroup", + conditions = .jg_cond(context = c("c1", "c2", "c3")), + X = X, + Y = Y, + traitPos = c(10, 20, 30) + ) + kept <- .jgKeepConditions(g, c(TRUE, FALSE, TRUE)) + expect_equal(.jgConditions(kept)$context, c("c1", "c3")) + expect_equal(.jgY(kept), Y[, c(1L, 3L)]) + expect_equal(.jgTraitPos(kept), c(10, 30)) + expect_identical(.jgKeepConditions(g, rep(TRUE, 3L)), g) + expect_null(.jgKeepConditions(g, rep(FALSE, 3L))) + sg <- new( + "SumStatsJointGroup", + conditions = .jg_cond(), + Z = matrix( + as.numeric(1:6), + 3, + 2, + dimnames = list(paste0("v", 1:3), NULL) + ), + ldReference = NULL, + N = c(100, 120) + ) + keptSs <- .jgKeepConditions(sg, c(FALSE, TRUE)) + expect_equal(.jgZ(keptSs), .jgZ(sg)[, 2L, drop = FALSE]) + expect_equal(.jgN(keptSs), 120) +}) + test_that("JointGroup validity rejects malformed groups", { X <- matrix( 0, @@ -105,7 +143,7 @@ test_that("JointGroup validity rejects malformed groups", { "SumStatsJointGroup", conditions = .jg_cond(), Z = matrix(0, 3, 2), - ldSketch = NULL, + ldReference = NULL, N = 1 ), "variant ids as rownames" diff --git a/tests/testthat/test_LdEigen.R b/tests/testthat/test_LdEigen.R index 4f64c4b65..58eadaef8 100644 --- a/tests/testthat/test_LdEigen.R +++ b/tests/testthat/test_LdEigen.R @@ -107,6 +107,10 @@ test_that("subsetting an LdEigen is refused, not silently allowed", { ) expect_error(obj[1:5], "cannot be subset") expect_error(obj[1], "Recompute over the subset") + # head() and tail() reach the rows without `[`; they used to return the + # first variants with every block's decomposition still attached. + expect_error(head(obj, 3), "cannot be subset") + expect_error(tail(obj, 3), "cannot be subset") }) @@ -114,8 +118,8 @@ test_that("subsetting an LdEigen is refused, not silently allowed", { # buildLdEigen # ============================================================================= -test_that("buildLdEigen decomposes a single-block LdData", { - ld <- makeTestLdData(n = 6L) +test_that("buildLdEigen decomposes a single LdMatrix as one block", { + ld <- makeTestLdMatrix(n = 6L) ref <- buildLdEigen(ld) expect_s4_class(ref, "LdEigen") @@ -127,8 +131,8 @@ test_that("buildLdEigen decomposes a single-block LdData", { expect_equal(eigenList(ref)[[1]]$snpIdx, 1:6) }) -test_that("buildLdEigen gives one block per matrix of a multi-block LdData", { - ref <- buildLdEigen(makeTestLdDataMultiBlock(sizes = c(4L, 3L))) +test_that("buildLdEigen gives one block per LdMatrix in a list", { + ref <- buildLdEigen(makeTestLdMatrixBlocks(sizes = c(4L, 3L))) expect_equal(length(ref), 7L) blocks <- eigenList(ref) @@ -140,18 +144,18 @@ test_that("buildLdEigen gives one block per matrix of a multi-block LdData", { }) test_that("buildLdEigen reconstructs the correlation it was given", { - ld <- makeTestLdData(n = 6L) + ld <- makeTestLdMatrix(n = 6L) block <- eigenList(buildLdEigen(ld))[[1]] rebuilt <- block$vectors %*% diag(block$values) %*% t(block$vectors) expect_equal(rebuilt, unname(ldMatrix(ld)), tolerance = 1e-10) }) -test_that("buildLdEigen carries variant identity across from the LdData", { - ref <- buildLdEigen(makeTestLdData(n = 6L)) +test_that("buildLdEigen carries variant identity across from an LdMatrix", { + ref <- buildLdEigen(makeTestLdMatrix(n = 6L)) md <- S4Vectors::mcols(ref, use.names = FALSE) - # An LdData names variants `variant_id` and reports `allele_freq`; an - # LdStatistic wants SNP and MAF. + # An LdMatrix records the frequency of A1 as `AF`; an LdStatistic wants + # it folded, as MAF. expect_equal(names(ref)[[1]], "chr1:1000:C:T") expect_equal(as.character(md$A1)[[1]], "T") expect_equal(as.character(md$A2)[[1]], "C") @@ -162,7 +166,7 @@ test_that("buildLdEigen carries variant identity across from the LdData", { }) test_that("buildLdEigen truncates to the requested eigenvalue mass", { - ld <- makeTestLdData(n = 6L) + ld <- makeTestLdMatrix(n = 6L) full <- eigenList(buildLdEigen(ld))[[1]] cut <- eigenList(buildLdEigen(ld, eigenvalueTruncation = 0.9))[[1]] @@ -175,7 +179,7 @@ test_that("buildLdEigen truncates to the requested eigenvalue mass", { test_that("buildLdEigen prefers an explicit nRef, inSample and genome", { ref <- buildLdEigen( - makeTestLdData(), + makeTestLdMatrix(), nSamples = 12345L, inSample = TRUE, genome = "hg38" @@ -226,16 +230,42 @@ test_that("LdEigen: argument guards fire", { }) test_that("buildLdEigen: argument guards fire", { - meta <- system.file( - "extdata", - "ld_reference", - "ld_meta_file.tsv", - package = "pecotmr" - ) - ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") + ld <- makeTestLdMatrix() expect_error(buildLdEigen(ld, nSamples = 0L), "nSamples.*Must be >= 1") expect_error( buildLdEigen(ld, inSample = NA), "inSample.*May not be NA" ) }) + +test_that("buildLdEigen from a panel decomposes each block when asked", { + fx <- .h2PanelFixture() + lazy <- buildLdEigen(fx$panel, ldBlocks = fx$blocks, genome = "hg19") + stored <- buildLdEigen(fx$ld, genome = "hg19") + expect_length(methods::slot(lazy, "eigenList"), 0L) + expect_identical(ldReference(lazy), fx$panel) + blocks <- eigenList(lazy) + expect_length(blocks, 3L) + # Blocks of 60, 140 and 100 variants from 100 samples: the middle one + # lists 100 directions and counts its other 40 zero-eigenvalue ones. + expect_equal(map_int(blocks, "nNull"), c(0L, 40L, 0L)) + expect_equal(lengths(map(blocks, "values")), c(60L, 100L, 100L)) + expect_equal( + blocks[[2L]]$values[1:90], + eigenList(stored)[[2L]]$values[1:90] + ) + expect_equal(map(blocks, "snpIdx"), map(eigenList(stored), "snpIdx")) + out <- capture.output(show(lazy)) + expect_true(any(grepl("across 3 blocks", out))) + expect_true(any(grepl("computed from the genotype panel", out))) + expect_error(lazy[1:2], "cannot be subset") +}) + +test_that("an LdEigen stores one decomposition per block or reads them all", { + fx <- .h2PanelFixture() + lazy <- buildLdEigen(fx$panel, ldBlocks = fx$blocks, genome = "hg19") + stored <- buildLdEigen(fx$ld, genome = "hg19") + mixed <- lazy + mixed@eigenList <- eigenList(stored) + expect_error(validObject(mixed), "Variable 'eigenList'.*Must have length") +}) diff --git a/tests/testthat/test_LdMatrix.R b/tests/testthat/test_LdMatrix.R new file mode 100644 index 000000000..67efd6abc --- /dev/null +++ b/tests/testthat/test_LdMatrix.R @@ -0,0 +1,302 @@ +# Tests for the LdMatrix class (R/LdMatrix.R). + +# Eight chr22 variants from the bundled eQTL region, with their sample LD. +.ldmFixture <- function() { + data(eqtlRegionExample, envir = environment()) + X <- eqtlRegionExample$X[, 1:8] + list(X = X, R = cor(X), ids = colnames(X)) +} + +# The variant table of `ids` (chrom:pos:A2:A1) as a data frame. +.ldmTable <- function(ids, af = NULL) { + p <- parseVariantId(ids) + tbl <- data.frame( + chrom = p$chrom, + pos = p$pos, + A1 = p$A1, + A2 = p$A2, + SNP = ids + ) + if (!is.null(af)) { + tbl$AF <- af + } + tbl +} + +test_that("LdMatrix parses its variants from chrom:pos:A2:A1 dimnames", { + f <- .ldmFixture() + ld <- LdMatrix(f$R, nSamples = nrow(f$X)) + expect_s4_class(ld, "LdMatrix") + expect_s4_class(ld, "GRanges") + expect_equal(length(ld), 8L) + expect_identical(variantIds(ld), f$ids) + expect_identical(names(ld), f$ids) + expect_identical(as.character(GenomicRanges::seqnames(ld))[[1L]], "chr22") + p <- parseVariantId(f$ids) + expect_identical(S4Vectors::mcols(ld)$A1, p$A1) + expect_identical(S4Vectors::mcols(ld)$A2, p$A2) + expect_identical(ldMatrix(ld), f$R) + expect_identical(nSamples(ld), nrow(f$X)) + expect_null(mixtureWeights(ld)) +}) + +test_that("LdMatrix takes its variants from a table or a GRanges", { + f <- .ldmFixture() + af <- seq(0.05, 0.4, length.out = 8L) + fromTable <- LdMatrix(unname(f$R), variants = .ldmTable(f$ids, af)) + expect_identical(rownames(ldMatrix(fromTable)), f$ids) + expect_equal(unname(af(fromTable)), af) + expect_identical(names(af(fromTable)), f$ids) + expect_true(is.na(nSamples(fromTable))) + + gr <- GenomicRanges::GRanges( + "22", + IRanges::IRanges(parseVariantId(f$ids)$pos, width = 1L), + A1 = parseVariantId(f$ids)$A1, + A2 = parseVariantId(f$ids)$A2 + ) + fromRanges <- LdMatrix(f$R, variants = gr, nSamples = 100) + # Unnamed ranges with no SNP column take the matrix's labels. + expect_identical(variantIds(fromRanges), f$ids) + expect_identical( + as.character(GenomicRanges::seqnames(fromRanges))[[1L]], + "chr22" + ) +}) + +test_that("an unlabelled matrix without variants is refused", { + f <- .ldmFixture() + expect_error(LdMatrix(unname(f$R)), "`variants` is required") + bad <- `dimnames<-`(f$R, list(letters[1:8], letters[1:8])) + expect_error(LdMatrix(bad), "not chrom:pos:A2:A1") +}) + +test_that("variant ids come from a variant_id column or the ranges' names", { + f <- .ldmFixture() + p <- parseVariantId(f$ids) + tbl <- data.frame( + chrom = p$chrom, + pos = p$pos, + A1 = p$A1, + A2 = p$A2, + variant_id = f$ids + ) + expect_identical(variantIds(LdMatrix(unname(f$R), variants = tbl)), f$ids) + gr <- GenomicRanges::GRanges( + "22", + IRanges::IRanges(p$pos, width = 1L), + A1 = p$A1, + A2 = p$A2 + ) + named <- LdMatrix(unname(f$R), variants = `names<-`(gr, f$ids)) + expect_identical(variantIds(named), f$ids) + expect_identical(rownames(ldMatrix(named)), f$ids) +}) + +test_that("variants that cannot describe the matrix are refused", { + f <- .ldmFixture() + p <- parseVariantId(f$ids) + expect_error( + LdMatrix(f$R, variants = "chr22"), + "must be a GRanges, a data frame or NULL \\(got character\\)" + ) + expect_error( + LdMatrix( + unname(f$R), + variants = data.frame(chrom = p$chrom, pos = p$pos) + ), + "lacks column\\(s\\) A1, A2" + ) + expect_error( + LdMatrix( + unname(f$R), + variants = .ldmTable(replace(f$ids, 2L, f$ids[[1L]])) + ), + "variant ids must be unique" + ) +}) + +test_that("a matrix labelled differently from its variants is refused", { + f <- .ldmFixture() + tbl <- .ldmTable(rev(f$ids)) + expect_error( + LdMatrix(f$R, variants = tbl), + "dimnames do not match the variant ids" + ) + expect_error( + LdMatrix(f$R[1:3, 1:3], variants = .ldmTable(f$ids)), + "lists 8 variant" + ) +}) + +test_that("validity rejects a matrix that is not a correlation matrix", { + f <- .ldmFixture() + offDiag <- f$R + offDiag[1, 2] <- offDiag[2, 1] <- 1.5 + expect_error(LdMatrix(offDiag), "outside \\[-1, 1\\]") + badDiag <- `diag<-`(f$R, 0.9) + expect_error(LdMatrix(badDiag), "diagonal is not 1") + asym <- f$R + asym[1, 2] <- 0.9 + expect_error(LdMatrix(asym), "not symmetric") + withNa <- f$R + withNa[1, 2] <- withNa[2, 1] <- NA + expect_error(LdMatrix(withNa), "missing") + expect_error(LdMatrix(f$R, nSamples = 0), "nSamples") + expect_error( + LdMatrix(unname(f$R), variants = .ldmTable(f$ids, rep(2, 8))), + "allele frequencies in \\[0, 1\\]" + ) +}) + +test_that("validity catches a part changed after construction", { + # The constructor never builds these, but `@<-` and `mcols<-` assign a + # part on its own, and validObject() is what catches the result. + f <- .ldmFixture() + ld <- LdMatrix(f$R, nSamples = 30) + noA1 <- ld + S4Vectors::mcols(noA1)$A1 <- NULL + expect_error(validObject(noA1), "carry no A1 column") + small <- ld + small@correlation <- f$R[1:2, 1:2] + expect_error(validObject(small), "is 2 x 2 but there are 8 variant") + relabelled <- ld + relabelled@correlation <- `dimnames<-`(f$R, list(rev(f$ids), rev(f$ids))) + expect_error(validObject(relabelled), "names must be the variant ids") + withNa <- ld + withNa@correlation[1, 2] <- NA + expect_error(validObject(withNa), "holds missing values") + noSize <- ld + noSize@nSamples <- 0L + expect_error(validObject(noSize), "one positive count") + mix <- LdMatrix(list(ld, ld), mixtureWeights = c(0.5, 0.5)) + mix@mixtureWeights <- c(0.5, 0.6) + expect_error(validObject(mix), "non-negative and sum to 1") +}) + +test_that("subsetting an LdMatrix subsets its matrix with it", { + f <- .ldmFixture() + ld <- LdMatrix(f$R, nSamples = 50) + sub <- ld[c(4, 2)] + expect_s4_class(sub, "LdMatrix") + expect_identical(variantIds(sub), f$ids[c(4, 2)]) + expect_identical(ldMatrix(sub), f$R[c(4, 2), c(4, 2)]) + expect_identical(nSamples(sub), 50L) + empty <- ld[integer(0)] + expect_equal(length(empty), 0L) + expect_equal(dim(ldMatrix(empty)), c(0L, 0L)) + expect_true(validObject(empty)) +}) + +test_that("a mixture is the weighted average of its components", { + f <- .ldmFixture() + half <- seq_len(nrow(f$X) / 2) + rA <- cor(f$X[half, ]) + rB <- cor(f$X[-half, ]) + ldA <- LdMatrix( + unname(rA), + variants = .ldmTable(f$ids, rep(0.2, 8)), + nSamples = length(half) + ) + ldB <- LdMatrix( + unname(rB), + variants = .ldmTable(f$ids, rep(0.4, 8)), + nSamples = nrow(f$X) - length(half) + ) + mix <- LdMatrix(list(ldA, ldB), mixtureWeights = c(0.75, 0.25)) + expect_equal(unname(ldMatrix(mix)), unname(0.75 * rA + 0.25 * rB)) + expect_identical(mixtureWeights(mix), c(0.75, 0.25)) + expect_equal(unname(af(mix)), rep(0.75 * 0.2 + 0.25 * 0.4, 8)) + nA <- length(half) + nB <- nrow(f$X) - nA + expect_identical( + nSamples(mix), + as.integer(round(1 / (0.75^2 / nA + 0.25^2 / nB))) + ) +}) + +test_that("mixture components are put into the first one's allele coding", { + f <- .ldmFixture() + ldA <- LdMatrix(f$R, variants = .ldmTable(f$ids, rep(0.3, 8))) + # Component B codes variant 2 the other way round: its id, its alleles, + # its frequency and the sign of every correlation it takes part in flip. + p <- parseVariantId(f$ids[[2L]]) + swapped <- str_c("chr22:", p$pos, ":", p$A1, ":", p$A2) + idsB <- replace(f$ids, 2L, swapped) + sgn <- replace(rep(1, 8), 2L, -1) + rB <- `dimnames<-`(f$R * outer(sgn, sgn), list(idsB, idsB)) + ldB <- LdMatrix( + rB, + variants = .ldmTable(idsB, replace(rep(0.3, 8), 2L, 0.7)) + ) + mix <- LdMatrix(list(ldA, ldB), mixtureWeights = c(0.5, 0.5)) + expect_equal(ldMatrix(mix), f$R) + expect_equal(unname(af(mix)), rep(0.3, 8)) + expect_identical(variantIds(mix), f$ids) +}) + +test_that("a mixture keeps only the variants every component covers", { + f <- .ldmFixture() + ldA <- LdMatrix(f$R) + ldB <- LdMatrix(f$R[2:8, 2:8]) + expect_message( + mix <- LdMatrix(list(ldA, ldB), mixtureWeights = c(0.5, 0.5)), + "1 variant\\(s\\) of the first component are not in every component" + ) + expect_identical(variantIds(mix), f$ids[2:8]) + # A component without a size or frequencies leaves the mixture without. + expect_true(is.na(nSamples(mix))) + expect_null(S4Vectors::mcols(mix)$AF) +}) + +test_that("a mixture needs LdMatrix components and valid weights", { + f <- .ldmFixture() + ld <- LdMatrix(f$R) + expect_error( + LdMatrix(list(ld), mixtureWeights = 1), + "at least two LdMatrix" + ) + expect_error( + LdMatrix(list(ld, f$R), mixtureWeights = c(0.5, 0.5)), + "at least two LdMatrix" + ) + expect_error( + LdMatrix(list(ld, ld), mixtureWeights = c(0.5, 0.6)), + "summing to 1" + ) + expect_error(LdMatrix(list(ld, ld)), "summing to 1") + expect_error( + LdMatrix(f$R, mixtureWeights = c(0.5, 0.5)), + "for combining LD matrices" + ) + disjoint <- LdMatrix(f$R[1:2, 1:2]) + expect_error( + LdMatrix( + list(disjoint, LdMatrix(f$R[3:4, 3:4])), + mixtureWeights = c(0.5, 0.5) + ), + "share no variant" + ) +}) + +test_that("a Matrix-package matrix is made dense", { + skip_if_not_installed("Matrix") + f <- .ldmFixture() + ld <- LdMatrix(Matrix::Matrix(f$R), nSamples = 10) + expect_true(is.matrix(ldMatrix(ld))) + expect_equal(ldMatrix(ld), f$R) +}) + +test_that("show reports the size, a mixture and missing frequencies", { + f <- .ldmFixture() + out <- capture.output(show(LdMatrix(f$R, nSamples = 30))) + expect_true(any(grepl("8 variants, panel size 30", out))) + expect_true(any(grepl("no allele frequencies", out))) + unknown <- capture.output(show(LdMatrix(f$R))) + expect_true(any(grepl("panel size unknown", unknown))) + mix <- LdMatrix( + list(LdMatrix(f$R), LdMatrix(f$R)), + mixtureWeights = c(0.5, 0.5) + ) + expect_true(any(grepl("mixture of 2 panels", capture.output(show(mix))))) +}) diff --git a/tests/testthat/test_LdScore.R b/tests/testthat/test_LdScore.R index 84ac17145..d0a3562de 100644 --- a/tests/testthat/test_LdScore.R +++ b/tests/testthat/test_LdScore.R @@ -117,42 +117,98 @@ test_that("validity requires the score columns to be present in mcols", { # buildLdScore # ============================================================================= -test_that("buildLdScore computes per-block sums of r^2", { - ld <- makeTestLdData(n = 6L) +test_that("buildLdScore sums ldsc's unbiased r^2 within each block", { + ld <- makeTestLdMatrix(n = 6L) ref <- buildLdScore(ld) + r2 <- unname(ldMatrix(ld))^2 expect_s4_class(ref, "LdScore") expect_equal(length(ref), 6L) expect_equal(colnames(mcols(ref)$ldScores), "base_l2") + # makeTestLdMatrix records a 500-sample panel. expect_equal( as.vector(mcols(ref)$ldScores[, 1]), - rowSums(unname(ldMatrix(ld))^2) + rowSums(r2 - (1 - r2) / (500 - 2)) ) }) test_that("buildLdScore scores each block against only its own variants", { - ld <- makeTestLdDataMultiBlock(sizes = c(4L, 3L)) + ld <- makeTestLdMatrixBlocks(sizes = c(4L, 3L)) scores <- as.vector(mcols(buildLdScore(ld))$ldScores[, 1]) - perBlock <- unlist(map(ldMatrix(ld), function(R) rowSums(R^2))) + perBlock <- unlist(map( + map(ld, ldMatrix), + function(R) rowSums(R^2 - (1 - R^2) / (500 - 2)) + )) expect_equal(length(scores), 7L) - expect_equal(scores, perBlock) + expect_equal(scores, unname(perBlock)) +}) + +# The unbiased r^2 is ldsc's (ldscore.py, __l2_unbiased__). These inputs are +# exact in binary: r = 0.5 gives 0.25 - 0.75 / 8 = 0.15625, and r = 0 gives +# -1 / 8, which ldsc keeps rather than flooring. A variant's own term stays 1. +test_that("the unbiased r^2 is r^2 - (1 - r^2) / (n - 2), as in ldsc", { + R <- matrix(c(1, 0.5, 0, 0.5, 1, -0.5, 0, -0.5, 1), 3L, 3L) + ld <- LdMatrix( + R, + variants = .testLdVariants(3L, "chr1", 1000L), + nSamples = 10L + ) + # The raw sums would be c(1.25, 1.5, 1.25). + expect_identical( + as.vector(mcols(buildLdScore(ld))$ldScores[, 1]), + c(1.03125, 1.3125, 1.03125) + ) +}) + +# Summed over a block with weights a_k, the unbiased r^2 is affine in the raw +# weighted sum: ((n - 1) * sum_k a_k r2_jk - sum_k a_k) / (n - 2). The LdEigen +# route relies on that to correct scores it never forms r^2 for, so it must +# hold exactly, for binary and continuous weights alike. +test_that("the summed form of the unbiased r^2 is exact under any weights", { + set.seed(11) + R <- cov2cor(crossprod(matrix(rnorm(40 * 8), 40, 8))) + a <- cbind(base = 1, binary = c(1, 0, 0, 1, 1, 0, 1, 0), cont = runif(8)) + expect_equal( + pecotmr:::.ldscUnbiasedSum((R^2) %*% a, colSums(a), 40L), + pecotmr:::.ldscUnbiasedR2(R^2, 40L) %*% a, + tolerance = 1e-12 + ) +}) + +test_that("the unbiased r^2 needs a reference panel of more than 2", { + # An LdMatrix that records no panel size leaves nothing to divide by. + expect_error( + buildLdScore(makeTestLdMatrix(nSamples = NA_integer_)), + "`nSamples` is required" + ) + expect_error( + buildLdScore(makeTestLdMatrix(), nSamples = 2L), + "needs more than 2 samples, and it records 2" + ) + # Naming the panel size rescues an LdMatrix that records none. + expect_s4_class( + buildLdScore(makeTestLdMatrix(nSamples = NA_integer_), nSamples = 10L), + "LdScore" + ) }) # buildLdScore and computeLdScores(LdEigen) are two routes to the same -# quantity -- sum_k r^2_jk versus sum_i V[j,i]^2 d[i]^2 -- so a disagreement -# means one of them has drifted. +# quantity -- the first sums the unbiased r^2 over R, the second corrects +# sum_i V[j,i]^2 d[i]^2 (= sum_k r^2_jk) through the summed form -- so a +# disagreement means one of them has drifted. test_that("buildLdScore agrees with computeLdScores on the same reference", { - for (ld in list(makeTestLdData(n = 6L), makeTestLdDataMultiBlock())) { + for (ld in list(makeTestLdMatrix(n = 6L), makeTestLdMatrixBlocks())) { expect_equal( as.vector(mcols(buildLdScore(ld))$ldScores[, 1]), - as.vector(computeLdScores(buildLdEigen(ld))[, 1]) + as.vector(computeLdScores(buildLdEigen(ld))[, 1]), + tolerance = 1e-12 ) } }) test_that("buildLdScore keeps per-block LD matrices for g-LDSC by default", { - ld <- makeTestLdDataMultiBlock(sizes = c(4L, 3L)) + ld <- makeTestLdMatrixBlocks(sizes = c(4L, 3L)) mats <- ldMatrixList(buildLdScore(ld)) expect_equal(length(mats), 2L) @@ -166,7 +222,7 @@ test_that("buildLdScore keeps per-block LD matrices for g-LDSC by default", { }) test_that("buildLdScore defaults weights to 1/max(l2, 1)", { - ld <- makeTestLdData(n = 6L) + ld <- makeTestLdMatrix(n = 6L) ref <- buildLdScore(ld) l2 <- as.vector(mcols(ref)$ldScores[, 1]) expect_equal(mcols(ref)$ldScoreWeights, 1 / pmax(l2, 1)) @@ -180,13 +236,7 @@ test_that("buildLdScore defaults weights to 1/max(l2, 1)", { }) test_that("buildLdScore: argument guards fire", { - meta <- system.file( - "extdata", - "ld_reference", - "ld_meta_file.tsv", - package = "pecotmr" - ) - ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") + ld <- makeTestLdMatrix() expect_error(buildLdScore(ld, nSamples = 0L), "nSamples.*Must be >= 1") expect_error(buildLdScore(ld, inSample = NA), "inSample.*May not be NA") expect_error( @@ -195,8 +245,66 @@ test_that("buildLdScore: argument guards fire", { ) }) -test_that(".ldScoreVector answers all-zero scores when there are no blocks", { - # Variants in no block keep a zero score, so no blocks at all is a - # zero vector of the full variant length rather than an error. - expect_identical(pecotmr:::.ldScoreVector(list(), NULL, 3L), numeric(3)) +test_that("buildLdScore reads a panel's blocks as LdMatrix blocks give them", { + fx <- .h2PanelFixture() + lazy <- buildLdScore(fx$panel, ldBlocks = fx$blocks, genome = "hg19") + stored <- buildLdScore(fx$ld, genome = "hg19") + expect_equal( + S4Vectors::mcols(lazy)$ldScores, + S4Vectors::mcols(stored)$ldScores, + tolerance = 1e-10 + ) + expect_equal( + S4Vectors::mcols(lazy)$ldScoreWeights, + S4Vectors::mcols(stored)$ldScoreWeights, + tolerance = 1e-10 + ) + # The panel is never copied into matrices, whatever keepLdMatrices says. + expect_length(methods::slot(lazy, "ldMatrixList"), 0L) + expect_length(methods::slot(stored, "ldMatrixList"), 3L) + expect_null(ldReference(stored)) + out <- capture.output(show(lazy)) + expect_true(any(grepl("read from the genotype panel", out))) + out <- capture.output(show(stored)) + expect_true(any(grepl("stored matrices", out))) + bare <- buildLdScore(fx$ld, genome = "hg19", keepLdMatrices = FALSE) + out <- capture.output(show(bare)) + expect_true(any(grepl("scores only", out))) +}) + +test_that("an LdScore storing block matrices refuses every subset", { + # Each stored block indexes its variants by position, so a subset or a + # reorder would leave the matrices describing other variants. head() and + # rev() reach the rows without `[`, so they are refused as well. + fx <- .h2PanelFixture() + stored <- buildLdScore(fx$ld, genome = "hg19") + msg <- "an LdScore storing per-block LD matrices cannot be subset" + expect_error(stored[1:3], msg) + expect_error(head(stored, 3), msg) + expect_error(rev(stored), msg) +}) + +test_that("an LdScore without stored matrices subsets freely", { + # Each block's variants are found afresh from the ranges, so the scores + # and the block LD of the variants kept stay in step. + fx <- .h2PanelFixture() + lazy <- buildLdScore(fx$panel, ldBlocks = fx$blocks, genome = "hg19") + bare <- buildLdScore(fx$ld, genome = "hg19", keepLdMatrices = FALSE) + keep <- c(5:40, 100:150) + for (obj in list(lazy, bare)) { + sub <- obj[keep] + expect_length(sub, length(keep)) + expect_equal( + S4Vectors::mcols(sub)$ldScores, + S4Vectors::mcols(obj)$ldScores[keep, , drop = FALSE] + ) + } + # The panel's LD over the kept variants is the full blocks' restricted to + # them; the third block keeps no variant and so has no entry. + full <- ldMatrixList(lazy) + sub <- ldMatrixList(lazy[keep]) + expect_length(sub, 2L) + expect_equal(sub[[1L]]$R, full[[1L]]$R[5:40, 5:40], tolerance = 1e-12) + expect_equal(sub[[2L]]$R, full[[2L]]$R[40:90, 40:90], tolerance = 1e-12) + expect_equal(map(sub, "snpIdx"), list(1:36, 37:87)) }) diff --git a/tests/testthat/test_LdStatistic.R b/tests/testthat/test_LdStatistic.R index a02d715f0..7efc731b4 100644 --- a/tests/testthat/test_LdStatistic.R +++ b/tests/testthat/test_LdStatistic.R @@ -131,47 +131,63 @@ test_that("ldBlocks returns the blocks the statistic was built against", { # ============================================================================= -# .ldRefPrepare -- the input handling shared by buildLdEigen/buildLdScore +# .h2RefPrepare -- the input handling shared by buildLdEigen/buildLdScore # ============================================================================= -test_that("the builders accept a bare LdData as well as a list of them", { - one <- makeTestLdData(n = 4L, startBp = 1000L) - two <- makeTestLdData(n = 3L, startBp = 5000L) +test_that("the builders accept one LdMatrix as well as a list of them", { + one <- makeTestLdMatrix(n = 4L, startBp = 1000L) + two <- makeTestLdMatrix(n = 3L, startBp = 5000L) expect_equal(length(buildLdEigen(one)), 4L) expect_equal(length(buildLdEigen(list(one))), 4L) - # A list of LdData concatenates: one LD block per element here, and the - # variant order follows the list order. + # A list concatenates, one LD block per element, and the variant order + # follows the list order. joined <- buildLdEigen(list(one, two)) expect_equal(length(joined), 7L) expect_equal(length(eigenList(joined)), 2L) expect_equal(eigenList(joined)[[2]]$snpIdx, 5:7) }) -test_that("the builders reject input that is not LdData", { - expect_error(buildLdEigen("not-ld"), "must be an LdData") - expect_error(buildLdEigen(list()), "must be an LdData") +test_that("the builders reject anything but LdMatrix blocks or a panel", { + msg <- "must be a genotype panel, an LdMatrix, or a non-empty list" + expect_error(buildLdEigen("not-ld"), msg) + expect_error(buildLdEigen(list()), msg) + expect_error(buildLdScore(list(makeTestLdMatrix(), "not-ld")), msg) expect_error( - buildLdScore(list(makeTestLdData(), "not-ld")), - "element\\(s\\) 2 are not LdData" + buildLdScore(makeTestLdMatrix(), ldBlocks = makeTestLdBlocks()), + "`ldBlocks` cuts a genotype panel" ) }) -test_that("nRef is taken from the LdData, and disagreement is an error", { - a <- makeTestLdData(n = 4L, nSamples = 500L) - b <- makeTestLdData(n = 3L, startBp = 5000L, nSamples = 900L) +test_that("nRef is taken from the LdMatrix blocks; disagreement is an error", { + a <- makeTestLdMatrix(n = 4L, nSamples = 500L) + b <- makeTestLdMatrix(n = 3L, startBp = 5000L, nSamples = 900L) expect_equal(ldPanelNSamples(buildLdEigen(list(a, a))), 500L) expect_error(buildLdEigen(list(a, b)), "differing reference panel sizes") # An explicit nRef settles it. - expect_equal(ldPanelNSamples(buildLdEigen(list(a, b), nSamples = 700L)), 700L) + expect_equal( + ldPanelNSamples(buildLdEigen(list(a, b), nSamples = 700L)), + 700L + ) }) -test_that("the genome build comes from the LdData when the caller names none", { - ld <- makeTestLdData() - # loadLdMatrix() leaves the build unset, which must stay NA rather than - # becoming a made-up default. +test_that("nSamples is required when no LdMatrix records one", { + unknown <- makeTestLdMatrix(n = 3L, nSamples = NA_integer_) + expect_error(buildLdScore(unknown), "`nSamples` is required") + expect_equal( + ldPanelNSamples(buildLdScore(unknown, nSamples = 250L)), + 250L + ) + # Alongside a block that does record one, that size is used. + known <- makeTestLdMatrix(n = 3L, startBp = 5000L, nSamples = 900L) + expect_equal(ldPanelNSamples(buildLdEigen(list(unknown, known))), 900L) +}) + +test_that("the genome build comes from the reference when none is named", { + ld <- makeTestLdMatrix() + # An unlabelled reference stays NA rather than becoming a made-up default. expect_true(is.na(unname(GenomeInfoDb::genome(buildLdEigen(ld))))) tagged <- ld @@ -185,7 +201,7 @@ test_that("the genome build comes from the LdData when the caller names none", { }) test_that("LD block ranges span the variants each block covers", { - ref <- buildLdEigen(makeTestLdDataMultiBlock(sizes = c(4L, 3L))) + ref <- buildLdEigen(makeTestLdMatrixBlocks(sizes = c(4L, 3L))) blocks <- ldBlocks(ref) variants <- GenomicRanges::start(ref) @@ -198,209 +214,135 @@ test_that("LD block ranges span the variants each block covers", { }) test_that("an LD block spanning chromosomes is rejected", { - ld <- makeTestLdData(n = 4L) - gr <- as(ld, "GRanges") - GenomeInfoDb::seqlevels(gr) <- c("chr1", "chr2") - GenomicRanges::seqnames(gr) <- factor( - c("chr1", "chr1", "chr2", "chr2"), - levels = c("chr1", "chr2") - ) - crossChrom <- LdData( - correlation = ldMatrix(ld), - variants = gr, - blockMetadata = blockMetadata(ld), - nSamples = ldPanelNSamples(ld) - ) + tbl <- .testLdVariants(4L, "chr1", 1000L) + tbl$chrom <- c("chr1", "chr1", "chr2", "chr2") + crossChrom <- LdMatrix(.testArBlock(4L, 0.5), variants = tbl, nSamples = 50) expect_error(buildLdEigen(crossChrom), "spans 2 chromosomes") }) -# =========================================================================== -# .ldRefPrepare()'s accessor fallbacks and guards -# -# The shared helpers behind buildLdEigen() / buildLdScore() read a variant's -# identity, alleles and frequency out of whatever columns the LdData happens -# to carry. Every fixture above supplies `variant_id` + `allele_freq` and a -# blockMetadata whose startIdx/endIdx line up, so only one path through each -# accessor was ever taken. These exercise the others. -# =========================================================================== - -# An LdData whose variant metadata is whatever the caller passes, so each -# accessor branch can be reached in turn. `blockMetadata` defaults to a -# single block spanning every variant. -.ldsVariants <- function(n, md = NULL, variantNames = NULL) { - gr <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges( - start = seq(100L, by = 100L, length.out = n), - width = 1L - ) - ) - if (is.null(md)) { - md <- S4Vectors::DataFrame( - variant_id = str_c("v", seq_len(n)), - A1 = rep("T", n), - A2 = rep("C", n) - ) - } - S4Vectors::mcols(gr) <- md - if (!is.null(variantNames)) { - names(gr) <- variantNames - } - gr -} - -.ldsBlockMeta <- function(sizes) { - ends <- cumsum(sizes) - starts <- ends - sizes + 1L - tibble( - blockId = seq_along(sizes), - chrom = "1", - blockStart = as.integer(100L * starts), - blockEnd = as.integer(100L * ends), - size = as.integer(sizes), - startIdx = as.integer(starts), - endIdx = as.integer(ends) - ) -} - -.ldsData <- function( - n = 3L, - md = NULL, - variantNames = NULL, - nSamples = 100L, - correlation = NULL, - blockMetadata = NULL -) { - LdData( - correlation = correlation %||% diag(n), - variants = .ldsVariants(n, md, variantNames), - blockMetadata = blockMetadata %||% .ldsBlockMeta(n), - nSamples = nSamples +test_that("an AF column becomes a folded MAF column; none leaves it off", { + tbl <- .testLdVariants(3L, "chr1", 1000L) + tbl$AF <- c(0.1, 0.9, 0.3) + got <- S4Vectors::mcols( + buildLdScore(LdMatrix(diag(3), variants = tbl, nSamples = 50)), + use.names = FALSE ) -} + expect_equal(as.numeric(got$MAF), c(0.1, 0.1, 0.3)) -.ldsAlleles <- function(n) { - S4Vectors::DataFrame(A1 = rep("T", n), A2 = rep("C", n)) -} - -test_that("variant ids fall back to a SNP column when there is no variant_id", { - md <- S4Vectors::DataFrame( - SNP = c("s1", "s2", "s3"), - A1 = rep("T", 3), - A2 = rep("C", 3) + tbl$AF <- NULL + bare <- S4Vectors::mcols( + buildLdScore(LdMatrix(diag(3), variants = tbl, nSamples = 50)), + use.names = FALSE ) - expect_equal(names(buildLdScore(.ldsData(3L, md))), c("s1", "s2", "s3")) + expect_false(is_in("MAF", colnames(bare))) + expect_identical(as.character(bare$SNP), tbl$SNP) }) -test_that("variant ids fall back to the GRanges names", { - expect_equal( - names(buildLdScore( - .ldsData(3L, .ldsAlleles(3L), variantNames = c("n1", "n2", "n3")) - )), - c("n1", "n2", "n3") +test_that("a genotype panel is cut into LD blocks at ldBlocks", { + panel <- readGenotypes(test_path("test_data", "test_variants.bed")) + pos <- GenomicRanges::start(SummarizedExperiment::rowRanges(panel)) + cut <- pos[[200L]] + # The block table may name chromosomes either way; a panel's are + # chr-prefixed. Variants outside every block are left out. + blocks <- data.frame( + chrom = "21", + start = c(pos[[1L]], cut), + end = c(cut - 1L, pos[[300L]]) ) -}) - -test_that("variant ids are synthesized from chrom:pos as a last resort", { + ref <- buildLdScore(panel, ldBlocks = blocks) + expect_equal(length(ref), 300L) + expect_equal(ldPanelNSamples(ref), ncol(panel)) + # It keeps the panel and each variant's row in it, not the blocks' LD... + expect_identical(ldReference(ref), panel) + expect_identical(S4Vectors::mcols(ref)$panelRow, 1:300) + expect_length(methods::slot(ref, "ldMatrixList"), 0L) + # ...and computes a block's LD from the panel when asked for it. + expect_equal(length(ldMatrixList(ref)), 2L) expect_equal( - names(buildLdScore(.ldsData(3L, .ldsAlleles(3L)))), - c("chr1:100", "chr1:200", "chr1:300") + unname(ldMatrixList(ref)[[2]]$R), + unname(computeLd(panel, snpIdx = 200:300)) ) -}) - -test_that("an MAF column is carried across as-is", { - md <- S4Vectors::DataFrame( - variant_id = c("a", "b", "c"), - A1 = rep("T", 3), - A2 = rep("C", 3), - MAF = c(0.1, 0.2, 0.3) + expect_error(buildLdScore(panel), "`ldBlocks` is required") + overlapping <- data.frame( + chrom = "chr21", + start = c(pos[[1L]], pos[[100L]]), + end = c(pos[[150L]], pos[[300L]]) ) - got <- S4Vectors::mcols(buildLdScore(.ldsData(3L, md)), use.names = FALSE) - expect_true(is_in("MAF", colnames(got))) - # Taken verbatim, NOT folded the way allele_freq is. - expect_equal(as.numeric(got$MAF), c(0.1, 0.2, 0.3)) -}) - -test_that("no frequency column leaves the MAF column off entirely", { - got <- S4Vectors::mcols( - buildLdScore(.ldsData(3L, .ldsAlleles(3L))), - use.names = FALSE - ) - expect_false(is_in("MAF", colnames(got))) -}) - -test_that("blocks are taken in order when blockMetadata has no startIdx", { - # The positional fallback: each block covers as many variants as its - # matrix has rows. blockMetadata is present but carries no index columns, - # so it cannot be treated as authoritative. - noIdx <- tibble( - blockId = 1:2, - chrom = "1", - blockStart = c(100L, 300L), - blockEnd = c(200L, 400L), - size = c(2L, 2L) + expect_error( + buildLdEigen(panel, ldBlocks = overlapping), + "`ldBlocks` overlap" ) - ref <- buildLdScore(.ldsData( - 4L, - correlation = list(diag(2), diag(2)), - blockMetadata = noIdx - )) - expect_equal(length(ref), 4L) - expect_equal(length(ldBlocks(ref)), 2L) }) -test_that("a variant table with no A1 column is rejected", { - md <- S4Vectors::DataFrame( - variant_id = c("a", "b", "c"), - A2 = rep("C", 3) +test_that("a stochastic sketch's blocks carry its effective size", { + skip_if_not_installed("pgenlibr") + sketch <- readGenotypes( + test_path("test_data", "test_harmonize_regions.pgen") ) - expect_error( - buildLdScore(.ldsData(3L, md)), - "carry no `A1` column" + gr <- SummarizedExperiment::rowRanges(sketch) + blocks <- data.frame( + chrom = "chr21", + start = min(GenomicRanges::start(gr)), + end = max(GenomicRanges::start(gr)) ) + ref <- buildLdEigen(sketch, ldBlocks = blocks) + # 50 real samples projected onto 100 pseudo-samples: 1 / (1/50 + 1/100). + expect_equal(ldPanelNSamples(ref), 33L) + # The sketch's real allele frequencies are carried as MAF. + af <- SummarizedExperiment::rowRanges(sketch)$AF + expect_equal(as.numeric(S4Vectors::mcols(ref)$MAF), pmin(af, 1 - af)) }) -test_that("block matrices that do not cover every variant are rejected", { +test_that("a statistic read from a panel must name each variant's panel row", { + fx <- .h2PanelFixture() + ref <- buildLdScore(fx$panel, ldBlocks = fx$blocks) + expect_true(validObject(ref)) + offPanel <- ref + S4Vectors::mcols(offPanel)$panelRow <- ref$panelRow + 1000L + expect_error(validObject(offPanel), "needs an integer `panelRow`") + unread <- ref + S4Vectors::mcols(unread)$panelRow <- NULL + expect_error(validObject(unread), "needs an integer `panelRow`") + # An LdMatrix reference's LD is stored per block, never read on demand. + asMatrix <- ref + asMatrix@ldReference <- fx$ld[[1L]] expect_error( - buildLdScore(.ldsData( - 3L, - correlation = list(diag(2), diag(2)), - blockMetadata = .ldsBlockMeta(c(2L, 2L)) - )), - "cover 4 variant\\(s\\) but the LdData carries 3" + validObject(asMatrix), + "must be a genotype panel or a GenotypeMixture" ) }) -test_that("a block matrix sized differently from its span is rejected", { - # sum(sizes) matches the variant count, so the earlier total check passes; - # the mis-span only shows up once each block is sliced out. - misSpan <- tibble( - blockId = 1:2, - chrom = "1", - blockStart = c(100L, 400L), - blockEnd = c(300L, 400L), - size = c(3L, 1L), - startIdx = c(1L, 4L), - endIdx = c(3L, 4L) +test_that("a block's LD and decomposition are read as stored", { + fx <- .h2PanelFixture() + idx <- 61:200 + want <- unname(computeLd(fx$panel, snpIdx = idx)) + stored <- list(idx = seq_along(idx), R = want) + lazy <- list(idx = seq_along(idx), rows = idx) + expect_equal(pecotmr:::.ldStatBlockLd(stored, NULL), list(R = want)) + F <- pecotmr:::.ldStatBlockLd(lazy, fx$panel)$F + expect_equal(unname(crossprod(F)) / (nrow(F) - 1), want) + # 140 variants and 100 samples: the SVD lists 100 directions and counts + # the other 40, whose eigenvalue is exactly zero, unless they would be + # truncated away anyway. + dec <- pecotmr:::.ldStatBlockEigen(lazy, fx$panel, 1) + expect_equal(length(dec$values), 100L) + expect_equal(dec$nNull, 40L) + expect_equal(dec$snpIdx, seq_along(idx)) + full <- eigen(want, symmetric = TRUE)$values + expect_equal(dec$values[1:90], full[1:90]) + expect_equal( + unname(dec$vectors %*% (dec$values * t(dec$vectors))), + want ) - expect_error( - buildLdScore(.ldsData( - 4L, - correlation = list(diag(2), diag(2)), - blockMetadata = misSpan - )), - "LD block correlation.*Must have exactly 3 rows" + cut <- pecotmr:::.ldStatBlockEigen(lazy, fx$panel, 0.9) + expect_equal(cut$nNull, 0L) + expect_equal( + length(cut$values), + length(pecotmr:::.ldEigenKeep(full, 0.9)) ) -}) - -test_that("nRef is required when no LdData records one", { - expect_error( - buildLdScore(.ldsData(3L, nSamples = NA_integer_)), - "`nRef` is required" + storedEigen <- list(idx = 1:3, eigen = list(values = 1, vectors = 1)) + expect_equal( + pecotmr:::.ldStatBlockEigen(storedEigen, NULL, 1)$nNull, + 0L ) }) - -test_that("an explicit nRef overrides a missing one", { - ref <- buildLdScore(.ldsData(3L, nSamples = NA_integer_), nSamples = 250L) - expect_equal(ldPanelNSamples(ref), 250L) -}) diff --git a/tests/testthat/test_MethodParam.R b/tests/testthat/test_MethodParam.R index 0dfbaf564..4aa2908c6 100644 --- a/tests/testthat/test_MethodParam.R +++ b/tests/testthat/test_MethodParam.R @@ -70,6 +70,37 @@ test_that("a path slot refuses options built for the other path", { ) }) +test_that("a method's names are checked against the path that runs it", { + skip_if_not_installed("susieR") + indiv <- pecotmr:::.methodsPathAccepted( + "FineMappingMethodsParam", + "susie", + "QtlDataset" + ) + sumst <- pecotmr:::.methodsPathAccepted( + "FineMappingMethodsParam", + "susie", + "QtlSumStats" + ) + # `z` is a susie_rss argument and not a susie one. + expect_false(is_in("z", indiv)) + expect_true(is_in("z", sumst)) + # `y` is susie-only, so the mirror image holds. + expect_true(is_in("y", indiv)) + expect_false(is_in("y", sumst)) + # A name both callees accept is fine either way. + expect_true(is_in("L", indiv)) + expect_true(is_in("L", sumst)) + # Why this matters: validating against the UNION of both callees accepts + # `z` even for an individual-level run, and the setting then reaches an + # engine that never reads it. + both <- pecotmr:::.engineAcceptedNames( + c("susieR::susie", "susieR::susie_rss") + ) + expect_true(is_in("z", both)) + expect_false(is_in("z", pecotmr:::.engineAcceptedNames("susieR::susie"))) +}) + test_that("a path slot offers only the methods that run on it", { expect_error( FineMappingMethodsParam(qtlSumStatsMethods = list(fsusie = list())), @@ -642,3 +673,175 @@ test_that(".methodsParamFor and ...ForMulti route each input shape", { "must be a character vector, a named list" ) }) + +# ---- argument naming ----------------------------------------------------- + +# Every closure pecotmr defines: the namespace's functions plus the methods of +# its own generics. A method whose signature differs from its generic's is +# stored as a wrapper around an inner `.local`, whose formals the caller sees. +.mpUnwrapLocal <- function(f) { + b <- body(f) + isLocal <- is.call(b) && + identical(b[[1]], as.name("{")) && + is.call(b[[2]]) && + identical(b[[2]][[2]], as.name(".local")) + if (isLocal) eval(b[[2]][[3]]) else f +} + +.mpMethodsOf <- function(g, ns) { + defs <- methods::findMethods(g, where = ns) + set_names( + map(defs, .mpUnwrapLocal), + str_c(g, "[", map_chr(defs, .mpSignatureLabel), "]") + ) +} + +.mpSignatureLabel <- function(m) str_flatten(m@defined, ",") + +.mpClosures <- function(exportedOnly = FALSE) { + ns <- asNamespace("pecotmr") + nms <- if (exportedOnly) { + getNamespaceExports(ns) + } else { + ls(ns, all.names = TRUE) + } + fns <- keep( + mget(nms, envir = ns, inherits = TRUE, ifnotfound = list(NULL)), + is.function + ) + gens <- intersect(as.character(methods::getGenerics(where = ns)), nms) + c(fns, list_flatten(map(gens, .mpMethodsOf, ns = ns))) +} + +# The symbols a call tree passes as a function VALUE: the `.f` / FUN slot of +# the iteration helpers and the first argument of exec() and friends. +.mpFunSlot <- c( + exec = 1L, + do.call = 1L, + match.fun = 1L, + Filter = 1L, + Reduce = 1L, + Map = 1L, + mapply = 1L, + map = 2L, + map_lgl = 2L, + map_int = 2L, + map_dbl = 2L, + map_chr = 2L, + imap = 2L, + walk = 2L, + keep = 2L, + discard = 2L, + reduce = 2L, + accumulate = 2L, + detect = 2L, + lapply = 2L, + sapply = 2L, + vapply = 2L, + pmap = 2L, + map2 = 3L, + imap_chr = 2L, + apply = 3L +) + +.mpFunValueSymbols <- function(e) { + if (!is.call(e)) { + return(character(0)) + } + head <- if (is.symbol(e[[1]])) as.character(e[[1]]) else "" + here <- character(0) + if (is_in(head, names(.mpFunSlot)) && length(e) > .mpFunSlot[[head]]) { + named <- intersect(names(e), c(".f", ".fn", "FUN", "f", "what")) + a <- if (length(named)) { + e[[named[[1]]]] + } else { + e[[.mpFunSlot[[head]] + 1L]] + } + if (is.symbol(a)) here <- as.character(a) + } + rest <- map(as.list(e)[-1], .mpFunValueSymbolsSafe) + unique(c(here, unlist(rest, use.names = FALSE))) +} + +.mpFunValueSymbolsSafe <- function(a) { + if (missing(a) || is.null(a)) character(0) else .mpFunValueSymbols(a) +} + +.mpIsNsFunction <- function(n, ns) is.function(get(n, envir = ns)) + +.mpShadowedValues <- function(f, label, own) { + hit <- intersect( + intersect(.mpFunValueSymbols(body(f)), names(formals(f))), + own + ) + if (length(hit)) hit else NULL +} + +test_that("no formal that shadows a pecotmr function is passed as a value", { + # Arguments are named after their class (credibleSetParam = + # CredibleSetParam()), so a few share a name with an accessor generic -- + # credibleSetParam(), susieRssParam(), panelFilterParam(). That is safe + # while the function only CALLS the accessor, because R skips non-function + # bindings when it looks up a call. It breaks the moment the accessor is + # passed as a value -- map(objs, credibleSetParam) -- because the formal + # is found instead. This pins the condition the shadowing relies on. + ns <- asNamespace("pecotmr") + own <- keep(ls(ns, all.names = TRUE), .mpIsNsFunction, ns = ns) + # The detector is not vacuous: it flags exactly that shape. + probe <- function(credibleSetParam, fits) map(fits, credibleSetParam) + expect_equal( + .mpShadowedValues(probe, "probe", own = own), + "credibleSetParam" + ) + closures <- .mpClosures() + bad <- compact(imap(closures, .mpShadowedValues, own = own)) + expect_equal( + str_c(names(bad), ": ", map_chr(bad, str_flatten, ", ")), + character(0) + ) +}) + +.mpParamFormals <- function(f, label) { + # formals() is a pairlist, which purrr deprecated as an input. + fm <- as.list(formals(f)) + isParam <- map_lgl(fm, .mpIsParamCall) + map(names(fm)[isParam], .mpFormalRecord, fm = fm, label = label) +} + +.mpIsParamCall <- function(d) { + is.call(d) && + is.symbol(d[[1]]) && + methods::extends(as.character(d[[1]]), "MethodParam") +} + +.mpFormalRecord <- function(nm, fm, label) { + list(fn = label, formal = nm, class = as.character(fm[[nm]][[1]])) +} + +.mpDescribeFormal <- function(r) { + str_c(r$fn, ": ", r$formal, " = ", r$class, "()") +} + +.mpNamedAfterClass <- function(r, roleNamed) { + expected <- str_c(tolower(substr(r$class, 1, 1)), substring(r$class, 2)) + identical(r$formal, expected) || is_in(r$formal, roleNamed) +} + +test_that("an argument taking a *Param record is named after its class", { + # Settings pecotmr reads travel as *Param records, passed under the + # class's own name (crossValidationParam = CrossValidationParam()); engine + # argument bundles (*Options) keep the *Args / methodArgs names. The four + # below are named for their role instead, and are the only exceptions. + roleNamed <- c("prior", "priors", "columns", "pruning") + expect_false(.mpNamedAfterClass( + list(formal = "crossValidationArgs", class = "CrossValidationParam"), + roleNamed = roleNamed + )) + found <- list_flatten(imap( + .mpClosures(exportedOnly = TRUE), + .mpParamFormals + )) + misnamed <- discard(found, .mpNamedAfterClass, roleNamed = roleNamed) + expect_gt(length(found), 0L) + expect_equal(unname(map_chr(misnamed, .mpDescribeFormal)), character(0)) +}) diff --git a/tests/testthat/test_MultiStudyQtlDataset.R b/tests/testthat/test_MultiStudyQtlDataset.R index 8f4097ff3..c8790032b 100644 --- a/tests/testthat/test_MultiStudyQtlDataset.R +++ b/tests/testthat/test_MultiStudyQtlDataset.R @@ -45,7 +45,7 @@ test_that("MultiStudyQtlDataset: rejects unnamed qtlDatasets list", { }) -test_that("MultiStudyQtlDataset: rejects trait/position conflicts across studies", { +test_that("MultiStudyQtlDataset: rejects a trait at two positions", { se1 <- .sc_makeSe(traits = "ENSG1") # Build se2 from scratch (see note in the QtlDataset trait-conflict test). rng2 <- GenomicRanges::GRanges( @@ -85,7 +85,7 @@ test_that("MultiStudyQtlDataset: rejects trait/position conflicts across studies }) -test_that("MultiStudyQtlDataset: tolerates chr-prefix-only seqname differences across studies", { +test_that("MultiStudyQtlDataset: allows studies differing only in chr prefix", { # se1 uses "chr1"; se2 is the SAME locus (chr1:1000-1499) but seqnames "1". se1 <- .sc_makeSe(traits = "ENSG1") rng2 <- GenomicRanges::GRanges( @@ -142,7 +142,7 @@ test_that("sumStats(MultiStudyQtlDataset) rejects selection arguments", { trait = "t1", entry = list(gr), genome = "hg19", - ldSketch = .sc_makeGenotypeHandle() + ldReference = .sc_makeGenotypeHandle() ) qd1 <- QtlDataset( studyName = "s1", @@ -186,6 +186,8 @@ test_that("MultiStudyQtlDataset: rejects duplicated study names", { }) test_that("MultiStudyQtlDataset: rejects a non-QtlSumStats sumStats", { + # The slot is typed QtlSumStats_OR_NULL, so S4 refuses the value when the + # object is built. qd <- QtlDataset( studyName = "s1", genotypes = .sc_makeGenotypeHandle(), @@ -196,7 +198,7 @@ test_that("MultiStudyQtlDataset: rejects a non-QtlSumStats sumStats", { qtlDatasets = list(s1 = qd, s2 = qd), sumStats = "not a QtlSumStats" ), - "'sumStats' must be a QtlSumStats object or NULL" + 'invalid object for slot "sumStats"' ) }) diff --git a/tests/testthat/test_QtlDataset.R b/tests/testthat/test_QtlDataset.R index 84400ac24..27990402f 100644 --- a/tests/testthat/test_QtlDataset.R +++ b/tests/testthat/test_QtlDataset.R @@ -15,8 +15,8 @@ context("QtlDataset internal helpers") ) { new( "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", + path = "/tmp/test", + format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), CHR = rep("1", snp_n), @@ -934,8 +934,8 @@ context("QtlDataset residualization methods") .qr_makeHandle <- function(snp_n = 6L, n_samples = 12L) { new( "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", + path = "/tmp/test", + format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), CHR = rep("1", snp_n), @@ -1190,7 +1190,7 @@ test_that("residualizedGenotypes: residualizes only against selected pheno covar G <- residualizedGenotypes( qd, contexts = "brain", - residualizationArgs = ResidualizationParam(phenotypeCovariates = "age") + residualizationParam = ResidualizationParam(phenotypeCovariates = "age") ) expect_equal(nrow(G), 12L) # Resulting columns should be uncorrelated with 'age'. @@ -1211,7 +1211,7 @@ test_that("residualizedGenotypes: respects residualizePhenotype = FALSE", { G1 <- residualizedGenotypes( qd, contexts = "brain", - residualizationArgs = ResidualizationParam( + residualizationParam = ResidualizationParam( residualizePhenotype = FALSE ) ) @@ -1228,14 +1228,14 @@ test_that("residualizedGenotypes: precise-name kwarg routes correctly", { G_precise <- residualizedGenotypes( qd, contexts = "brain", - residualizationArgs = ResidualizationParam( + residualizationParam = ResidualizationParam( residualizePhenotype = FALSE ) ) G_conv <- residualizedGenotypes( qd, contexts = "brain", - residualizationArgs = ResidualizationParam( + residualizationParam = ResidualizationParam( residualizePhenotype = FALSE ) ) @@ -1254,7 +1254,7 @@ test_that("residualizedGenotypes refuses a bare list for the bundle", { residualizedGenotypes( qd, contexts = "brain", - residualizationArgs = list(residualizePhenotype = FALSE) + residualizationParam = list(residualizePhenotype = FALSE) ), "ResidualizationParam" ) @@ -1286,7 +1286,7 @@ test_that("residualizedGenotypes: includes genotype covariates when supplied", { G <- residualizedGenotypes( qd, contexts = "brain", - residualizationArgs = ResidualizationParam( + residualizationParam = ResidualizationParam( genotypeCovariates = c("pc1", "pc2") ) ) @@ -1314,7 +1314,7 @@ test_that("residualizedGenotypes: mean-imputes missing covariates by default", { G <- residualizedGenotypes( qd, contexts = "brain", - residualizationArgs = ResidualizationParam( + residualizationParam = ResidualizationParam( genotypeCovariates = c("pc1", "pc2") ) ) @@ -1338,7 +1338,7 @@ test_that("residualizedGenotypes: covariateNaAction='drop' removes samples with G <- residualizedGenotypes( qd, contexts = "brain", - residualizationArgs = ResidualizationParam( + residualizationParam = ResidualizationParam( genotypeCovariates = c("pc1", "pc2"), covariateNaAction = "drop" ) @@ -1378,7 +1378,7 @@ test_that("residualizedPhenotypes: residualizes against age covariate", { Y <- residualizedPhenotypes( qd, contexts = "brain", - residualizationArgs = ResidualizationParam(phenotypeCovariates = "age") + residualizationParam = ResidualizationParam(phenotypeCovariates = "age") ) age <- seq_len(12) for (j in seq_len(ncol(Y))) { @@ -1391,7 +1391,7 @@ test_that("residualizedPhenotypes: respects residualizePhenotype = FALSE", { Y <- residualizedPhenotypes( qd, contexts = "brain", - residualizationArgs = ResidualizationParam( + residualizationParam = ResidualizationParam( residualizePhenotype = FALSE ) ) @@ -1404,14 +1404,14 @@ test_that("residualizedPhenotypes: precise-name kwarg routes correctly", { Y_precise <- residualizedPhenotypes( qd, contexts = "brain", - residualizationArgs = ResidualizationParam( + residualizationParam = ResidualizationParam( residualizePhenotype = FALSE ) ) Y_conv <- residualizedPhenotypes( qd, contexts = "brain", - residualizationArgs = ResidualizationParam( + residualizationParam = ResidualizationParam( residualizePhenotype = FALSE ) ) @@ -2143,7 +2143,7 @@ test_that("show.QtlDataset lists context names and trait count", { expect_true(any(grepl("QtlDataset for study 'study1'", out))) expect_true(any(grepl("1 context\\(s\\): brain", out))) expect_true(any(grepl("2 unique traits", out))) - expect_true(any(grepl("Genotypes: gds @ /tmp/test.gds", out))) + expect_true(any(grepl("Genotypes: plink2 @ /tmp/test", out))) }) @@ -2168,7 +2168,7 @@ test_that("show.MultiStudyQtlDataset reports sumstats studies when present", { trait = "t1", entry = list(.sh_makeQtlSumstatsGr()), genome = "hg19", - ldSketch = .sh_makeGenotypeHandle() + ldReference = .sh_makeGenotypeHandle() ) mt <- MultiStudyQtlDataset(qtlDatasets = list(s1 = qd), sumStats = ss) out <- capture.output(show(mt)) @@ -2205,9 +2205,9 @@ test_that("show.MultiStudyQtlDataset reports sumstats studies when present", { .mr_vids <- function(qd, region) colnames(genotypes(qd, region = region)) test_that("multi-range region unions disjoint sub-ranges on one chromosome", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") h <- GenotypeHandle( - plink1Prefix = file.path(test_data_dir, "test_variants") + plink2Prefix = file.path(test_data_dir, "test_variants") ) qd <- QtlDataset( studyName = "S", @@ -2234,7 +2234,7 @@ test_that("multi-range region unions disjoint sub-ranges on one chromosome", { }) test_that("multi-range region spans chromosomes on a sharded handle", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") hs <- GenotypeHandle( genoMeta = c( "21" = file.path(test_data_dir, "test_variants"), @@ -2247,7 +2247,7 @@ test_that("multi-range region spans chromosomes on a sharded handle", { phenotypes = list(ctx = .mr_makeSE(sampleIds(hs))) ) bp <- snpInfo(GenotypeHandle( - plink1Prefix = file.path(test_data_dir, "test_variants") + plink2Prefix = file.path(test_data_dir, "test_variants") ))$BP lo <- min(bp) hi <- max(bp) @@ -2271,9 +2271,9 @@ test_that("multi-range region spans chromosomes on a sharded handle", { }) test_that("multi-region: single-range extraction is unchanged (regression)", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") h <- GenotypeHandle( - plink1Prefix = file.path(test_data_dir, "test_variants") + plink2Prefix = file.path(test_data_dir, "test_variants") ) qd <- QtlDataset( studyName = "S", @@ -2286,9 +2286,9 @@ test_that("multi-region: single-range extraction is unchanged (regression)", { }) test_that(".qtlResolveVariantRegion rejects a non-GRanges / empty region", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") h <- GenotypeHandle( - plink1Prefix = file.path(test_data_dir, "test_variants") + plink2Prefix = file.path(test_data_dir, "test_variants") ) qd <- QtlDataset( studyName = "S", @@ -2739,7 +2739,7 @@ test_that("residualizedGenotypes: errors when genotypes and covariates share no residualizedGenotypes( qd, contexts = "brain", - residualizationArgs = ResidualizationParam( + residualizationParam = ResidualizationParam( residualizePhenotype = FALSE, genotypeCovariates = c("pc1", "pc2") ) @@ -2760,7 +2760,7 @@ test_that("residualizedPhenotypes: errors when phenotypes and covariates share n residualizedPhenotypes( qd, contexts = "brain", - residualizationArgs = ResidualizationParam( + residualizationParam = ResidualizationParam( residualizePhenotype = FALSE, genotypeCovariates = c("pc1", "pc2") ) @@ -2803,11 +2803,22 @@ test_that("QtlDataset filter accessors round-trip what was passed in", { test_that("genotypeHandle returns the handle, genotypes a dosage block", { # These are different accessors on purpose: genotypes() extracts # dosages through the filter stack, genotypeHandle() hands back the - # GenotypeHandle the dataset was built on. - data(qtlDatasetExample, envir = environment()) - x <- qtlDatasetExample + # GenotypeHandle the dataset was built on -- none for a panel that reads + # through its own seed, as the example's PLINK1 panel does. + skip_if_not_installed("pgenlibr") + h <- GenotypeHandle( + plink2Prefix = file.path(test_data_dir, "test_variants") + ) + x <- QtlDataset( + studyName = "S", + genotypes = h, + phenotypes = list(ctx = .mr_makeSE(sampleIds(h))) + ) expect_s4_class(genotypeHandle(x), "GenotypeHandle") expect_true(is.matrix(genotypes(x))) + data(qtlDatasetExample, envir = environment()) + expect_null(genotypeHandle(qtlDatasetExample)) + expect_true(is.matrix(genotypes(qtlDatasetExample))) }) @@ -3011,7 +3022,9 @@ test_that("replacing the handle moves the assay's seed with it", { # describing a different panel from the one the accessors read. qd <- .qm_makeDataset() handle <- genotypeHandle(qd) - handle@path <- "pecotmr://extdata/elsewhere" + # A bundled resource that resolves: building the panel looks beside it + # for a sketch's .afreq sidecar. + handle@path <- "pecotmr://extdata/toy_ref" out <- pecotmr:::.qtlWithGenotypeHandle(qd, handle) seedPath <- path(pecotmr:::.ghSeedHandle( DelayedArray::seed(SummarizedExperiment::assay( @@ -3019,8 +3032,8 @@ test_that("replacing the handle moves the assay's seed with it", { "dosage" )) )) - expect_equal(path(genotypeHandle(out)), "pecotmr://extdata/elsewhere") - expect_equal(seedPath, "pecotmr://extdata/elsewhere") + expect_equal(path(genotypeHandle(out)), "pecotmr://extdata/toy_ref") + expect_equal(seedPath, "pecotmr://extdata/toy_ref") }) @@ -3062,10 +3075,10 @@ test_that("longForm(genotype = TRUE) reads the dosages in", { qd <- qtlDatasetExample lf <- MultiAssayExperiment::longForm(qd, genotype = TRUE) expect_true(is_in("genotype", unique(as.character(lf$assay)))) - handle <- genotypeHandle(qd) + geno <- pecotmr:::.qtlGenotypeSe(qd) expect_equal( sum(as.character(lf$assay) == "genotype"), - nrow(snpInfo(handle)) * length(sampleIds(handle)) + nrow(geno) * ncol(geno) ) }) @@ -3347,3 +3360,45 @@ test_that("all three are MethodParams and read like a list", { expect_type(as.list(a), "list") } }) + + +test_that("a stochastic LD sketch is refused as a study's genotypes", { + skip_if_not_installed("pgenlibr") + sketch <- readGenotypes( + test_path("test_data", "test_harmonize_regions.pgen") + ) + expect_error( + pecotmr:::.qtlCheckRealGenotypes(pecotmr:::.ldRefHandle(sketch)), + "is a stochastic LD sketch" + ) + real <- readGenotypes(test_path("test_data", "test_variants.pgen")) + expect_null(pecotmr:::.qtlCheckRealGenotypes(pecotmr:::.ldRefHandle(real))) +}) + +test_that("a QtlDataset reads genotypes held in memory as from a file", { + # The genotype experiment is read through its own rows and assay, not a + # handle, so a panel from any backend -- here one held in memory -- gives + # the same blocks as the file it was read from. + data(qtlDatasetExample, envir = environment()) + disk <- pecotmr:::.qtlGenotypeSe(qtlDatasetExample) + mem <- SummarizedExperiment::SummarizedExperiment( + assays = list( + dosage = as.matrix(SummarizedExperiment::assay(disk, "dosage")) + ), + rowRanges = SummarizedExperiment::rowRanges(disk), + colData = SummarizedExperiment::colData(disk) + ) + qd <- QtlDataset( + studyName = studyName(qtlDatasetExample), + genotypes = mem, + phenotypes = pecotmr:::.qtlPhenotypeList(qtlDatasetExample) + ) + expect_null(genotypeHandle(qd)) + region <- SummarizedExperiment::rowRanges(disk)[1:30] + expect_equal( + genotypes(qd, region = region), + genotypes(qtlDatasetExample, region = region) + ) + out <- capture.output(show(qd)) + expect_true(any(grepl("held in memory", out))) +}) diff --git a/tests/testthat/test_QtlFineMappingResult.R b/tests/testthat/test_QtlFineMappingResult.R index 5d02e5219..ba5b46256 100644 --- a/tests/testthat/test_QtlFineMappingResult.R +++ b/tests/testthat/test_QtlFineMappingResult.R @@ -14,7 +14,7 @@ test_that("QtlFineMappingResult: builds a collection keyed by 4-tuple", { ) expect_s4_class(res, "QtlFineMappingResult") expect_equal(nrow(res), 2L) - expect_null(ldSketch(res)) + expect_null(ldReference(res)) }) @@ -31,7 +31,7 @@ test_that("QtlFineMappingResult: validity does not recurse on key subset (#546)" trait = "t", method = "qsusie", entry = list(e), - ldSketch = NULL + ldReference = NULL ) expect_s4_class(res, "QtlFineMappingResult") expect_true(validObject(res)) @@ -55,11 +55,11 @@ test_that("QtlFineMappingResult: stores an LD sketch when supplied", { trait = "t1", method = "susie", entry = list(e), - ldSketch = gh + ldReference = gh ) # The slot holds the panel; the handle it reads through is its seed. - expect_s4_class(ldSketch(res), "RangedSummarizedExperiment") - expect_identical(pecotmr:::.ldSketchHandle(ldSketch(res)), gh) + expect_s4_class(ldReference(res), "RangedSummarizedExperiment") + expect_identical(pecotmr:::.ldRefHandle(ldReference(res)), gh) }) @@ -287,21 +287,21 @@ test_that("show.QtlFineMappingResult prints entry/study/context/trait/method cou out <- capture.output(show(res)) expect_true(any(grepl("QtlFineMappingResult: 2 entries", out))) expect_true(any(grepl("1 studies.*2 contexts.*1 traits.*2 methods", out))) - expect_true(any(grepl("LD sketch: NULL", out))) + expect_true(any(grepl("LD reference: NULL", out))) }) -test_that("show.QtlFineMappingResult reports the ldSketch source when present", { +test_that("show.QtlFineMappingResult reports the ldReference source", { res <- QtlFineMappingResult( studyName = "s1", context = "c1", trait = "t1", method = "susie", entry = list(.sh_makeFmEntry()), - ldSketch = .sh_makeGenotypeHandle() + ldReference = .sh_makeGenotypeHandle() ) out <- capture.output(show(res)) - expect_true(any(grepl("LD sketch: gds @ /tmp/test.gds", out))) + expect_true(any(grepl("LD reference: plink2 @ /tmp/test", out))) }) diff --git a/tests/testthat/test_RangedTupleList.R b/tests/testthat/test_RangedTupleList.R index e687c5fe1..7b4547019 100644 --- a/tests/testthat/test_RangedTupleList.R +++ b/tests/testthat/test_RangedTupleList.R @@ -7,7 +7,7 @@ setClass( "RtlTestKid", contains = "RangedTupleList", - representation(genome = "character", ldSketch = "ANY", qcInfo = "list") + representation(genome = "character", ldReference = "ANY", qcInfo = "list") ) .rtl_mk <- function(chr, pos, strand = "*") { @@ -27,7 +27,7 @@ setClass( c = .rtl_mk("chr2", c(50, 60)) ), genome = "hg38", - ldSketch = "SKETCH", + ldReference = "SKETCH", qcInfo = list(step1 = "ok") ) S4Vectors::mcols(x) <- S4Vectors::DataFrame( @@ -56,7 +56,7 @@ test_that("ncol is zero when the collection has no mcols", { "RtlTestKid", GenomicRanges::GRangesList(a = .rtl_mk("chr1", 1:2)), genome = "hg38", - ldSketch = NULL, + ldReference = NULL, qcInfo = list() ) expect_equal(ncol(bare), 0L) @@ -87,7 +87,7 @@ test_that("$<- works on a collection that had no mcols at all", { "RtlTestKid", GenomicRanges::GRangesList(a = .rtl_mk("chr1", 1:2)), genome = "hg38", - ldSketch = NULL, + ldReference = NULL, qcInfo = list() ) bare$study <- "s1" @@ -105,7 +105,7 @@ test_that("[ selects elements and preserves class, slots and mcols", { expect_s4_class(y, "RtlTestKid") expect_equal(length(y), 2L) expect_equal(y@genome, "hg38") - expect_equal(y@ldSketch, "SKETCH") + expect_equal(y@ldReference, "SKETCH") expect_equal(y$study, c("s1", "s3")) expect_equal(names(y), c("a", "c")) }) @@ -132,7 +132,7 @@ test_that("validity rejects an element spanning two seqnames", { "RtlTestKid", GenomicRanges::GRangesList(a = .rtl_mk(c("chr1", "chr2"), c(1, 2))), genome = "hg38", - ldSketch = NULL, + ldReference = NULL, qcInfo = list() ), "span more than one" @@ -149,7 +149,7 @@ test_that("validity rejects an element spanning two strands", { a = .rtl_mk("chr1", c(1, 2), strand = c("+", "-")) ), genome = "hg38", - ldSketch = NULL, + ldReference = NULL, qcInfo = list() ), "span more than one" @@ -163,7 +163,7 @@ test_that("validity accepts a stranded element as long as it is consistent", { a = .rtl_mk("chr1", c(1, 2), strand = "+") ), genome = "hg38", - ldSketch = NULL, + ldReference = NULL, qcInfo = list() ) expect_equal(length(x), 1L) @@ -175,7 +175,7 @@ test_that("an empty collection is valid", { "RtlTestKid", GenomicRanges::GRangesList(), genome = "hg38", - ldSketch = NULL, + ldReference = NULL, qcInfo = list() ) expect_equal(length(empty), 0L) @@ -193,7 +193,7 @@ test_that(".rtlRebuild carries every subclass slot across a rebuild", { x <- .rtl_makeKid() expect_setequal( pecotmr:::.rtlOwnSlots(x), - c("genome", "ldSketch", "qcInfo") + c("genome", "ldReference", "qcInfo") ) out <- pecotmr:::.rtlRebuild( x, @@ -202,7 +202,7 @@ test_that(".rtlRebuild carries every subclass slot across a rebuild", { ) expect_s4_class(out, "RtlTestKid") expect_equal(out@genome, "hg38") - expect_equal(out@ldSketch, "SKETCH") + expect_equal(out@ldReference, "SKETCH") expect_equal(out@qcInfo, list(step1 = "ok")) expect_equal(out$study, c("s1", "s3")) expect_equal(unname(lengths(out)), c(1L, 1L)) @@ -212,7 +212,7 @@ test_that("endoapply rebuilds without losing slots", { x <- .rtl_makeKid() out <- endoapply(x, head, 1L) expect_equal(unname(lengths(out)), c(1L, 1L, 1L)) - expect_equal(out@ldSketch, "SKETCH") + expect_equal(out@ldReference, "SKETCH") expect_equal(out$study, c("s1", "s2", "s3")) }) @@ -419,7 +419,7 @@ test_that("[[<- replaces an element and keeps class, slots and mcols", { expect_equal(S4Vectors::mcols(x), before) # The collection-level slots are exactly what the setAs route would drop. expect_equal(x@genome, "hg38") - expect_equal(x@ldSketch, "SKETCH") + expect_equal(x@ldReference, "SKETCH") expect_equal(x@qcInfo, list(step1 = "ok")) }) @@ -640,7 +640,7 @@ test_that("nestTupleRanges round-trips an unmodified flatten", { expect_equal(mcols(back), mcols(mc)) # Collection-level slots survive, which is the point of nesting through a # template rather than rebuilding from the ranges alone. - expect_identical(ldSketch(back), ldSketch(mc)) + expect_identical(ldReference(back), ldReference(mc)) expect_identical( unname(GenomeInfoDb::genome(back)), unname(GenomeInfoDb::genome(mc)) @@ -718,7 +718,7 @@ test_that("filter keeps the collection and narrows its elements", { expect_s4_class(out, "QtlSumStats") expect_equal(nrow(out), nrow(mc)) expect_lt(sum(lengths(out)), sum(lengths(mc))) - expect_identical(ldSketch(out), ldSketch(mc)) + expect_identical(ldReference(out), ldReference(mc)) }) test_that("filter can mix identity and per-range columns", { @@ -840,7 +840,7 @@ test_that("seqinfo is left alone when the source carries none", { "RtlTestKid", GenomicRanges::GRangesList(), genome = "hg38", - ldSketch = NULL, + ldReference = NULL, qcInfo = list() ) grl <- GenomicRanges::GRangesList( diff --git a/tests/testthat/test_causalInferencePipeline.R b/tests/testthat/test_causalInferencePipeline.R index 65d738c83..ca4767e81 100644 --- a/tests/testthat/test_causalInferencePipeline.R +++ b/tests/testthat/test_causalInferencePipeline.R @@ -1,7 +1,7 @@ context("causalInferencePipeline") # =========================================================================== -# Strategy: mock extractBlockGenotypes so .ldFromSketch returns a real +# Strategy: mock extractBlockGenotypes so .ldFromRef returns a real # LD matrix on a small panel. Everything else (twasZ, MR, p-value combine) # runs for real on the tiny fixture. # =========================================================================== @@ -9,8 +9,8 @@ context("causalInferencePipeline") .cip_makeHandle <- function(snp_n = 6L, n_samples = 30L, sample_prefix = "s") { new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), @@ -82,7 +82,7 @@ context("causalInferencePipeline") studyName = "G1", entry = list(gr), genome = "hg19", - ldSketch = .cip_makeHandle(), + ldReference = .cip_makeHandle(), qcInfo = if (qc) list(step1 = "ok") else list() ) } @@ -101,7 +101,7 @@ context("causalInferencePipeline") trait = "t1", method = method, entry = list(entry), - ldSketch = .cip_makeHandle() + ldReference = .cip_makeHandle() ) } @@ -130,7 +130,7 @@ context("causalInferencePipeline") trait = "t1", method = "susie", entry = list(e), - ldSketch = .cip_makeHandle() + ldReference = .cip_makeHandle() ) } @@ -197,11 +197,11 @@ test_that("causalInferencePipeline: rejects GwasFineMappingResult for the QTL sl }) # =========================================================================== -# .cipRequireMatchingLdSketches branches +# .cipRequireMatchingLdRefs branches # =========================================================================== -test_that(".cipRequireMatchingLdSketches: NULL twas-side ldSketch is allowed", { - # Build a TwasWeights without an ldSketch. +test_that(".cipRequireMatchingLdRefs: NULL twas-side ldReference is allowed", { + # Build a TwasWeights without an ldReference. twNoLd <- TwasWeights( studyName = "Q1", context = "c1", @@ -211,7 +211,7 @@ test_that(".cipRequireMatchingLdSketches: NULL twas-side ldSketch is allowed", { variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), weights = rep(0.1, 5) )), - ldSketch = NULL + ldReference = NULL ) local_mocked_bindings( extractBlockGenotypes = .cip_mockExtractor(), @@ -224,7 +224,7 @@ test_that(".cipRequireMatchingLdSketches: NULL twas-side ldSketch is allowed", { expect_s4_class(out, "GRanges") }) -test_that(".cipRequireMatchingLdSketches: sample set mismatch errors", { +test_that(".cipRequireMatchingLdRefs: sample set mismatch errors", { otherPanel <- .cip_makeHandle(sample_prefix = "other") twOther <- TwasWeights( studyName = "Q1", @@ -235,7 +235,7 @@ test_that(".cipRequireMatchingLdSketches: sample set mismatch errors", { variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), weights = rep(0.1, 5) )), - ldSketch = otherPanel + ldReference = otherPanel ) expect_error( causalInferencePipeline( @@ -246,12 +246,12 @@ test_that(".cipRequireMatchingLdSketches: sample set mismatch errors", { ) }) -test_that(".cipRequireMatchingLdSketches: differently trimmed panels pass", { +test_that(".cipRequireMatchingLdRefs: differently trimmed panels pass", { # Independent QC of the QTL and GWAS sides leaves one LD reference as two # overlapping-but-unequal panels, which the check reports rather than # refuses. expect_warning( - expect_null(pecotmr:::.cipRequireMatchingLdSketches( + expect_null(pecotmr:::.cipRequireMatchingLdRefs( .cip_makeHandle(snp_n = 6L), .cip_makeHandle(snp_n = 7L), label = "twasWeights" @@ -287,7 +287,7 @@ test_that("causalInferencePipeline: returns GRanges with TWAS Z per tuple", { }) # =========================================================================== -# Happy path: TwasWeights + matching FineMappingResult enables MR +# Happy path: TwasWeights + matching QtlFineMappingResult enables MR # =========================================================================== test_that("causalInferencePipeline: with both inputs, MR fields are populated", { @@ -301,7 +301,7 @@ test_that("causalInferencePipeline: with both inputs, MR fields are populated", gwasSumStats = .cip_makeGwasSumstats(), twasWeights = tw, fineMappingResult = fmr, - mrArgs = MrParam(pipCutoff = 0.5) + mrParam = MrParam(pipCutoff = 0.5) ) mc <- S4Vectors::mcols(out) # MR uses PIP > 0.5 variants from the FMR (v1, v3, v4). @@ -311,7 +311,7 @@ test_that("causalInferencePipeline: with both inputs, MR fields are populated", }) # =========================================================================== -# FineMappingResult-only path: weights come from topLoci$betahat +# Fine-mapping-only path: weights come from topLoci$betahat # =========================================================================== test_that("causalInferencePipeline: FMR-only path extracts weights from topLoci$betahat", { @@ -348,7 +348,7 @@ test_that("causalInferencePipeline: combineMethods appends combined rows", { weights = rep(0.05, 5) ) ), - ldSketch = .cip_makeHandle() + ldReference = .cip_makeHandle() ) local_mocked_bindings( extractBlockGenotypes = .cip_mockExtractor(), @@ -505,7 +505,7 @@ test_that("causalInferencePipeline: rsqCutoff selects the max-rsq method per gro cvResult = list(metrics = c(rsq = 0.5, pval = 0.001)) ) ), - ldSketch = .cip_makeHandle() + ldReference = .cip_makeHandle() ) local_mocked_bindings( extractBlockGenotypes = .cip_mockExtractor(), @@ -514,7 +514,7 @@ test_that("causalInferencePipeline: rsqCutoff selects the max-rsq method per gro out <- causalInferencePipeline( gwasSumStats = .cip_makeGwasSumstats(), twasWeights = tw, - weightSelectionArgs = WeightSelectionParam(cutoff = 0.1) + weightSelectionParam = WeightSelectionParam(cutoff = 0.1) ) expect_equal(as.character(S4Vectors::mcols(out)$method), "lasso") }) @@ -538,7 +538,7 @@ test_that("causalInferencePipeline: NA/Inf TWAS-Z triggers method re-selection", cvResult = list(metrics = c(rsq = 0.5, pval = 0.001)) ) ), - ldSketch = .cip_makeHandle() + ldReference = .cip_makeHandle() ) local_mocked_bindings( extractBlockGenotypes = .cip_mockExtractor(), @@ -547,7 +547,7 @@ test_that("causalInferencePipeline: NA/Inf TWAS-Z triggers method re-selection", out <- causalInferencePipeline( gwasSumStats = .cip_makeGwasSumstats(), twasWeights = tw, - weightSelectionArgs = WeightSelectionParam(cutoff = 0.1) + weightSelectionParam = WeightSelectionParam(cutoff = 0.1) ) expect_equal(as.character(S4Vectors::mcols(out)$method), "lasso") expect_true(is.finite(S4Vectors::mcols(out)$twasZ)) @@ -571,7 +571,7 @@ test_that("causalInferencePipeline: rsqPvalCutoff gates out high-CV-pval methods cvResult = list(metrics = c(rsq = 0.5, pval = 0.001)) ) ), - ldSketch = .cip_makeHandle() + ldReference = .cip_makeHandle() ) local_mocked_bindings( extractBlockGenotypes = .cip_mockExtractor(), @@ -580,7 +580,7 @@ test_that("causalInferencePipeline: rsqPvalCutoff gates out high-CV-pval methods out <- causalInferencePipeline( gwasSumStats = .cip_makeGwasSumstats(), twasWeights = tw, - weightSelectionArgs = WeightSelectionParam( + weightSelectionParam = WeightSelectionParam( cutoff = 0.1, pvalCutoff = 0.05 ) @@ -712,14 +712,14 @@ test_that("twasZ: R path positional alignment errors on dim mismatch", { # twasZ: X path (computes R via computeLd) # =========================================================================== -test_that("twasZ: X path computes R via computeLd and matches that R explicitly", { +test_that("twasZ: X path matches R from computeLd without forming it", { d <- .tz_makeLd() set.seed(2) w <- rnorm(d$p) names(w) <- d$vid z <- rnorm(d$p) - # The X path delegates to computeLd(X, method = "sample"), which uses - # cor(X). Compare against the same correlation matrix passed explicitly. + # The X path computes W'RW from X's standardized dosages, R being + # computeLd(X)'s cor(X). Compare against that matrix passed explicitly. R_from_X <- cor(d$X) rownames(R_from_X) <- colnames(R_from_X) <- d$vid res_X <- pecotmr:::twasZ(w, z, X = d$X) @@ -727,6 +727,36 @@ test_that("twasZ: X path computes R via computeLd and matches that R explicitly" expect_equal(res_X$Z, res_Rfx$Z, tolerance = 1e-10) }) +test_that("twasZ: X path uses computeLd's LD for missing, constant columns", { + d <- .tz_makeLd() + X <- d$X + X[, 3] <- 1L + X[c(4, 9), 5] <- NA + set.seed(4) + w <- setNames(rnorm(d$p), d$vid) + z <- rnorm(d$p) + expect_equal( + pecotmr:::twasZ(w, z, X = X)$Z, + pecotmr:::twasZ(w, z, R = computeLd(X))$Z + ) +}) + +test_that("twasZ: X path aligns columns to the weights by name", { + d <- .tz_makeLd() + set.seed(5) + w <- setNames(rnorm(d$p), d$vid) + z <- rnorm(d$p) + shuffled <- d$X[, rev(seq_len(d$p))] + expect_equal( + pecotmr:::twasZ(w, z, X = shuffled)$Z, + pecotmr:::twasZ(w, z, X = d$X)$Z + ) + expect_error( + pecotmr:::twasZ(w, z, X = d$X[, -1]), + "X is missing columns for 1 variant" + ) +}) + # =========================================================================== # twasZ: SVD path coverage (V-row missing error) # =========================================================================== @@ -1029,7 +1059,6 @@ test_that("twasZ: matrix weights produce one Z row per column", { test_that("twasZ: combineMethods returns combined p-value summary", { - skip_if_not_installed("ACAT") set.seed(11) p <- 4 k <- 2 @@ -1042,7 +1071,7 @@ test_that("twasZ: combineMethods returns combined p-value summary", { z <- rnorm(p) R <- diag(p) rownames(R) <- colnames(R) <- paste0("SNP", seq_len(p)) - result <- twasZ(weights, z, R = R, combineMethods = "ACAT") + result <- twasZ(weights, z, R = R, combineMethods = "acat") expect_false(is.null(result$combined)) }) @@ -1163,8 +1192,6 @@ test_that("twasZ: error when weights and z have different lengths", { ) }) -# Phase 2: LD-sketch loading and standardize_genotype_hwe() - # =========================================================================== # Direct unit tests for the MR / metric helpers (mock topLoci to feed # controlled topLoci frames; gwasDf is a plain data.frame as produced by @@ -1369,6 +1396,22 @@ test_that(".cipComputeMrCsAware matches across a chr-prefix difference", { expect_true(is.finite(res$waldRatio)) }) +test_that(".cipComputeTwasZ gives a Z from a panel's factor or an LdMatrix", { + data(gwasSumStatsS4Example) + panel <- ldReference(gwasSumStatsS4Example) + ids <- names(SummarizedExperiment::rowRanges(panel))[c(3, 8, 15, 21, 30)] + ld <- LdMatrix( + unname(computeLd(panel)), + variants = SummarizedExperiment::rowRanges(panel) + ) + g <- .cip_gwasDf(ids, z = c(2, -1.5, 0.8, 1.1, -0.3)) + w <- c(0.2, -0.1, 0.3, 0.05, -0.2) + viaPanel <- pecotmr:::.cipComputeTwasZ(w, ids, g, panel) + viaMatrix <- pecotmr:::.cipComputeTwasZ(w, ids, g, ld) + expect_true(is.finite(viaPanel$Z)) + expect_equal(viaPanel, viaMatrix) +}) + test_that(".cipComputeTwasZ reconciles a chr-prefix mismatch (previously dropped)", { idsGwas <- c("1:100:A:G", "1:200:A:G", "1:300:A:G") # GWAS / panel coding idsWt <- c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") # QTL weight ids @@ -1465,9 +1508,11 @@ test_that(".cipComputeMrCsAware: CS-aware composite Wald + heterogeneity", { }) test_that(".cipComputeMrCsAware: credible-set column found via the ^cs fallback", { + # The shape a stored result has: no bare `cs`, and cs_95 holding + # "_" labels rather than integers. tl <- data.frame( variant_id = sprintf("chr1:%d:A:G", 100L * (1:2)), - cs_0.95 = c(1L, 1L), + cs_95 = c("susie_1", "susie_1"), pip = c(0.5, 0.4), beta = c(0.3, 0.2), se = rep(0.05, 2), @@ -1482,7 +1527,31 @@ test_that(".cipComputeMrCsAware: credible-set column found via the ^cs fallback" .cip_gwasDf(sprintf("chr1:%d:A:G", 100L * (1:2)), c(2, -1.5)), cpipCutoff = 0.5 ) - expect_true(is.finite(res$waldRatio)) # cs_0.95 via grep("^cs") + expect_true(is.finite(res$waldRatio)) + expect_equal(res$nCs, 1L) +}) + +test_that(".cipComputeMrCsAware runs on a stored fine-mapping result", { + # The labels used to be read with as.integer(), which turned every one + # into NA: csAware returned an all-NA result on any real result, and the + # tests above missed it because they all build the table by hand. + data(qtlFineMappingExample) + tl <- pecotmr:::.cipTopLociTable(qtlFineMappingExample) + gwas <- data.frame( + variant_id = tl$variant_id, + z = seq(2, 4, length.out = nrow(tl)), + N = 50000, + maf = pmin(pmax(tl$af, 0.05), 0.5) + ) + res <- pecotmr:::.cipComputeMrCsAware( + qtlFineMappingExample, + gwas, + cpipCutoff = 0.5 + ) + # 15 variants: 14 in the one credible set, 1 labelled susie_0. + expect_equal(res$nCs, 1L) + expect_equal(res$nIV, 14L) + expect_true(is.finite(res$waldRatio)) }) test_that("the MR paths abort naming the exposure columns they lack", { @@ -1605,45 +1674,57 @@ test_that(".cipExtractWeights: NULL on missing tuples and bad topLoci", { .fmrRowTopLoci = function(parts, ...) data.frame(), .package = "pecotmr" ) - expect_null(pecotmr:::.cipExtractWeights( - NULL, - fmr, - "Q1", - "c1", - "t1", - "susie", - useFmr = TRUE - )) + expect_warning( + out <- pecotmr:::.cipExtractWeights( + NULL, + fmr, + "Q1", + "c1", + "t1", + "susie", + useFmr = TRUE + ), + "no weights resolved" + ) + expect_null(out) local_mocked_bindings( .fmrRowTopLoci = function(parts, ...) { data.frame(variant_id = "chr1:100:A:G") }, .package = "pecotmr" ) - expect_null(pecotmr:::.cipExtractWeights( - NULL, - fmr, - "Q1", - "c1", - "t1", - "susie", - useFmr = TRUE - )) + expect_warning( + out <- pecotmr:::.cipExtractWeights( + NULL, + fmr, + "Q1", + "c1", + "t1", + "susie", + useFmr = TRUE + ), + "no weights resolved" + ) + expect_null(out) local_mocked_bindings( .fmrRowTopLoci = function(parts, ...) { data.frame(variant_id = NA_character_, beta = NA_real_) }, .package = "pecotmr" ) - expect_null(pecotmr:::.cipExtractWeights( - NULL, - fmr, - "Q1", - "c1", - "t1", - "susie", - useFmr = TRUE - )) + expect_warning( + out <- pecotmr:::.cipExtractWeights( + NULL, + fmr, + "Q1", + "c1", + "t1", + "susie", + useFmr = TRUE + ), + "no weights resolved" + ) + expect_null(out) }) test_that(".cipCombineAcrossMethods: a single-method group yields no combined rows", { @@ -1875,7 +1956,7 @@ test_that(".cipCvSelection errors when no method clears the CV cutoffs", { pecotmr:::.cipCvSelection( qtlRows = data.frame(a = 1), twasWeights = "notNull", - weightSelectionArgs = WeightSelectionParam( + weightSelectionParam = WeightSelectionParam( cutoff = 0.5, pvalCutoff = 0.05 ) @@ -1887,7 +1968,7 @@ test_that(".cipCvSelection errors when no method clears the CV cutoffs", { test_that(".cipRun errors when no tuple produced a result", { local_mocked_bindings( .cipValidateInputs = function(...) invisible(NULL), - .cipCheckLdSketches = function(...) NULL, + .cipCheckLdRefs = function(...) NULL, .cipResolveWorkList = function(...) data.frame(x = 1), .cipCvSelection = function(...) { list( @@ -1905,9 +1986,9 @@ test_that(".cipRun errors when no tuple produced a result", { twasWeights = NULL, fineMappingResult = NULL, combineMethods = NULL, - weightSelectionArgs = WeightSelectionParam(), + weightSelectionParam = WeightSelectionParam(), alleleFlip = FALSE, - mrArgs = MrParam(method = "csAware", cpipCutoff = 0) + mrParam = MrParam(method = "csAware", cpipCutoff = 0) ), "no \\(qtl, gwas\\) tuples produced a result" ) @@ -1950,7 +2031,7 @@ test_that(".cipScoreGwasPair skips a pair with no TWAS z", { gwasSumStats = list(study = "G1"), gwasLd = NULL, alleleFlip = FALSE, - mrArgs = MrParam( + mrParam = MrParam( method = "csAware", cpipCutoff = 0, pvalCutoff = 1 @@ -1969,7 +2050,7 @@ test_that(".cipRunMr routes to the CS-aware estimator when asked", { gdf = NULL, twasOut = list(pval = 0.001), alleleFlip = FALSE, - mrArgs = MrParam(method = "csAware", cpipCutoff = 0.5, pvalCutoff = 1) + mrParam = MrParam(method = "csAware", cpipCutoff = 0.5, pvalCutoff = 1) ) expect_true(isTRUE(out$SENTINEL)) }) diff --git a/tests/testthat/test_colocPipeline.R b/tests/testthat/test_colocPipeline.R index 361e76ad5..9ebfc83ac 100644 --- a/tests/testthat/test_colocPipeline.R +++ b/tests/testthat/test_colocPipeline.R @@ -10,8 +10,8 @@ context("colocPipeline") .cp_makeHandle <- function(snp_n = 6L, n_samples = 30L, sample_prefix = "s") { new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), @@ -89,7 +89,7 @@ context("colocPipeline") trait = map_chr(tuples, 3L), method = map_chr(tuples, 4L), entry = entries, - ldSketch = if (with_sketch) .cp_makeHandle() else NULL + ldReference = if (with_sketch) .cp_makeHandle() else NULL ) } @@ -109,7 +109,7 @@ context("colocPipeline") studyName = map_chr(tuples, 1L), method = map_chr(tuples, 2L), entry = entries, - ldSketch = if (with_sketch) .cp_makeHandle() else NULL + ldReference = if (with_sketch) .cp_makeHandle() else NULL ) } @@ -132,7 +132,7 @@ context("colocPipeline") studyName = studyName, entry = list(gr), genome = "hg19", - ldSketch = .cp_makeHandle(), + ldReference = .cp_makeHandle(), qcInfo = if (qc) list(step1 = "ok") else list() ) } @@ -158,7 +158,7 @@ context("colocPipeline") trait = "t1", entry = list(gr), genome = "hg19", - ldSketch = .cp_makeHandle(), + ldReference = .cp_makeHandle(), qcInfo = if (qc) list(step1 = "ok") else list() ) } @@ -222,10 +222,10 @@ test_that("colocPipeline: rejects un-QCd GwasSumStats input", { }) # =========================================================================== -# .colocRequireMatchingLdSketches +# .colocRequireMatchingLdRefs # =========================================================================== -test_that(".colocRequireMatchingLdSketches: NULL qtl-side ldSketch is allowed", { +test_that(".colocRequireMatchingLdRefs: NULL qtl-side ldReference is allowed", { qfmr <- .cp_makeQtlFmr(with_sketch = FALSE) gfmr <- .cp_makeGwasFmr() local_mocked_bindings(coloc.bf_bf = .cp_mockColocBfBf(), .package = "coloc") @@ -236,23 +236,23 @@ test_that(".colocRequireMatchingLdSketches: NULL qtl-side ldSketch is allowed", expect_s4_class(out, "ColocResult") }) -test_that(".colocRequireMatchingLdSketches: non-NULL qtl + NULL gwas errors", { +test_that(".colocRequireMatchingLdRefs: non-NULL qtl + NULL gwas errors", { qfmr <- .cp_makeQtlFmr() gfmr <- .cp_makeGwasFmr(with_sketch = FALSE) expect_error( colocPipeline(qtlFineMappingResult = qfmr, gwasInput = gfmr), - "ldSketch is NULL" + "ldReference is NULL" ) }) -test_that(".colocRequireMatchingLdSketches: sample set mismatch errors", { +test_that(".colocRequireMatchingLdRefs: sample set mismatch errors", { qfmr <- .cp_makeQtlFmr() otherPanel <- .cp_makeHandle(sample_prefix = "other") gfmr <- GwasFineMappingResult( studyName = "G1", method = "susie", entry = list(.cp_makeFmEntry()), - ldSketch = otherPanel + ldReference = otherPanel ) expect_error( colocPipeline(qtlFineMappingResult = qfmr, gwasInput = gfmr), @@ -260,11 +260,11 @@ test_that(".colocRequireMatchingLdSketches: sample set mismatch errors", { ) }) -test_that(".colocRequireMatchingLdSketches: differently trimmed panels pass", { +test_that(".colocRequireMatchingLdRefs: differently trimmed panels pass", { # The two sides QC'd separately keep different subsets of one LD # reference; the panels overlap, so the check warns rather than aborting. expect_warning( - expect_null(pecotmr:::.colocRequireMatchingLdSketches( + expect_null(pecotmr:::.colocRequireMatchingLdRefs( .cp_makeHandle(snp_n = 6L), .cp_makeHandle(snp_n = 7L) )), @@ -473,7 +473,7 @@ test_that("colocPipeline: empty result has the documented schema", { studyName = "G1", method = "susie", entry = list(e), - ldSketch = .cp_makeHandle() + ldReference = .cp_makeHandle() ) out <- suppressWarnings( colocPipeline(qtlFineMappingResult = qfmr, gwasInput = gfmr) @@ -563,7 +563,7 @@ test_that(".colocExtractLbfFromEntry: filterLbfCs subsets by cs_index", { ) out <- pecotmr:::.colocExtractLbfFromEntry( e, - lbfFilterArgs = ColocLbfFilterParam( + colocLbfFilterParam = ColocLbfFilterParam( filterLbfCs = TRUE, secondary = NULL ) @@ -927,7 +927,7 @@ test_that("colocPipeline: attaches gwasFineMapping when no pairs survive", { studyName = "G1", method = "susie", entry = list(e), - ldSketch = .cp_makeHandle() + ldReference = .cp_makeHandle() ) local_mocked_bindings(coloc.bf_bf = .cp_mockColocBfBf(), .package = "coloc") local_mocked_bindings( @@ -1050,7 +1050,7 @@ test_that(".colocExtractLbfFromEntry: stacks fSuSiE lBF list into a matrix", { ) out <- pecotmr:::.colocExtractLbfFromEntry( e, - lbfFilterArgs = ColocLbfFilterParam( + colocLbfFilterParam = ColocLbfFilterParam( filterLbfCs = FALSE, secondary = NULL, concentration = 0.5 @@ -1075,7 +1075,7 @@ test_that(".colocExtractLbfFromEntry: stacks nested fSuSiE lBF (fit[[1]] path)", ) out <- pecotmr:::.colocExtractLbfFromEntry( e, - lbfFilterArgs = ColocLbfFilterParam( + colocLbfFilterParam = ColocLbfFilterParam( filterLbfCs = FALSE, secondary = NULL, concentration = 0.5 @@ -1094,7 +1094,7 @@ test_that(".colocExtractLbfFromEntry: refuses a fit carrying no LBF slot", { expect_error( pecotmr:::.colocExtractLbfFromEntry( e, - lbfFilterArgs = ColocLbfFilterParam( + colocLbfFilterParam = ColocLbfFilterParam( filterLbfCs = FALSE, secondary = NULL, concentration = 0.5 @@ -1134,7 +1134,7 @@ test_that(".colocExtractLbfFromEntry: refuses an empty LBF matrix", { expect_error( pecotmr:::.colocExtractLbfFromEntry( e, - lbfFilterArgs = ColocLbfFilterParam( + colocLbfFilterParam = ColocLbfFilterParam( filterLbfCs = FALSE, secondary = NULL, concentration = 0.5 @@ -1167,7 +1167,7 @@ test_that(".colocExtractLbfFromEntry: secondary CS filter subsets rows", { ) out <- pecotmr:::.colocExtractLbfFromEntry( e, - lbfFilterArgs = ColocLbfFilterParam( + colocLbfFilterParam = ColocLbfFilterParam( filterLbfCs = FALSE, secondary = 0.95, concentration = 0.5 @@ -1186,7 +1186,7 @@ test_that(".colocExtractLbfFromEntry: assigns colnames from variantIds when fit ) out <- pecotmr:::.colocExtractLbfFromEntry( e, - lbfFilterArgs = ColocLbfFilterParam( + colocLbfFilterParam = ColocLbfFilterParam( filterLbfCs = FALSE, secondary = NULL, concentration = 0.5 @@ -1213,7 +1213,7 @@ test_that(".colocExtractLbfFromEntry: NULL when every variant column is NA-named ) out <- pecotmr:::.colocExtractLbfFromEntry( e, - lbfFilterArgs = ColocLbfFilterParam( + colocLbfFilterParam = ColocLbfFilterParam( filterLbfCs = FALSE, secondary = NULL, concentration = 0.5 @@ -1335,7 +1335,7 @@ test_that("gwasFineMapping is refused when the GWAS is already fine-mapped", { colocPipeline( qtlFineMappingExample, gwasFineMappingExample, - gwasFineMappingArgs = GwasFineMappingParam(methods = "susieInf") + gwasFineMappingParam = GwasFineMappingParam(methods = "susieInf") ), "there is no run to configure" ) diff --git a/tests/testthat/test_colocboostPipeline.R b/tests/testthat/test_colocboostPipeline.R index e467dddbd..83b930492 100644 --- a/tests/testthat/test_colocboostPipeline.R +++ b/tests/testthat/test_colocboostPipeline.R @@ -38,7 +38,7 @@ context("colocboostPipeline") # setMethod("colocboostPipeline", "MultiStudyQtlDataset", ...) # # - QTL data is supplied as a QtlDataset / QtlSumStats / MultiStudyQtlDataset -# (DFrame-based S4 objects with an ldSketch slot for sumstats inputs and +# (DFrame-based S4 objects with an ldReference slot for sumstats inputs and # residualizedGenotypes() / residualizedPhenotypes() accessors for # individual-level inputs). # - GWAS is supplied separately via the gwasSumStats = GwasSumStats(...) @@ -86,14 +86,14 @@ context("colocboostPipeline (S4 dispatch)") # colocboost::colocboost is the heavy compute; we mock it to return a stub # result so the pipeline orchestration runs end-to-end. The helpers # (.cbBuildLdArgs, .cbMergeSumstatBundles, -# .cbRequireMatchingLdSketches, .cbEmptyResult) are exercised directly. +# .cbRequireMatchingLdRefs, .cbEmptyResult) are exercised directly. # =========================================================================== .cbp_makeHandle <- function(snp_n = 6L, n_samples = 30L, sample_prefix = "s") { new( "GenotypeHandle", - path = "/tmp/cb.gds", - format = "gds", + path = "/tmp/cb", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), @@ -211,7 +211,7 @@ context("colocboostPipeline (S4 dispatch)") trait = "t1", entry = list(gr), genome = "hg19", - ldSketch = .cbp_makeHandle(), + ldReference = .cbp_makeHandle(), qcInfo = if (qc) list(step1 = "ok") else list() ) } @@ -235,7 +235,7 @@ context("colocboostPipeline (S4 dispatch)") studyName = "G1", entry = list(gr), genome = "hg19", - ldSketch = .cbp_makeHandle(), + ldReference = .cbp_makeHandle(), qcInfo = if (qc) list(step1 = "ok") else list() ) } @@ -252,10 +252,13 @@ test_that(".cbBuildLdArgs: square matrices route to LD", { expect_false("X_ref" %in% names(res)) }) -test_that(".cbBuildLdArgs: non-square matrices route to X_ref", { +test_that(".cbBuildLdArgs: factors route to X_ref, whatever their shape", { X1 <- matrix(0, 10, 4) - res <- pecotmr:::.cbBuildLdArgs(list(X1)) - expect_true("X_ref" %in% names(res)) + res <- pecotmr:::.cbBuildLdArgs(list(X1), "X_ref") + expect_identical(names(res), "X_ref") + # A factor with as many rows as variants is still a factor. + square <- pecotmr:::.cbBuildLdArgs(list(diag(4)), "X_ref") + expect_identical(names(square), "X_ref") }) test_that(".cbBuildLdArgs: empty list returns empty list", { @@ -320,22 +323,22 @@ test_that(".cbRequireSumStatsQc: QCd input passes", { }) -test_that(".cbRequireMatchingLdSketches: NULL sides are allowed", { - expect_silent(pecotmr:::.cbRequireMatchingLdSketches( +test_that(".cbRequireMatchingLdRefs: NULL sides are allowed", { + expect_silent(pecotmr:::.cbRequireMatchingLdRefs( NULL, .cbp_makeHandle() )) - expect_silent(pecotmr:::.cbRequireMatchingLdSketches( + expect_silent(pecotmr:::.cbRequireMatchingLdRefs( .cbp_makeHandle(), NULL )) }) -test_that(".cbRequireMatchingLdSketches: accepts differently trimmed panels", { +test_that(".cbRequireMatchingLdRefs: accepts differently trimmed panels", { # Separate QC of the two sides trims one shared LD reference to two # overlapping-but-unequal variant sets; the check reports, not refuses. expect_warning( - expect_null(pecotmr:::.cbRequireMatchingLdSketches( + expect_null(pecotmr:::.cbRequireMatchingLdRefs( .cbp_makeHandle(snp_n = 4L), .cbp_makeHandle(snp_n = 5L) )), @@ -343,9 +346,9 @@ test_that(".cbRequireMatchingLdSketches: accepts differently trimmed panels", { ) }) -test_that(".cbRequireMatchingLdSketches: sample-set mismatch errors", { +test_that(".cbRequireMatchingLdRefs: sample-set mismatch errors", { expect_error( - pecotmr:::.cbRequireMatchingLdSketches( + pecotmr:::.cbRequireMatchingLdRefs( .cbp_makeHandle(sample_prefix = "a"), .cbp_makeHandle(sample_prefix = "b") ), @@ -369,6 +372,23 @@ test_that(".cbMergeSumstatBundles: identical LD matrices are deduplicated", { res <- pecotmr:::.cbMergeSumstatBundles(bundles) expect_equal(length(res$LD), 1L) expect_equal(unique(res$dict_sumstatLD[, 2L]), 1L) + expect_identical(res$ldArg, "LD") +}) + +test_that(".cbMergeSumstatBundles records factors and refuses a mix", { + f <- matrix(c(1, -1, 0.5, -0.5), 2) + factors <- list( + a = list(sumstat = data.frame(z = 1:2), LD = f, isFactor = TRUE), + b = list(sumstat = data.frame(z = 3:4), LD = f, isFactor = TRUE) + ) + res <- pecotmr:::.cbMergeSumstatBundles(factors) + expect_identical(res$ldArg, "X_ref") + expect_equal(length(res$LD), 1L) + mixed <- list_assign(factors, b = list_assign(factors$b, isFactor = FALSE)) + expect_error( + pecotmr:::.cbMergeSumstatBundles(mixed), + "mix LD matrices and genotype factors" + ) }) test_that(".cbEmptyResult: is the internal per-analysis accumulator", { @@ -590,9 +610,9 @@ test_that("colocboostPipeline: no analysis flag set is an error", { } }) -test_that("colocboostPipeline: GWAS ldSketch mismatch errors during the driver", { +test_that("colocboostPipeline: GWAS ldReference mismatch errors in driver", { ss <- .cbp_makeQtlSumStats() - # Build a GwasSumStats whose ldSketch has a different sample set. + # Build a GwasSumStats whose ldReference has a different sample set. gh_diff <- .cbp_makeHandle(sample_prefix = "z") gr <- GenomicRanges::GRanges( seqnames = "chr1", @@ -612,7 +632,7 @@ test_that("colocboostPipeline: GWAS ldSketch mismatch errors during the driver", studyName = "G1", entry = list(gr), genome = "hg19", - ldSketch = gh_diff, + ldReference = gh_diff, qcInfo = list(step1 = "ok") ) # .cbQtlSumStatsBundle reads the qtl sketch via extractBlockGenotypes @@ -658,7 +678,7 @@ test_that("GwasSumStats: nCase/nControl are optional columns (absent by default) study = "G1", entry = list(gr), genome = "hg19", - ldSketch = .cbp_makeHandle(), + ldReference = .cbp_makeHandle(), qcInfo = list(ok = 1) ) g0 <- exec(GwasSumStats, !!!base) @@ -690,7 +710,7 @@ test_that("colocboost GWAS bundle: effective N for case/control, per-variant N o study = "G1", entry = list(gr), genome = "hg19", - ldSketch = .cbp_makeHandle(), + ldReference = .cbp_makeHandle(), qcInfo = list(ok = 1) ) local_mocked_bindings( @@ -844,7 +864,7 @@ test_that("colocboostPipeline(QtlDataset): pipCutoffToSkip dropping every outcom colocboostPipeline( qd, xqtlColoc = TRUE, - signalScreenArgs = SignalScreenParam(pip = 0.9999) + signalScreenParam = SignalScreenParam(pip = 0.9999) ) )) expect_null(out$xqtl_coloc) # 249-253 skip -> empty @@ -954,6 +974,27 @@ test_that(".cbFlipPairToCanonical flips z + LD for swapped variants, relabels to expect_equal(unname(diag(out$LD)), c(1, 1)) # diagonal preserved }) +test_that(".cbFlipPairToCanonical negates a factor's swapped columns", { + ss <- data.frame( + z = c(2, -1), + n = c(1000, 1000), + variant = c("chr1:100:A:G", "chr1:200:C:T"), + stringsAsFactors = FALSE + ) + f <- matrix(c(1, -1, 0, 0.5, 0.5, -1), nrow = 3) + p <- list(sumstat = ss, LD = f, variantIds = ss$variant, isFactor = TRUE) + canonical <- c("chr1:100:G:A", "chr1:200:C:T") + out <- pecotmr:::.cbFlipPairToCanonical(p, canonical) + expect_true(out$isFactor) + expect_identical(colnames(out$LD), canonical) + expect_equal(unname(out$LD), cbind(-f[, 1], f[, 2])) + # The factor's LD is the flipped LD. + expect_equal( + unname(crossprod(out$LD)), + unname(crossprod(f) * outer(c(-1, 1), c(-1, 1))) + ) +}) + test_that(".cbFlipMatrixToCanonical negates residualized dosage for swapped columns", { X <- matrix( c(1, -1, 2, 0.5, -0.5, 1), @@ -1056,7 +1097,7 @@ test_that("colocboost RSS cutoffs match .panelVariantFilter", { expect_equal( .cbf_n(ss, mafCutoff = cut), length(.panelVariantFilter( - ldSketch(ss), + ldReference(ss), ids, PanelFilterParam(mafCutoff = cut) )), @@ -1067,7 +1108,7 @@ test_that("colocboost RSS cutoffs match .panelVariantFilter", { test_that("colocboost RSS treats MAC as a MAF equivalent", { ss <- .cbf_qcd() - nSamp <- ncol(ldSketch(ss)) + nSamp <- ncol(ldReference(ss)) expect_equal( .cbf_n(ss, macCutoff = 0.1 * 2 * nSamp), .cbf_n(ss, mafCutoff = 0.1) @@ -1092,22 +1133,51 @@ test_that(".cbSumstatPair keeps sumstat rows aligned to the LD matrix", { trait = ss$trait[[1L]], require = "Z" ) - sketch <- ldSketch(ss) + sketch <- ldReference(ss) pair <- suppressMessages(.cbSumstatPair( df = df, - ldSketch = sketch, + ldReference = sketch, cutoffs = list(mafCutoff = 0.2, macCutoff = 0, imissCutoff = 1) )) expect_lt(length(pair$variantIds), nrow(df)) expect_equal(nrow(pair$sumstat), length(pair$variantIds)) expect_equal(pair$sumstat$variant, pair$variantIds) - expect_equal(nrow(pair$LD), length(pair$variantIds)) - expect_equal(rownames(pair$LD), pair$variantIds) + # A genotype reference gives a factor of its LD: variants on the columns. + expect_true(pair$isFactor) + expect_equal(ncol(pair$LD), length(pair$variantIds)) + expect_equal(colnames(pair$LD), pair$variantIds) # The surviving z values are the originals for those variants. orig <- df$z[is_in(normalizeVariantId(df$variant_id), pair$variantIds)] expect_equal(pair$sumstat$z, orig) }) +test_that("colocboost reads a panel's factor and its LdMatrix alike", { + # A genotype reference reaches colocboost as X_ref, a factor of its LD; + # an LdMatrix as LD. The same LD gives the same colocalization. + skip_if_not_installed("colocboost") + data(qtlSumStatsMulticontextExample) + ss <- suppressMessages(summaryStatsQc(qtlSumStatsMulticontextExample)) + panel <- ldReference(ss) + withLd <- QtlSumStats( + studyName = ss$study, + context = ss$context, + trait = ss$trait, + entry = map(seq_len(length(ss)), .collectionEntry, x = ss), + genome = "hg19", + ldReference = LdMatrix( + unname(computeLd(panel)), + variants = SummarizedExperiment::rowRanges(panel) + ), + qcInfo = qcInfo(ss) + ) + set.seed(1) + viaPanel <- suppressWarnings(suppressMessages(colocboostPipeline(ss))) + set.seed(1) + viaMatrix <- suppressWarnings(suppressMessages(colocboostPipeline(withLd))) + expect_gt(nrow(as.data.frame(viaPanel)), 0L) + expect_equal(as.data.frame(viaPanel), as.data.frame(viaMatrix)) +}) + test_that(".cbSumstatPair returns NULL when a cutoff removes everything", { ss <- .cbf_qcd() df <- as.data.frame( @@ -1119,7 +1189,7 @@ test_that(".cbSumstatPair returns NULL when a cutoff removes everything", { ) expect_null(suppressMessages(.cbSumstatPair( df = df, - ldSketch = ldSketch(ss), + ldReference = ldReference(ss), cutoffs = list(mafCutoff = 0.99, macCutoff = 0, imissCutoff = 1) ))) }) @@ -1188,7 +1258,7 @@ test_that("a MultiStudyQtlDataset with no embedded sumstats yields no pairs", { traitId = NULL ) expect_equal(out$qtlPairs, list()) - expect_null(out$qtlLdSketch) + expect_null(out$qtlLdReference) }) test_that("the signal screen passes Y through when no cutoff applies", { @@ -1501,7 +1571,7 @@ test_that(".cbAppendGwasPairs disambiguates a colliding study key", { out <- pecotmr:::.cbAppendGwasPairs( list(dup = "QTL", other = "X"), "notNull", - qtlLdSketch = NULL + qtlLdReference = NULL ) # The QTL pair keeps its key; the GWAS pair is suffixed rather than # overwriting it. @@ -1514,7 +1584,7 @@ test_that(".cbConcat answers an empty list for no pieces", { expect_identical(pecotmr:::.cbConcat(list()), list()) }) -test_that("colocboostPipeline forwards residualizationArgs to both sides", { +test_that("colocboostPipeline forwards residualizationParam to both sides", { # It accepted no bundle at all, so it ran on the dataset's own settings # with no per-call say -- unlike fineMappingPipeline() and # twasWeightsPipeline(). Both SIDES matter here: colocboost consumes X and @@ -1538,25 +1608,25 @@ test_that("colocboostPipeline forwards residualizationArgs to both sides", { residualizedGenotypes = function( x, ..., - residualizationArgs = ResidualizationParam() + residualizationParam = ResidualizationParam() ) { - note("geno", residualizationArgs) - origG(x, ..., residualizationArgs = residualizationArgs) + note("geno", residualizationParam) + origG(x, ..., residualizationParam = residualizationParam) }, residualizedPhenotypes = function( x, ..., - residualizationArgs = ResidualizationParam() + residualizationParam = ResidualizationParam() ) { - note("pheno", residualizationArgs) - origP(x, ..., residualizationArgs = residualizationArgs) + note("pheno", residualizationParam) + origP(x, ..., residualizationParam = residualizationParam) }, .package = "pecotmr" ) suppressWarnings(suppressMessages(colocboostPipeline( qtlDatasetExample, cisWindow = 1e6, - residualizationArgs = ResidualizationParam(scaleResiduals = FALSE) + residualizationParam = ResidualizationParam(scaleResiduals = FALSE) ))) expect_equal(unique(get("geno", envir = seen)), "FALSE") expect_equal(unique(get("pheno", envir = seen)), "FALSE") diff --git a/tests/testthat/test_cpp11.R b/tests/testthat/test_cpp11.R index 2557339f0..2818c855f 100644 --- a/tests/testthat/test_cpp11.R +++ b/tests/testthat/test_cpp11.R @@ -2,7 +2,11 @@ # only thin .Call() wrappers around the compiled routines in src/. The # behaviour of each routine is tested through its R-level wrapper # (test_rrLassosum.R, test_rrPrsCs.R, test_rrSdpr.R, test_rrPenalizedRss.R, -# test_sumstatsQc.R for DENTIST, test_qtlEnrichmentPipeline.R). +# test_sumstatsQc.R for DENTIST, test_qtlEnrichmentPipeline.R, +# test_ld.R for the pruning components, test_genotypeIo.R for the BGEN +# decoder, test_GenotypeDosageSeed.R for VCF GT calls) or, for the solvers' +# factor entry points, against their dense counterparts +# (test_regularizedRegressionWrappers.R). # # What is left to check here is the seam those tests cannot see: that every # generated wrapper's native symbol is actually registered in the compiled @@ -12,12 +16,21 @@ # "object '_pecotmr_x' not found" from deep inside a pipeline. .cpp_wrappers <- c( + "bgenDosageCpp", + "bgenSampleIdsCpp", "dentistIterativeImpute", - "lassosumRssRcpp", - "penalizedRssRcpp", - "prsCsRcpp", - "qtlEnrichmentRcpp", - "sdprRcpp" + "dentistIterativeImputeFactor", + "lassosumRssCpp", + "lassosumRssFactorCpp", + "ldThresholdComponents", + "penalizedRssCpp", + "penalizedRssFactorCpp", + "prsCsCpp", + "prsCsFactorCpp", + "qtlEnrichmentCpp", + "sdprCpp", + "sdprFactorCpp", + "vcfGtDosageCpp" ) test_that("every generated cpp11 wrapper exists in the namespace", { diff --git a/tests/testthat/test_crossValidation.R b/tests/testthat/test_crossValidation.R index 34c87b66c..010d59d53 100644 --- a/tests/testthat/test_crossValidation.R +++ b/tests/testthat/test_crossValidation.R @@ -389,3 +389,44 @@ test_that("sumstats inputs ignore residualization but refuse crossValidation", { expect_false("residualization" %in% names(formals(f)), label = fn) } }) + +test_that("CrossValidationParam(fitFullData) is validated at construction", { + expect_true(CrossValidationParam()$fitFullData) + expect_false( + CrossValidationParam(folds = 2, fitFullData = FALSE)$fitFullData + ) + # FALSE keeps only the cross-validation results, so there must be + # cross-validation to keep: 0 and 1 folds both mean "none". + expect_error( + CrossValidationParam(fitFullData = FALSE), + "fitFullData = FALSE requires cross-validation" + ) + expect_error( + CrossValidationParam(folds = 1, fitFullData = FALSE), + "fitFullData = FALSE requires cross-validation" + ) + expect_error( + CrossValidationParam(fitFullData = NA), + "single TRUE or FALSE" + ) + expect_error( + CrossValidationParam(fitFullData = c(TRUE, FALSE)), + "single TRUE or FALSE" + ) + expect_true(pecotmr:::.cvResolve(CrossValidationParam())$fitFullData) + # The default is not a request, so the default bundle still passes the + # summary-statistics refusal; an explicit FALSE is one, and is refused. + expect_silent(pecotmr:::.cvRefuseOnSumstats( + CrossValidationParam(), + "twasWeightsPipeline", + "QtlSumStats" + )) + expect_error( + pecotmr:::.cvRefuseOnSumstats( + CrossValidationParam(folds = 2, fitFullData = FALSE), + "twasWeightsPipeline", + "QtlSumStats" + ), + "fitFullData" + ) +}) diff --git a/tests/testthat/test_ctwasPipeline.R b/tests/testthat/test_ctwasPipeline.R index b58e3b089..9c3a35a70 100644 --- a/tests/testthat/test_ctwasPipeline.R +++ b/tests/testthat/test_ctwasPipeline.R @@ -13,9 +13,9 @@ context("ctwasPipeline") # Use a per-process tempfile so .ctwasLdPanelKey's file.exists check # succeeds against the fixture handle (real LD-sketch payloads exist # by construction; mock fixtures need an equivalent on-disk anchor). - gdsPath <- file.path(tempdir(), "ctp_sketch.gds") - if (!file.exists(gdsPath)) { - file.create(gdsPath) + stem <- file.path(tempdir(), "ctp_sketch") + if (!file.exists(paste0(stem, ".pgen"))) { + file.create(paste0(stem, ".pgen")) } positions <- seq(100L, by = 100L, length.out = snp_n) # SNP IDs follow the canonical chr:pos:A2:A1 layout so allele @@ -24,8 +24,8 @@ context("ctwasPipeline") snpIds <- sprintf("chr1:%d:G:A", positions) new( "GenotypeHandle", - path = gdsPath, - format = "gds", + path = stem, + format = "plink2", snpInfo = data.frame( SNP = snpIds, CHR = rep("1", snp_n), @@ -41,12 +41,19 @@ context("ctwasPipeline") } # A panel with its correlation already built, the shape callers saw before -# the LD became on-demand. Tests that assert on R_wgt want it materialized. +# the LD became on-demand. Tests that compare against that matrix want it +# materialized. .ctp_fullPanel <- function(h) { p <- pecotmr:::.ctwasPanelFor(h) c(p, list(R = pecotmr:::.ctwasPanelLd(p))) } +# A genotype panel's variants snpInfo-style (SNP, CHR, BP, A1, A2): the +# example dataset's PLINK1 panel reads through no handle to ask instead. +.ctp_panelSnpInfo <- function(panel) { + pecotmr:::.rangesSnpInfo(SummarizedExperiment::rowRanges(panel)) +} + # Canonical SNP IDs the fixtures use. .ctp_makeHandle() emits these in # chr:pos:A2:A1 form; tests reference them by index via .ctp_snpId(i). .ctp_snpId <- function(i) sprintf("chr1:%d:G:A", 100L * i) @@ -115,7 +122,7 @@ context("ctwasPipeline") studyName = rep("G1", n), entry = map(seq_len(n), .ctp_blockVariants), genome = "hg19", - ldSketch = .ctp_makeHandle(snp_n = 6L * n), + ldReference = .ctp_makeHandle(snp_n = 6L * n), blockId = blockIds, qcInfo = if (qc) list(step1 = "ok") else list() ) @@ -135,7 +142,7 @@ context("ctwasPipeline") trait = "t1", method = "susie", entry = list(e), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) } @@ -166,7 +173,7 @@ context("ctwasPipeline") trait = "t1", method = "susie", entry = list(fe), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) } @@ -255,10 +262,16 @@ test_that("assembleCtwasInputs: allows twasWeights keys to be a subset of gwasSu extractBlockGenotypes = .ctp_mockExtractor(), .package = "pecotmr" ) - # Two blocks supply zSnp; only block1 supplies TwasWeights. - inputs <- assembleCtwasInputs( - gwasSumStats = ss, - twasWeights = list(block1 = tw) + # Two blocks supply zSnp; only block1 supplies TwasWeights, whose panel + # shares block1's six variants of its twelve -- a partial overlap, + # reported once per session. + rlang::reset_warning_verbosity("pecotmrLdReferenceOverlap-ctwasPipeline") + expect_warning( + inputs <- assembleCtwasInputs( + gwasSumStats = ss, + twasWeights = list(block1 = tw) + ), + "share 6 variant" ) # Both blocks appear in region_info / snp_map (SNP-only block2 contributes # its zSnp), but the weights list only has block1-keyed entries. @@ -282,7 +295,7 @@ test_that("assembleCtwasInputs: accepts a QtlFineMappingResult weight source (to weights = c(0.1, 0.05, -0.2, 0.3, 0.0), weightStandardized = TRUE )), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) fmr <- .ctp_makeFmrWeightSource() local_mocked_bindings( @@ -328,7 +341,7 @@ test_that("assembleCtwasInputs: boundary gene fits per-region, spans all", { studyName = studyName, entry = list(gr), genome = "hg19", - ldSketch = .ctp_makeHandle(), + ldReference = .ctp_makeHandle(), qcInfo = if (qc) list(step1 = "ok") else list() ) } @@ -345,7 +358,7 @@ test_that("assembleCtwasInputs: boundary gene fits per-region, spans all", { trait = "t1", method = "susie", entry = list(crossEntry), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) local_mocked_bindings( extractBlockGenotypes = .ctp_mockExtractor(), @@ -366,7 +379,8 @@ test_that("assembleCtwasInputs: boundary gene fits per-region, spans all", { wgt <- entry$wgt expect_equal(nrow(wgt), 2L) expect_setequal(rownames(wgt), map_chr(2:3, .ctp_snpId)) - expect_equal(nrow(entry$R_wgt), 2L) + expect_length(entry$wgt_var, 1L) + expect_gt(entry$wgt_var, 0) expect_equal(entry$n_wgt, 2L) expect_equal(entry$p0, 200L) expect_equal(entry$p1, 500L) @@ -414,10 +428,10 @@ test_that("CtwasPriorParam rejects an unknown varStructure", { }) # =========================================================================== -# .ctwasRequireMatchingLdSketches +# .ctwasRequireMatchingLdRefs # =========================================================================== -test_that(".ctwasRequireMatchingLdSketches: NULL twas-side handle is allowed", { +test_that(".ctwasRequireMatchingLdRefs: NULL twas-side handle is allowed", { twNoLd <- TwasWeights( studyName = "Q1", context = "c1", @@ -427,15 +441,15 @@ test_that(".ctwasRequireMatchingLdSketches: NULL twas-side handle is allowed", { variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), weights = rep(0.1, 5) )), - ldSketch = NULL + ldReference = NULL ) - expect_silent(pecotmr:::.ctwasRequireMatchingLdSketches( + expect_silent(pecotmr:::.ctwasRequireMatchingLdRefs( twLd = NULL, gwasLd = .ctp_makeHandle() )) }) -test_that(".ctwasRequireMatchingLdSketches: differently trimmed panels ok", { +test_that(".ctwasRequireMatchingLdRefs: differently trimmed panels ok", { # One LD reference QC'd separately on the two sides leaves each sketch # trimmed to its own surviving variants, so the panels overlap without # being identical. That is the normal case, not an error. @@ -444,23 +458,23 @@ test_that(".ctwasRequireMatchingLdSketches: differently trimmed panels ok", { # tests legitimately trip it first (each block's GWAS panel is narrowed to # its own variants while the weights carry the whole one), so clear that # budget here rather than depending on which files ran before this. - rlang::reset_warning_verbosity("pecotmrLdSketchOverlap-ctwasPipeline") + rlang::reset_warning_verbosity("pecotmrLdReferenceOverlap-ctwasPipeline") twLd <- .ctp_makeHandle(snp_n = 5L) gwasLd <- .ctp_makeHandle(snp_n = 6L) expect_warning( - expect_null(pecotmr:::.ctwasRequireMatchingLdSketches(twLd, gwasLd)), + expect_null(pecotmr:::.ctwasRequireMatchingLdRefs(twLd, gwasLd)), "share 5 variant" ) }) -test_that(".ctwasRequireMatchingLdSketches: disjoint panels error", { +test_that(".ctwasRequireMatchingLdRefs: disjoint panels error", { twLd <- .ctp_makeHandle(snp_n = 3L) gwasLd <- .ctp_makeHandle(snp_n = 3L) si <- snpInfo(gwasLd) si$BP <- si$BP + 1e6L gwasLd@snpInfo <- si expect_error( - pecotmr:::.ctwasRequireMatchingLdSketches(twLd, gwasLd), + pecotmr:::.ctwasRequireMatchingLdRefs(twLd, gwasLd), "share no variant" ) }) @@ -606,7 +620,7 @@ test_that(".ctwasBuildSingleRegionInfo: uses the block entry span, not the wider studyName = "G1", entry = list(gr), genome = "hg19", - ldSketch = .ctp_makeHandle(), + ldReference = .ctp_makeHandle(), qcInfo = list(step1 = "ok") ) ri <- pecotmr:::.ctwasBuildSingleRegionInfo("blockX", gss) @@ -630,7 +644,7 @@ test_that(".ctwasBuildSingleRegionInfo: multi-chromosome block entry errors", { studyName = "G1", entry = list(gr), genome = "hg19", - ldSketch = .ctp_makeHandle(), + ldReference = .ctp_makeHandle(), qcInfo = list(step1 = "ok") ) expect_error( @@ -664,11 +678,18 @@ test_that(".ctwasSnpInfoForBlock: repairs a tag-allele panel id from A1/A2", { expect_true("chr1:200:G:A" %in% names(panel$variance)) }) -test_that(".ctwasLdPanelKey: returns the on-disk path for an existing GDS sketch", { +test_that(".ctwasLdPanelKey: returns the file behind an existing sketch", { handle <- .ctp_makeHandle() key <- pecotmr:::.ctwasLdPanelKey(handle) expect_true(file.exists(key)) - expect_equal(key, path(handle)) + expect_equal(key, paste0(path(handle), ".pgen")) +}) + +test_that(".ctwasLdPanelKey: a VCF panel's key is its file", { + skip_if_not_installed("VariantAnnotation") + vcf <- .writeTestVcf(.vcfGtOnly(.vcfOverlapRecords()), c("s1", "s2", "s3")) + panel <- suppressWarnings(readGenotypes(vcf)) + expect_equal(pecotmr:::.ctwasLdPanelKey(panel), normalizePath(vcf)) }) test_that(".ctwasLdPanelKey: errors when no candidate file exists", { @@ -690,10 +711,41 @@ test_that(".ctwasLdPanelKey: errors when no candidate file exists", { ) expect_error( pecotmr:::.ctwasLdPanelKey(ghost), - "could not derive an existing LD-file token" + "could not find the file behind the LD panel" ) }) +test_that(".ctwasLdPanelKey: a mixture checks each panel; memory needs none", { + panel <- readGenotypes(test_path("test_data", "test_variants.bed")) + mix <- GenotypeMixture( + list(a = panel[, 1:40], b = panel[, 41:100]), + mixtureWeights = c(0.5, 0.5) + ) + expect_null(pecotmr:::.ctwasLdPanelKey(mix)) + # One panel whose file has gone fails the whole mixture. + dir <- withr::local_tempdir() + file.copy( + test_path( + "test_data", + str_c("test_variants", c(".bed", ".bim", ".fam")) + ), + dir + ) + copy <- readGenotypes(file.path(dir, "test_variants.bed")) + gone <- GenotypeMixture( + list(a = copy[, 1:40], b = panel[, 41:100]), + mixtureWeights = c(0.5, 0.5) + ) + file.remove(file.path(dir, "test_variants.bed")) + expect_error( + pecotmr:::.ctwasLdPanelKey(gone), + "could not find the file behind the LD panel" + ) + # A panel held in memory reads no file, so there is none to find. + inMemory <- .ctp_mockExtractor()(.ctp_makeHandle(snp_n = 6L), 1:6) + expect_null(pecotmr:::.ctwasLdPanelKey(inMemory)) +}) + # --------------------------------------------------------------------------- # Per-block LD scoping. Two bugs met here: combineGwasSumStats() UNIONS the # per-piece sketches, and `[` carries that collection-level slot into every @@ -706,15 +758,15 @@ test_that(".ctwasPickBlock: narrows the collection sketch to the block", { ss <- .ctp_makeGwasSumstats() # The collection's sketch spans both blocks, as combineGwasSumStats # leaves it. - expect_equal(length(pecotmr:::.ldSketchRanges(ldSketch(ss))), 12L) + expect_equal(length(pecotmr:::.ldRefRanges(ldReference(ss))), 12L) byBlock <- pecotmr:::.ctwasGwasByBlock(ss) sizes <- map_int(byBlock, function(b) { - length(pecotmr:::.ldSketchRanges(ldSketch(b))) + length(pecotmr:::.ldRefRanges(ldReference(b))) }) expect_equal(unname(sizes), c(6L, 6L)) # Narrowed to DIFFERENT variants: block 1 holds 1..6, block 2 holds 7..12. pos <- map(byBlock, function(b) { - GenomicRanges::start(pecotmr:::.ldSketchRanges(ldSketch(b))) + GenomicRanges::start(pecotmr:::.ldRefRanges(ldReference(b))) }) expect_equal(pos[[1L]], 100L * (1:6)) expect_equal(pos[[2L]], 100L * (7:12)) @@ -723,7 +775,7 @@ test_that(".ctwasPickBlock: narrows the collection sketch to the block", { test_that(".ctwasRegionLdTokens: one distinct, existing token per region", { ss <- .ctp_makeGwasSumstats() byBlock <- pecotmr:::.ctwasGwasByBlock(ss) - sketches <- map(byBlock, ldSketch) + sketches <- map(byBlock, ldReference) tokens <- pecotmr:::.ctwasRegionLdTokens(names(byBlock), sketches) expect_length(unique(unname(tokens)), 2L) expect_true(all(file.exists(tokens))) @@ -794,7 +846,7 @@ test_that(".ctwasResolveMethod: caller-supplied method wins when present", { trait = "t1", method = "mrash", entry = list(e), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) expect_equal(pecotmr:::.ctwasResolveMethod(list(r1 = tw), "mrash"), "mrash") }) @@ -810,7 +862,7 @@ test_that(".ctwasResolveMethod: caller-supplied unknown method errors", { trait = "t1", method = "mrash", entry = list(e), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) expect_error( pecotmr:::.ctwasResolveMethod(list(r1 = tw), "bogus"), @@ -830,7 +882,7 @@ test_that(".ctwasResolveMethod: defaults to ensemble when present among multiple trait = "t1", method = m, entry = list(e), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) } # Build a multi-method TwasWeights by stitching two methods together. @@ -849,7 +901,7 @@ test_that(".ctwasResolveMethod: defaults to ensemble when present among multiple weights = c(0.4, 0.5, 0.6) ) ), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) expect_equal(pecotmr:::.ctwasResolveMethod(list(r1 = tw)), "ensemble") }) @@ -865,7 +917,7 @@ test_that(".ctwasResolveMethod: single method auto-picked when only one availabl trait = "t1", method = "mrash", entry = list(e), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) expect_equal(pecotmr:::.ctwasResolveMethod(list(r1 = tw)), "mrash") }) @@ -886,7 +938,7 @@ test_that(".ctwasResolveMethod: multi-method + no ensemble + no caller method er weights = c(0.4, 0.5, 0.6) ) ), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) expect_error( pecotmr:::.ctwasResolveMethod(list(r1 = tw)), @@ -909,7 +961,7 @@ test_that(".ctwasResolveMethod: multi-method + no ensemble + no caller method er weights = c(0.1, 0.2, 0.3) ) }), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) } @@ -1034,14 +1086,14 @@ test_that(".ctwasBucketWeights: places a flat 2-gene source into its home blocks c("chr1", "chr1"), IRanges::IRanges(c(100, 800), c(150, 850)) ), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) grid <- pecotmr:::.ctwasGwasByBlock(.ctp_makeGwasSumstats()) bucketed <- pecotmr:::.ctwasBucketWeights(tw, grid) expect_named(bucketed, c("block1", "block2"), ignore.order = TRUE) expect_equal(as.character(bucketed[["block1"]]$trait), "gA") expect_equal(as.character(bucketed[["block2"]]$trait), "gB") - expect_false(is.null(ldSketch(bucketed[["block1"]]))) + expect_false(is.null(ldReference(bucketed[["block1"]]))) }) test_that(".ctwasBucketWeights: errors when source lacks traitPos", { @@ -1237,7 +1289,7 @@ test_that(".ctwasFilterMethod: subsets rows to the requested method", { weights = c(0.4, 0.5, 0.6) ) ), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) twSub <- pecotmr:::.ctwasFilterMethod(tw, "susie") expect_equal(nrow(twSub), 1L) @@ -1271,7 +1323,7 @@ test_that(".ctwasBuildWeights: scales non-standardized weights by sqrt(variance) trait = "t1", method = "susie", entry = list(twasWeightsRow(variantIds = ids5, weights = rawW)), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) wl <- pecotmr:::.ctwasBuildWeights(tw, panel) expected <- unname(rawW * sqrt(panel$variance[ids5])) @@ -1293,7 +1345,7 @@ test_that(".ctwasBuildWeights: standardized weights bypass variance scaling", { weights = rawW, weightStandardized = TRUE )), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) wl <- pecotmr:::.ctwasBuildWeights(tw, panel) expect_equal(as.numeric(wl[[1L]]$wgt), rawW, tolerance = 1e-12) @@ -1564,13 +1616,15 @@ test_that(".ctwasBuildWeights: keys per-tuple weights, adds gene metadata", { expect_true(is.matrix(wl[[1L]]$wgt)) expect_equal(dim(wl[[1L]]$wgt), c(5L, 1L)) expect_equal(rownames(wl[[1L]]$wgt), ids5) - # R_wgt is a 5x5 slice of the cached panel R - expect_true(is.matrix(wl[[1L]]$R_wgt)) - expect_equal(dim(wl[[1L]]$R_wgt), c(5L, 5L)) - expect_equal(rownames(wl[[1L]]$R_wgt), ids5) + # wgt_var is the gene's w'Rw, here from the panel's own R; no weight LD + # matrix is carried. + w <- wl[[1L]]$wgt[, 1L] + expect_equal( + wl[[1L]]$wgt_var, + as.numeric(crossprod(w, panel$R[ids5, ids5] %*% w)) + ) + expect_null(wl[[1L]]$R_wgt) expect_equal(wl[[1L]]$n_wgt, 5L) - # And it is literally a slice of the panel R (no recompute path). - expect_equal(wl[[1L]]$R_wgt, panel$R[ids5, ids5]) }) test_that(".ctwasBuildWeights: drops variants not present in the LD panel", { @@ -1585,7 +1639,7 @@ test_that(".ctwasBuildWeights: drops variants not present in the LD panel", { variantIds = c(ids3, missing), weights = c(0.1, 0.2, 0.3, 0.4, 0.5) )), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) panel <- .ctp_makeLdPanel() wl <- pecotmr:::.ctwasBuildWeights(tw, panel) @@ -1610,7 +1664,7 @@ test_that(".ctwasBuildWeights: intersects with gwasSnpIds when supplied", { variantIds = ids5, weights = c(0.1, 0.2, 0.3, 0.4, 0.5) )), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) panel <- .ctp_makeLdPanel() wl <- pecotmr:::.ctwasBuildWeights( @@ -1646,34 +1700,46 @@ test_that(".ctwasPanelFor: cheap fields eagerly, correlation on request", { expect_equal(rownames(R), ids6) }) -test_that(".ctwasPanelLdSubset: refuses a variant absent from the panel", { +test_that(".ctwasPanelWeightLd: refuses a variant absent from the panel", { local_mocked_bindings( extractBlockGenotypes = .ctp_mockExtractor(), .package = "pecotmr" ) panel <- pecotmr:::.ctwasPanelFor(.ctp_makeHandle(snp_n = 6L)) vids <- c(.ctp_snpId(2L), "chr22:999999999:A:G") - # Subsetting on a missing id would give an NA row/column that silently - # poisons the correlation, so it is refused by name and count. + # A missing id would give an NA column that silently poisons the weight + # variance, so it is refused by name and count. expect_error( - pecotmr:::.ctwasPanelLdSubset(panel, vids), + pecotmr:::.ctwasPanelWeightLd(panel, vids), "1 weight variant\\(s\\) absent from the block's LD panel" ) }) -test_that(".ctwasPanelLdSubset: slices a precomputed R when the panel has one", { +test_that(".ctwasPanelWeightLd: a panel's factor, or the R it carries", { local_mocked_bindings( extractBlockGenotypes = .ctp_mockExtractor(), .package = "pecotmr" ) panel <- pecotmr:::.ctwasPanelFor(.ctp_makeHandle(snp_n = 6L)) - vids <- map_chr(c(1L, 3L), .ctp_snpId) - # With R already built, the subset is a slice rather than a recompute. - panel$R <- pecotmr:::.ctwasPanelLd(panel) - out <- pecotmr:::.ctwasPanelLdSubset(panel, vids) - expect_equal(dim(out), c(2L, 2L)) - expect_equal(rownames(out), vids) - expect_equal(out, panel$R[vids, vids]) + vids <- map_chr(c(4L, 1L, 3L), .ctp_snpId) + full <- pecotmr:::.ctwasPanelLd(panel) + # A sketch gives its factor: the LD over vids without forming it. + viaFactor <- pecotmr:::.ctwasPanelWeightLd(panel, vids) + expect_null(viaFactor$R) + expect_identical(colnames(viaFactor$F), vids) + expect_equal( + crossprod(viaFactor$F) / (nrow(viaFactor$F) - 1), + full[vids, vids] + ) + # A panel that already carries R is sliced, not re-read. + withR <- pecotmr:::.ctwasPanelWeightLd(c(panel, list(R = full)), vids) + expect_null(withR$F) + expect_equal(withR$R, full[vids, vids]) + # An LdMatrix has no factor to give: its matrix is read over vids. + ldPanel <- pecotmr:::.ctwasPanelFor(LdMatrix(full, nSamples = 30)) + viaMatrix <- pecotmr:::.ctwasPanelWeightLd(ldPanel, vids) + expect_null(viaMatrix$F) + expect_equal(viaMatrix$R, full[vids, vids]) }) test_that(".ctwasLdMapRegionIds: falls back to positions without region_id", { @@ -1690,7 +1756,8 @@ test_that(".ctwasLdMapRegionIds: falls back to positions without region_id", { ) expect_equal( pecotmr:::.ctwasLdMapRegionIds( - data.frame(region_id = c("a", "b")), 2L + data.frame(region_id = c("a", "b")), + 2L ), c("a", "b") ) @@ -1706,44 +1773,87 @@ test_that(".ctwasGlobalPanelInfo: NULL when the collection has no sketch", { blockId = "block1", qcInfo = list(step1 = "ok") ) - expect_null(ldSketch(gs)) + expect_null(ldReference(gs)) # .ctwasRegionGwasLd reports the missing-sketch case with its own # message, so this helper must stay quiet and hand back NULL. expect_null(pecotmr:::.ctwasGlobalPanelInfo(gs)) }) -test_that(".ctwasPanelLdSubset: equals the slice of the full correlation", { +test_that(".ctwasWeightVariances: w'Rw from the factor matches the matrix", { local_mocked_bindings( extractBlockGenotypes = .ctp_mockExtractor(), .package = "pecotmr" ) panel <- pecotmr:::.ctwasPanelFor(.ctp_makeHandle(snp_n = 6L)) - vids <- map_chr(c(2L, 4L, 5L), .ctp_snpId) full <- pecotmr:::.ctwasPanelLd(panel) - # Mean imputation is per column, so correlating a subset of the dosages - # gives the same pairwise values as slicing the whole matrix. + prepared <- list( + list(vids = map_chr(c(1L, 2L), .ctp_snpId), w = c(0.5, -0.2)), + list(vids = map_chr(c(2L, 5L, 6L), .ctp_snpId), w = c(0.1, 0.3, -0.4)) + ) + viaFactor <- pecotmr:::.ctwasWeightVariances(panel, prepared) + viaMatrix <- pecotmr:::.ctwasWeightVariances( + c(panel, list(R = full)), + prepared + ) + expect_equal(viaFactor, viaMatrix) expect_equal( - pecotmr:::.ctwasPanelLdSubset(panel, vids), - full[vids, vids] + viaMatrix[[2L]], + as.numeric(crossprod( + prepared[[2L]]$w, + full[prepared[[2L]]$vids, prepared[[2L]]$vids] %*% prepared[[2L]]$w + )) ) + expect_identical(pecotmr:::.ctwasWeightVariances(panel, list()), numeric(0)) }) -test_that(".ctwasRWgtSource: builds the block matrix only when it pays", { - local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), - .package = "pecotmr" +test_that(".ctwasGeneZ gives ctwas::compute_gene_z's gene z-scores", { + skip_if_not_installed("ctwas") + ids <- map_chr(1:3, .ctp_snpId) + R <- matrix(c(1, 0.4, 0.1, 0.4, 1, 0.3, 0.1, 0.3, 1), 3, 3) + dimnames(R) <- list(ids, ids) + wgt <- matrix(c(0.5, -0.2, 0.3), ncol = 1L, dimnames = list(ids, "wgt")) + entry <- list(wgt = wgt, type = "c1", context = "c1") + zSnp <- data.frame(id = ids, A1 = "A", A2 = "G", z = c(2, -1, 0.5)) + ours <- pecotmr:::.ctwasGeneZ( + list( + g1 = list_assign( + entry, + wgt_var = as.numeric(crossprod(wgt, R %*% wgt)) + ) + ), + zSnp ) - panel <- pecotmr:::.ctwasPanelFor(.ctp_makeHandle(snp_n = 6L)) - # One gene on two variants: 4 against 36, so no block matrix is formed. - expect_null(pecotmr:::.ctwasRWgtSource(panel, 2L)) - # Six genes on five variants each: 150 against 36, so form it once. - dense <- pecotmr:::.ctwasRWgtSource(panel, rep(5L, 6L)) - expect_equal(dim(dense), c(6L, 6L)) - # A panel that already carries one is never rebuilt. - expect_identical( - pecotmr:::.ctwasRWgtSource(.ctp_makeLdPanel(), 1L), - .ctp_makeLdPanel()$R + theirs <- suppressMessages(ctwas::compute_gene_z( + zSnp, + list(g1 = list_assign(entry, R_wgt = R)) + )) + expect_equal(ours, theirs) + expect_error( + pecotmr:::.ctwasGeneZ( + list(g1 = list_assign(entry, wgt_var = 1)), + zSnp[-1L, ] + ), + "1 weight variant\\(s\\) of gene 'g1' have no GWAS z-score" + ) +}) + +test_that(".ctwasGeneZ: none without weights; an infinite z is dropped", { + expect_null(pecotmr:::.ctwasGeneZ(list(), data.frame())) + # A gene whose weights carry no variance in the panel has an infinite + # z, which ctwas's own compute_gene_z() drops too. + ids <- map_chr(1:2, .ctp_snpId) + wgt <- matrix(c(0.5, -0.2), ncol = 1L, dimnames = list(ids, "wgt")) + entry <- list(wgt = wgt, type = "c1", context = "c1", wgt_var = 1) + zSnp <- data.frame(id = ids, A1 = "A", A2 = "G", z = c(2, -1)) + expect_warning( + out <- pecotmr:::.ctwasGeneZ( + list(g1 = entry, g2 = list_assign(entry, wgt_var = 0)), + zSnp + ), + "dropped 1 gene\\(s\\) with an infinite z-score" ) + expect_equal(out$id, "g1") + expect_equal(out$z, 0.5 * 2 + 0.2) }) test_that(".ctwasBuildZGene: builds z_gene from a TWAS-Z GRanges", { @@ -2225,7 +2335,7 @@ test_that("ctwasPipeline: mergeBoundary = TRUE re-fine-maps and flows into Ctwas out <- ctwasPipeline( inp$gwasSumStats, inp$twasWeights, - boundaryMergeArgs = BoundaryMergeParam(enabled = TRUE) + boundaryMergeParam = BoundaryMergeParam(enabled = TRUE) ) expect_true(merged) # merging ran expect_s4_class(out, "CtwasResult") @@ -2316,7 +2426,7 @@ test_that("estCtwasGroupPriors: fallbackToPrefit recovers from accurate-EM NaN d expect_error( estCtwasGroupPriors( assembleCtwasInputs(inp$gwasSumStats, inp$twasWeights), - ctwasPriorArgs = CtwasPriorParam(fallbackToPrefit = FALSE) + ctwasPriorParam = CtwasPriorParam(fallbackToPrefit = FALSE) ), "contains NAs" ) @@ -2326,7 +2436,7 @@ test_that("estCtwasGroupPriors: fallbackToPrefit recovers from accurate-EM NaN d # (default thin = 0.1) → 1e-5. The group_prior_var is not thinned. est <- estCtwasGroupPriors( assembleCtwasInputs(inp$gwasSumStats, inp$twasWeights), - ctwasPriorArgs = CtwasPriorParam(fallbackToPrefit = TRUE) + ctwasPriorParam = CtwasPriorParam(fallbackToPrefit = TRUE) ) expect_equal(unname(est$param$group_prior), c(0.05, 1e-5)) expect_equal(unname(est$param$group_prior_var), c(4.0, 5.0)) @@ -2369,7 +2479,7 @@ test_that("estCtwasGroupPriors fallback drops degenerate regions before fit_EM", ) est <- estCtwasGroupPriors( assembleCtwasInputs(inp$gwasSumStats, inp$twasWeights), - ctwasPriorArgs = CtwasPriorParam(fallbackToPrefit = TRUE) + ctwasPriorParam = CtwasPriorParam(fallbackToPrefit = TRUE) ) # only the qualifying region reached fit_EM; the degenerate region was filtered expect_equal(seen, "good") @@ -2394,12 +2504,16 @@ test_that("(real ctwas) prefit fallback skips a degenerate region fit_EM would r "ctwas_region_data_degenerate.rds" )) expect_length(region_data, 2L) - res <- .ctwasFitPrefitEm( - region_data, - niter = 3L, - groupPriorVarStructure = "shared_all", - thin = 1, - numThreads = 1L + # Three iterations keep the test quick, short of ctwas's convergence. + expect_warning( + res <- .ctwasFitPrefitEm( + region_data, + niter = 3L, + groupPriorVarStructure = "shared_all", + thin = 1, + numThreads = 1L + ), + "EM did not converge in 3 iterations" ) # the prefit EM ran on the valid region only and returns finite real group priors expect_true("SNP" %in% names(res$group_prior)) @@ -2490,7 +2604,7 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", data(qtlDatasetExample) gss <- gwasSumStatsS4Example qd <- qtlDatasetExample - gh <- genotypeHandle(qd) + gh <- pecotmr:::.qtlGenotypeSe(qd) # Two 5-variant synthetic genes from the bundled panel, one anchored in # each LD block below. cTWAS's EM runs per region and cannot fit a block @@ -2498,19 +2612,19 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", # the previous per-region list dodged this by putting the SAME GWAS block # and the SAME gene under two region ids. geneOne <- twasWeightsRow( - variantIds = snpInfo(gh)$SNP[1:5], + variantIds = .ctp_panelSnpInfo(gh)$SNP[1:5], weights = c(0.1, -0.2, 0.05, 0.0, 0.3) ) geneTwo <- twasWeightsRow( - variantIds = snpInfo(gh)$SNP[9:13], + variantIds = .ctp_panelSnpInfo(gh)$SNP[9:13], weights = c(0.2, 0.1, -0.15, 0.05, 0.0) ) # A FLAT weight source is placed into blocks by `traitPos`, so each gene # needs the span it sits in. geneSpan <- function(i) { - bp <- snpInfo(gh)$BP[i] + bp <- .ctp_panelSnpInfo(gh)$BP[i] GenomicRanges::GRanges( - str_c("chr", snpInfo(gh)$CHR[i][[1L]]), + str_c("chr", .ctp_panelSnpInfo(gh)$CHR[i][[1L]]), IRanges::IRanges(min(bp), max(bp)) ) } @@ -2521,7 +2635,7 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", method = rep("susie", 2L), entry = list(geneOne, geneTwo), traitPos = c(geneSpan(1:5), geneSpan(9:13)), - ldSketch = gh + ldReference = gh ) # ctwasPipeline needs >= 2 blocks for the joint EM to have something to @@ -2543,7 +2657,7 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", studyName = studyName(gss), entry = list(unlist(gss)), genome = unique(unname(GenomeInfoDb::genome(gss))), - ldSketch = ldSketch(gss), + ldReference = ldReference(gss), qcInfo = qcInfo(gss), ldBlocks = twoBlocks ) @@ -2551,7 +2665,7 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", ctwasPipeline( gwasSumStats = gssTwoBlocks, twasWeights = tw, - ctwasPriorArgs = CtwasPriorParam(niter = 5L, niterPrefit = 2L), + ctwasPriorParam = CtwasPriorParam(niter = 5L, niterPrefit = 2L), # Toy panel: relax the production filters that gate out tiny # inputs. `filter_L = FALSE` used to sit here too; no ctwas # function has ever had such a formal, so .ctwasInvoke dropped it @@ -2702,8 +2816,8 @@ test_that(".ctwasFilterVariants: returns NULL when no variants survive", { test_that(".ctwasBuildWeights: maxNumVariants caps the per-gene weight matrix", { data(qtlDatasetExample) qd <- qtlDatasetExample - gh <- genotypeHandle(qd) - vids <- snpInfo(gh)$SNP[1:5] + gh <- pecotmr:::.qtlGenotypeSe(qd) + vids <- .ctp_panelSnpInfo(gh)$SNP[1:5] ent <- twasWeightsRow( variantIds = vids, weights = c(0.1, -0.2, 0.05, 0.3, 0.15) @@ -2714,7 +2828,7 @@ test_that(".ctwasBuildWeights: maxNumVariants caps the per-gene weight matrix", trait = "ENSG_example", method = "susie", entry = list(ent), - ldSketch = gh + ldReference = gh ) ldPanel <- .ctp_fullPanel(gh) wl <- pecotmr:::.ctwasBuildWeights(tw, ldPanel, maxNumVariants = 3L) @@ -2727,8 +2841,8 @@ test_that(".ctwasBuildWeights: maxNumVariants caps the per-gene weight matrix", test_that(".ctwasBuildWeights: twasWeightCutoff drops low-magnitude variants", { data(qtlDatasetExample) qd <- qtlDatasetExample - gh <- genotypeHandle(qd) - vids <- snpInfo(gh)$SNP[1:5] + gh <- pecotmr:::.qtlGenotypeSe(qd) + vids <- .ctp_panelSnpInfo(gh)$SNP[1:5] ent <- twasWeightsRow( variantIds = vids, # v1 (0.005) and v3 (0.001) will be dropped at cutoff 0.01 @@ -2740,7 +2854,7 @@ test_that(".ctwasBuildWeights: twasWeightCutoff drops low-magnitude variants", { trait = "ENSG_example", method = "susie", entry = list(ent), - ldSketch = gh + ldReference = gh ) ldPanel <- .ctp_fullPanel(gh) wl <- pecotmr:::.ctwasBuildWeights(tw, ldPanel, twasWeightCutoff = 0.01) @@ -2907,7 +3021,7 @@ test_that("assembleCtwasInputs: rejects a non-FineMappingResultBase fineMappingR assembleCtwasInputs( gwasSumStats = ss, twasWeights = list(block1 = tw), - fineMappingResult = "not a FineMappingResult" + fineMappingResult = "not a fine-mapping result" ), "must be a FineMappingResultBase" ) @@ -2927,7 +3041,7 @@ test_that("assembleCtwasInputs: skips a block whose TwasWeights lacks the resolv variantIds = ids5, weights = c(0.1, 0.2, 0.3, 0.4, 0.5) )), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) } local_mocked_bindings( @@ -3085,7 +3199,7 @@ test_that(".ctwasBuildWeights: SuSiE renormalization fires when variants are dro trait = "t1", method = "susie", entry = list(ent), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) wl <- pecotmr:::.ctwasBuildWeights(tw, panel) expect_equal(wl[[1L]]$n_wgt, 4L) @@ -3187,6 +3301,51 @@ test_that(".ctwasGetFinemapAux: no cs_95 column yields empty CS membership", { expect_equal(aux$pip[["chr1:200:A:G"]], 0.8) }) +test_that(".ctwasGetFinemapAux: a cs_95 column naming no set yields none", { + # A fit that found no credible set still reports its top loci, each one + # "in no set" (index 0). + tl <- data.frame( + variant_id = c("chr1:100:A:G", "chr1:200:A:G"), + pip = c(0.2, 0.3), + cs_95 = c("susie_0", "susie_0"), + stringsAsFactors = FALSE + ) + fmr <- QtlFineMappingResult( + studyName = "Q1", + context = "c1", + trait = "t1", + method = "susie", + entry = list(fineMappingRow(tl$variant_id, NULL, tl)) + ) + aux <- pecotmr:::.ctwasGetFinemapAux(fmr, "Q1", "c1", "t1", "susie") + expect_length(aux$csMembers, 0L) + expect_identical(aux$csPurity, numeric(0)) + expect_equal(aux$pip[["chr1:200:A:G"]], 0.3) +}) + +test_that(".ctwasRelabelFinemapAux: ids absent from the weights are kept", { + # Fine-mapping can cover variants the gene's weights do not; those keep + # their own labels. + aux <- list( + pip = c("chr1:900:G:A" = 0.4), + csMembers = list("chr1:900:G:A"), + csPurity = 0.9 + ) + expect_identical( + pecotmr:::.ctwasRelabelFinemapAux(aux, map_chr(1:3, .ctp_snpId)), + aux + ) +}) + +test_that(".ctwasFixMolecularId: rows without a gene id are left alone", { + # SNP-background rows carry variant ids, which have no trait to restore. + snps <- data.frame( + id = map_chr(1:2, .ctp_snpId), + molecular_id = c("x", "y") + ) + expect_identical(pecotmr:::.ctwasFixMolecularId(snps), snps) +}) + test_that(".ctwasGetFinemapAux: NULL input, no-match tuple, and empty topLoci all return NULL", { expect_null(pecotmr:::.ctwasGetFinemapAux(NULL, "Q1", "c1", "t1", "susie")) tl <- data.frame( @@ -3243,7 +3402,7 @@ test_that(".ctwasSnpInfoForGwasBlock: returns an empty frame when the block has studyName = "G1", entry = list(gr), genome = "hg19", - ldSketch = .ctp_makeHandle(), + ldReference = .ctp_makeHandle(), qcInfo = list(step1 = "ok") ) panelInfo <- data.frame( @@ -3354,7 +3513,7 @@ test_that(".ctwasBucketWeights: unplaced genes warn + drop; empty blocks skipped c("chr1", "chr9"), IRanges::IRanges(c(100, 100), c(150, 150)) ), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) grid <- list( chr1_1_350 = .ctp_makeGwasSumstats(), @@ -3382,7 +3541,7 @@ test_that(".ctwasBucketWeights: errors when no gene lands in any block", { method = "susie", entry = list(mkE()), traitPos = GenomicRanges::GRanges("chr9", IRanges::IRanges(100, 150)), - ldSketch = .ctp_makeHandle() + ldReference = .ctp_makeHandle() ) grid <- list( chr1_1_350 = .ctp_makeGwasSumstats(), @@ -3500,10 +3659,14 @@ test_that("resolving the LD token keeps the loader cache keys in step", { }) test_that("an ordinary LD path is left alone", { - expect_equal( - pecotmr:::.resolveCtwasLdToken("/some/real/path.pgen"), - "/some/real/path.pgen" - ) + # A token still on disk -- the caller's own file, or this session's + # sentinel -- needs nothing re-minted. + path <- withr::local_tempfile(fileext = ".ld") + file.create(path) + payload <- list( + LD_map = data.frame(region_id = "r1", LD_file = path, SNP_file = path) + ) + expect_identical(pecotmr:::.ctwasResolveLdPaths(payload), payload) noLdMap <- list(z_snp = NULL) expect_equal(pecotmr:::.ctwasResolveLdPaths(noLdMap), noLdMap) # Hand-built payloads reach the granular steps with an LD_map stub that is @@ -3536,7 +3699,7 @@ test_that("finemapCtwasRegions runs from the bundled est payload", { # ============================================================================= # ctwasPipeline shares the LD-sketch validator # -# ctwasPipeline cannot use `.ldFromSketch()` itself: it needs the whole panel +# ctwasPipeline cannot use `.ldFromRef()` itself: it needs the whole panel # rather than a matched subset, and returns per-variant variance alongside R. # It must still fail the same way when the LD reference is missing, rather # than surfacing an S4 dispatch error from deep inside. @@ -3545,7 +3708,7 @@ test_that("finemapCtwasRegions runs from the bundled est payload", { test_that("ctwas LD assembly reports a missing LD sketch like everything else", { expect_error( pecotmr:::.ctwasPanelFor(NULL), - "carries no ldSketch" + "carries no ldReference" ) expect_error( pecotmr:::.ctwasPanelFor("not a panel"), @@ -3553,9 +3716,9 @@ test_that("ctwas LD assembly reports a missing LD sketch like everything else", ) }) -test_that("the shared validator gives ctwas and .ldFromSketch one message", { +test_that("the shared validator gives ctwas and .ldFromRef one message", { shared <- tryCatch( - pecotmr:::.ldFromSketch(NULL, "chr1:1:A:G", label = "ctwasPipeline"), + pecotmr:::.ldFromRef(NULL, "chr1:1:A:G", label = "ctwasPipeline"), error = conditionMessage ) own <- tryCatch( @@ -3825,6 +3988,26 @@ test_that(".ctwasPrefitRegionFilter errors when nothing survives", { expect_equal(names(kept), "r1") }) +test_that(".ctwasPrefitRegionFilter honours min_var = 0 and min_gene = 0", { + # The est_param options reach the prefit skip too: min_var = 0 keeps a + # region of any size, and min_gene = 0 one without a gene. + regionData <- list( + r1 = list(gid = "g1", sid = character(0)), + r2 = list(gid = character(0), sid = "s1") + ) + expect_named( + pecotmr:::.ctwasPrefitRegionFilter( + regionData, + list(min_var = 0, min_gene = 0) + ), + c("r1", "r2") + ) + expect_named( + pecotmr:::.ctwasPrefitRegionFilter(regionData, list(min_var = 0)), + "r1" + ) +}) + test_that(".ctwasBlockGrFromIds places unparseable ids on chrUn", { # asGranges() warns on the unparseable id before erroring; the fallback # catches the error, and the warning is incidental to what is tested. @@ -3893,10 +4076,10 @@ test_that(".ctwasBuildSingleRegionInfo reports an empty block accurately", { test_that(".ctwasFirstPass requires an LD reference on every region", { byBlock <- pecotmr:::.ctwasGwasByBlock(.ctp_noLdGwas()) - expect_null(ldSketch(byBlock[[1L]])) + expect_null(ldReference(byBlock[[1L]])) expect_error( pecotmr:::.ctwasFirstPass("b1", byBlock, list(b1 = NULL)), - "region 'b1' carries no ldSketch" + "region 'b1' carries no ldReference" ) }) @@ -4028,3 +4211,32 @@ test_that("ctwas entry points refuse a bare list for methodArgs", { "must be built with CtwasOptions\\(\\)" ) }) + + +test_that("ctwas reads variance and LD from an LdMatrix block", { + ids <- c("chr22:100:A:G", "chr22:200:C:T", "chr22:300:G:A") + R <- matrix(c(1, 0.5, 0.2, 0.5, 1, 0.3, 0.2, 0.3, 1), 3L, 3L) + vars <- data.frame( + chrom = "chr22", + pos = c(100L, 200L, 300L), + SNP = ids, + A1 = c("G", "T", "A"), + A2 = c("A", "C", "G") + ) + bare <- LdMatrix(R, variants = vars, nSamples = 100) + # No AF: no genotype variance, which only non-standardized weights need. + panel <- .ctwasPanelFor(bare) + expect_true(all(is.na(panel$variance))) + expect_equal(unname(.ctwasPanelLd(panel)), R) + withAf <- LdMatrix( + R, + variants = transform(vars, AF = c(0.1, 0.3, 0.5)), + nSamples = 100 + ) + expect_equal( + unname(.ctwasPanelFor(withAf)$variance), + 2 * c(0.1, 0.3, 0.5) * (1 - c(0.1, 0.3, 0.5)) + ) + # An LdMatrix has no file payload to check. + expect_null(.ctwasLdPanelKey(bare)) +}) diff --git a/tests/testthat/test_ctwasWrapper.R b/tests/testthat/test_ctwasWrapper.R index 828597a63..79e0602dc 100644 --- a/tests/testthat/test_ctwasWrapper.R +++ b/tests/testthat/test_ctwasWrapper.R @@ -66,8 +66,14 @@ test_that("CtwasOptions nests one bundle per ctwas step", { expect_equal( names(a), c( - "geneZ", "regionData", "estParam", "screen", "expand", - "finemap", "merge", "boundaryGenes" + "geneZ", + "regionData", + "estParam", + "screen", + "expand", + "finemap", + "merge", + "boundaryGenes" ) ) expect_equal(a$estParam$min_group_size, 2L) @@ -110,7 +116,8 @@ test_that("the estParam bundle covers the prefit-EM fallback too", { # whose formals are NOT a subset -- so the bundle is checked against # both and .ctwasInvoke drops whichever the running step lacks. expect_s4_class( - CtwasEstParamOptions(warn_converge_fail = FALSE), "MethodOptions" + CtwasEstParamOptions(warn_converge_fail = FALSE), + "MethodOptions" ) expect_s4_class(CtwasEstParamOptions(EM_tol = 1e-4), "MethodOptions") }) @@ -144,10 +151,12 @@ test_that("step bundles refuse pecotmr's own pipeline parameters", { # silently discarded. The error names the setting that takes effect, and # it is now raised by the step that would have dropped it. expect_error( - CtwasRegionDataOptions(thin = 0.1), "CtwasPriorParam\\(thin =\\)" + CtwasRegionDataOptions(thin = 0.1), + "CtwasPriorParam\\(thin =\\)" ) expect_error( - CtwasEstParamOptions(niter = 10L), "CtwasPriorParam\\(niter =\\)" + CtwasEstParamOptions(niter = 10L), + "CtwasPriorParam\\(niter =\\)" ) expect_error( CtwasEstParamOptions(group_prior_var_structure = "shared_all"), @@ -156,6 +165,39 @@ test_that("step bundles refuse pecotmr's own pipeline parameters", { expect_error(CtwasFinemapOptions(L = 5L), "the pipeline's own") expect_error(CtwasGeneZOptions(ncore = 4L), "the pipeline's own") expect_error( - CtwasMergeOptions(maxSNP = 10L), "BoundaryMergeParam\\(maxSnp =\\)" + CtwasMergeOptions(maxSNP = 10L), + "BoundaryMergeParam\\(maxSnp =\\)" ) }) + + +test_that("a ctwas step logs warnings only to the console, all to its file", { + # ctwas logs through the logging package, which prints with cat(); the + # step below logs as ctwas does, opening a file handler for `logfile=`. + skip_if_not_installed("logging") + logFile <- withr::local_tempfile(fileext = ".log") + before <- names(logging::getLogger()[["handlers"]]) + step <- function(logfile = NULL) { + if (!is.null(logfile)) { + logging::addHandler( + logging::writeToFile, + file = logfile, + level = "DEBUG" + ) + } + logging::loginfo("step info") + logging::logwarn("step warning") + "done" + } + shown <- utils::capture.output( + res <- pecotmr:::.ctwasQuietly(step, list(logfile = logFile)) + ) + expect_identical(res, "done") + expect_false(any(grepl("step info", shown))) + expect_true(any(grepl("step warning", shown))) + expect_true(any(grepl("step info", readLines(logFile)))) + # The step's file handler is gone and the console is as it was. + expect_identical(names(logging::getLogger()[["handlers"]]), before) + after <- utils::capture.output(logging::loginfo("after the step")) + expect_true(any(grepl("after the step", after))) +}) diff --git a/tests/testthat/test_data/bgen/LICENSE_1_0.txt b/tests/testthat/test_data/bgen/LICENSE_1_0.txt new file mode 100644 index 000000000..7925d62e6 --- /dev/null +++ b/tests/testthat/test_data/bgen/LICENSE_1_0.txt @@ -0,0 +1,24 @@ +Boost Software License - Version 1.0 - August 17th, 2003 + +Permission is hereby granted, free of charge, to any person or organization +obtaining a copy of the software and accompanying documentation covered by +this license (the "Software") to use, reproduce, display, distribute, +execute, and transmit the Software, and to prepare derivative works of the +Software, and to permit third-parties to whom the Software is furnished to +do so, all subject to the following: + +The copyright notices in the Software and this entire statement, including +the above license grant, this restriction and the following disclaimer, +must be included in all copies of the Software, in whole or in part, and +all derivative works of the Software, unless such copies or derivative +works are solely in the form of machine-executable object code generated by +a source language processor. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, TITLE AND NON-INFRINGEMENT. IN NO EVENT +SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE +FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + diff --git a/tests/testthat/test_data/bgen/complex.bgen b/tests/testthat/test_data/bgen/complex.bgen new file mode 100644 index 000000000..ebeb112a6 Binary files /dev/null and b/tests/testthat/test_data/bgen/complex.bgen differ diff --git a/tests/testthat/test_data/bgen/complex.bgen.bgi b/tests/testthat/test_data/bgen/complex.bgen.bgi new file mode 100644 index 000000000..2aa1c7753 Binary files /dev/null and b/tests/testthat/test_data/bgen/complex.bgen.bgi differ diff --git a/tests/testthat/test_data/bgen/complex.sample b/tests/testthat/test_data/bgen/complex.sample new file mode 100644 index 000000000..5be9e2d0b --- /dev/null +++ b/tests/testthat/test_data/bgen/complex.sample @@ -0,0 +1,6 @@ +id +0 +sample_0 +sample_1 +sample_2 +sample_3 diff --git a/tests/testthat/test_data/bgen/complex.vcf b/tests/testthat/test_data/bgen/complex.vcf new file mode 100644 index 000000000..47e5c429a --- /dev/null +++ b/tests/testthat/test_data/bgen/complex.vcf @@ -0,0 +1,15 @@ +##fileformat=VCFv4.2 +##FORMAT= +##FORMAT= +##FORMAT= +#CHROM POS ID REF ALT QUAL FILTER INFO FORMAT sample_0 sample_1 sample_2 sample_3 +01 1 V1 A G . . . GT:GP 0:1,0 0/0:1,0,0 0/0:1,0,0 0/1:0,1,0 +01 2 V2,V2.1 A G . . . GT:GP 0:1,0 0:1,0 0:1,0 1:0,1 +01 3 V3 A G . . . GT:HP 0:1,0 1|1:0,1,0,1 0|0:1,0,1,0 0|1:1,0,0,1 +01 4 M4 A G,T . . . GT:GP 0:1,0,0 0/0:1,0,0,0,0,0 0/1:0,1,0,0,0,0 0/2:0,0,0,1,0,0 +01 5 M5 A G . . . GT:HP 0:1,0 0|0|0:1,0,1,0,1,0 0|0|1:1,0,1,0,0,1 0|1:1,0,0,1 +01 7 M6 A G,GT,GTT . . . GT:GP 0:1,0,0,0 1:0,1,0,0 2:0,0,1,0 3:0,0,0,1 +01 7 M7 A G,GT,GTT,GTTT,GTTTT . . . GT:GP 0:1,0,0,0,0,0 3:0,0,0,1,0,0 4:0,0,0,0,1,0 5:0,0,0,0,0,1 +01 8 M8 A G,GT,GTT,GTTT,GTTTT,GTTTTT . . . GT:GP 0:1,0,0,0,0,0,0 3:0,0,0,1,0,0,0 4:0,0,0,0,1,0,0 5:0,0,0,0,0,1,0 +01 9 M9 A G,GT,GTT,GTTT,GTTTT,GTTTTT,GTTTTTT . . . GT:GP 0:1,0,0,0,0,0,0,0 6:0,0,0,0,0,0,1,0 4:0,0,0,0,1,0,0,0 1/5:0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 +01 10 M10 A G . . . GT:GP 0/0/0/0:1,0,0,0,0 0/0/0/1:0,1,0,0,0 0/0/1/1:0,0,1,0,0 0/1/1/1:0,0,0,1,0 diff --git a/tests/testthat/test_data/bgen/haplotypes.bgen b/tests/testthat/test_data/bgen/haplotypes.bgen new file mode 100644 index 000000000..e96d58488 Binary files /dev/null and b/tests/testthat/test_data/bgen/haplotypes.bgen differ diff --git a/tests/testthat/test_data/bgen/haplotypes.bgen.bgi b/tests/testthat/test_data/bgen/haplotypes.bgen.bgi new file mode 100644 index 000000000..02d582c09 Binary files /dev/null and b/tests/testthat/test_data/bgen/haplotypes.bgen.bgi differ diff --git a/tests/testthat/test_data/bgen/haplotypes.haps b/tests/testthat/test_data/bgen/haplotypes.haps new file mode 100644 index 000000000..c10e3ca80 --- /dev/null +++ b/tests/testthat/test_data/bgen/haplotypes.haps @@ -0,0 +1,4 @@ +1 SNP1 RS1 1 A G 0 0 1 0 0 1 1 1 +1 SNP2 RS2 2 A G 1 0 0 1 1 1 0 0 +1 SNP3 RS3 3 A G 0 1 1 1 0 0 1 0 +1 SNP4 RS4 4 A G 1 1 0 0 1 0 0 1 diff --git a/tests/testthat/test_data/h2ParityLd.rds b/tests/testthat/test_data/h2ParityLd.rds new file mode 100644 index 000000000..acf136857 Binary files /dev/null and b/tests/testthat/test_data/h2ParityLd.rds differ diff --git a/tests/testthat/test_data/sldscUpstreamZ.rds b/tests/testthat/test_data/h2ParityZ.rds similarity index 100% rename from tests/testthat/test_data/sldscUpstreamZ.rds rename to tests/testthat/test_data/h2ParityZ.rds diff --git a/tests/testthat/test_exampleData.R b/tests/testthat/test_exampleData.R index c9e1cfd31..849d563e3 100644 --- a/tests/testthat/test_exampleData.R +++ b/tests/testthat/test_exampleData.R @@ -169,7 +169,7 @@ test_that("every estimateH2 method runs on the bundled LD references", { studyName = "trait1", entry = list(gr), genome = unique(unname(GenomeInfoDb::genome(ldScoreExample))), - ldSketch = panel + ldReference = panel ) for (method in c("sldsc", "gldsc")) { res <- estimateH2(ss, ldScoreExample, method = method) diff --git a/tests/testthat/test_fineMappingPipeline.R b/tests/testthat/test_fineMappingPipeline.R index 878667f17..0333eb86b 100644 --- a/tests/testthat/test_fineMappingPipeline.R +++ b/tests/testthat/test_fineMappingPipeline.R @@ -14,8 +14,8 @@ context("fineMappingPipeline") .fmp_makeHandle <- function(snp_n = 6L, n_samples = 40L) { new( "GenotypeHandle", - path = "/tmp/fmsketch.gds", - format = "gds", + path = "/tmp/fmsketch", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), @@ -143,7 +143,7 @@ context("fineMappingPipeline") trait = "t1", entry = list(.fmp_makeSumstatsGr()), genome = "hg19", - ldSketch = .fmp_makeHandle(), + ldReference = .fmp_makeHandle(), qcInfo = if (qc) list(step1 = "ok") else list() ) } @@ -153,7 +153,7 @@ context("fineMappingPipeline") studyName = studyName, entry = list(.fmp_makeSumstatsGr()), genome = "hg19", - ldSketch = .fmp_makeHandle(), + ldReference = .fmp_makeHandle(), qcInfo = if (qc) list(step1 = "ok") else list() ) } @@ -386,16 +386,16 @@ test_that("FineMappingMethodsParam rejects unnamed and non-list entries", { ) }) -test_that(".fmMergeUserArgs: user overrides win over capability defaults + base", { +test_that(".fmMergeUserArgs: user overrides win over the base arguments", { # base sets convergence_method = "pip"; user overrides to "objective" out <- pecotmr:::.fmMergeUserArgs( list(z = 1:3, convergence_method = "pip"), - token = "susie", userArgs = list(convergence_method = "objective", L = 1) ) expect_equal(out$convergence_method, "objective") expect_equal(out$L, 1) expect_identical(out$z, 1:3) + expect_identical(pecotmr:::.fmMergeUserArgs(list(a = 1)), list(a = 1)) }) # =========================================================================== @@ -1224,7 +1224,7 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips no-signal univ methods = "susie", cisWindow = 1000L, initializeWithSusieInf = FALSE, - signalScreenArgs = SignalScreenParam(pip = -1) + signalScreenParam = SignalScreenParam(pip = -1) ) ) # ENSG_A screened out, ENSG_B kept -> a single row. @@ -1253,7 +1253,7 @@ test_that("fineMappingPipeline( methods = "susie", cisWindow = 1000L, initializeWithSusieInf = FALSE, - crossValidationArgs = CrossValidationParam(folds = 3), + crossValidationParam = CrossValidationParam(folds = 3), verbose = 0 ) ) @@ -1429,7 +1429,7 @@ test_that("fineMappingPipeline(QtlDataset): unknown context errors", { qd <- .fmp_makeQtlDataset() expect_error( fineMappingPipeline(qd, methods = "susie", contexts = "ghost"), - "unknown context" + "no study has: ghost" ) }) @@ -1578,7 +1578,7 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip drops null contexts qd, methods = "mvsusie", cisWindow = 1000L, - signalScreenArgs = SignalScreenParam(pip = -1) + signalScreenParam = SignalScreenParam(pip = -1) ) ) # liver screened out -> the joint fit runs on brain + heart only. @@ -1608,7 +1608,7 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips mvsusie when < methods = c("susie", "mvsusie"), cisWindow = 1000L, initializeWithSusieInf = FALSE, - signalScreenArgs = SignalScreenParam(pip = -1) + signalScreenParam = SignalScreenParam(pip = -1) ) ) # mvsusie skipped (only 1 context survives); susie still produced per-context. @@ -2059,8 +2059,76 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): aggregates results across # One row per (study, context, trait, method) tuple. expect_equal(nrow(res), 2L) expect_setequal(studyName(res), c("s1", "s2")) - # Pure individual-level -> ldSketch should be NULL. - expect_null(ldSketch(res)) + # Pure individual-level -> ldReference should be NULL. + expect_null(ldReference(res)) +}) + +# A study measured in brain and liver, on the synthetic genotypes. +.fmp_twoContextStudy <- function(studyName) { + QtlDataset( + studyName = studyName, + genotypes = .fmp_makeHandle(), + phenotypes = list( + brain = .fmp_makeSe(traits = c("ENSG_A", "ENSG_B")), + liver = .fmp_makeSe(traits = c("ENSG_A", "ENSG_B")) + ), + genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) + ) +} + +test_that("fineMappingPipeline(MultiStudy): list selections stay per study", { + # Every study used to get the selection whole: list(A = "ENSG_B") also + # restricted B to ENSG_B, and list(B = "brain") restricted A to brain. + mt <- MultiStudyQtlDataset( + qtlDatasets = list( + A = .fmp_twoContextStudy("A"), + B = .fmp_twoContextStudy("B") + ) + ) + local_mocked_bindings( + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieIndiv = .fmp_mockFitIndiv(), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr" + ) + res <- suppressMessages(fineMappingPipeline( + mt, + methods = "susie", + traitId = list(A = "ENSG_B"), + contexts = list(B = "brain"), + cisWindow = 1000L, + initializeWithSusieInf = FALSE + )) + expect_setequal( + paste(res$study, res$context, res$trait), + c( + "A brain ENSG_B", + "A liver ENSG_B", + "B brain ENSG_A", + "B brain ENSG_B" + ) + ) +}) + +test_that("fineMappingPipeline(QtlDataset): traitId chosen per context", { + local_mocked_bindings( + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieIndiv = .fmp_mockFitIndiv(), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr" + ) + res <- suppressMessages(fineMappingPipeline( + .fmp_twoContextStudy("A"), + methods = "susie", + traitId = list(A = list(brain = "ENSG_B")), + cisWindow = 1000L, + initializeWithSusieInf = FALSE + )) + # brain keeps only ENSG_B; liver, which the list does not name, keeps both. + expect_setequal( + paste(res$context, res$trait), + c("brain ENSG_B", "liver ENSG_A", "liver ENSG_B") + ) }) test_that("fineMappingPipeline(MultiStudyQtlDataset): per-study options are not dropped", { @@ -2216,7 +2284,7 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): jointRegions=FALSE merges expect_equal(names(fit), c("region1", "region2")) }) -test_that("fineMappingPipeline(MSQD): embedded sumstats record ldSketch", { +test_that("fineMappingPipeline(MSQD): embedded sumstats record ldReference", { qd <- QtlDataset( studyName = "s1", genotypes = .fmp_makeHandle(), @@ -2243,7 +2311,7 @@ test_that("fineMappingPipeline(MSQD): embedded sumstats record ldSketch", { expect_s4_class(res, "QtlFineMappingResult") expect_true(nrow(res) >= 2L) # Embedded sumstats has an LD sketch -> the merged result carries it. - expect_s4_class(ldSketch(res), "RangedSummarizedExperiment") + expect_s4_class(ldReference(res), "RangedSummarizedExperiment") }) # =========================================================================== @@ -2280,9 +2348,14 @@ test_that("fineMappingPipeline(QtlSumStats): un-QCd input rejected", { test_that("fineMappingPipeline(QtlSumStats): empty selection rejected", { ss <- .fmp_makeQtlSumStats() expect_error( - fineMappingPipeline(ss, methods = "susie", contexts = "ghost"), + fineMappingPipeline(ss, methods = "susie", traitId = "ghost"), "no entries matched" ) + # A context no study has is caught earlier, when the selection is parsed. + expect_error( + fineMappingPipeline(ss, methods = "susie", contexts = "ghost"), + "no study has: ghost" + ) }) # =========================================================================== @@ -2309,6 +2382,36 @@ test_that("fineMappingPipeline(GwasSumStats): runs end-to-end with mocked RSS fi expect_setequal(methodNames(res), "susie") }) +test_that("fineMappingPipeline(GwasSumStats): opaque blockId, entry's span", { + local_mocked_bindings( + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieRss = .fmp_mockFitRss(), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr" + ) + regionOf <- function(blockId) { + gss <- GwasSumStats( + studyName = "G1", + entry = list(.fmp_makeSumstatsGr()), + genome = "hg19", + ldReference = .fmp_makeHandle(), + blockId = blockId, + qcInfo = list(step1 = "ok") + ) + res <- suppressMessages(fineMappingPipeline( + gss, + methods = "susie", + initializeWithSusieInf = FALSE + )) + reg <- genomicRegion(res) + c(GenomicRanges::start(reg), GenomicRanges::end(reg)) + } + # A blockId spelling coordinates is the region's boundary; an opaque + # label says nothing, so the region is the entry's own variant span. + expect_equal(regionOf("chr1_50_600"), c(50L, 600L)) + expect_equal(regionOf("block1"), c(100L, 500L)) +}) + test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { # Regression for top_loci$N == 1. The RSS path must forward the per-variant # effective N (the entry's N column, aligned to the analysed variants) to @@ -2335,7 +2438,7 @@ test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { studyName = "G1", entry = list(gr), genome = "hg19", - ldSketch = .fmp_makeHandle(), + ldReference = .fmp_makeHandle(), qcInfo = list(step1 = "ok") ) captured <- new.env(parent = emptyenv()) @@ -2399,7 +2502,7 @@ test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { studyName = studyName, entry = list(GenomicRanges::GRanges()), genome = "hg19", - ldSketch = .fmp_makeHandle(), + ldReference = .fmp_makeHandle(), qcInfo = list( entryAudit = list(list( pipScreenSkipped = TRUE, @@ -2421,6 +2524,22 @@ test_that("fineMappingPipeline(GwasSumStats): a PIP-screened region yields an em ) expect_s4_class(res, "GwasFineMappingResult") expect_equal(nrow(res), 0L) # graceful skip, not stop("no ... tuples") + # An audit recording the skip but no reason gets the screen's own. + noReason <- GwasSumStats( + studyName = "G1", + entry = list(GenomicRanges::GRanges()), + genome = "hg19", + ldReference = .fmp_makeHandle(), + qcInfo = list(entryAudit = list(list(pipScreenSkipped = TRUE))) + ) + expect_message( + fineMappingPipeline( + noReason, + methods = "susie", + initializeWithSusieInf = FALSE + ), + "skipped: no signal above the PIP pre-screen cutoff" + ) }) test_that("fineMappingPipeline(GwasSumStats): mixed screened + real keeps only the real region", { @@ -2428,7 +2547,7 @@ test_that("fineMappingPipeline(GwasSumStats): mixed screened + real keeps only t studyName = c("Gskip", "Greal"), entry = list(GenomicRanges::GRanges(), .fmp_makeSumstatsGr()), genome = "hg19", - ldSketch = .fmp_makeHandle(), + ldReference = .fmp_makeHandle(), qcInfo = list( entryAudit = list( list(pipScreenSkipped = TRUE, pipScreenReason = "no signal"), @@ -2458,7 +2577,7 @@ test_that("fineMappingPipeline(GwasSumStats): a 0-variant entry is skipped even studyName = "G1", entry = list(GenomicRanges::GRanges()), genome = "hg19", - ldSketch = .fmp_makeHandle(), + ldReference = .fmp_makeHandle(), qcInfo = list(step1 = "ok") ) res <- suppressMessages( @@ -2479,7 +2598,7 @@ test_that("fineMappingPipeline(QtlSumStats): a screened trait is skipped gracefu trait = "t1", entry = list(GenomicRanges::GRanges()), genome = "hg19", - ldSketch = .fmp_makeHandle(), + ldReference = .fmp_makeHandle(), qcInfo = list( entryAudit = list(list( pipScreenSkipped = TRUE, @@ -3046,7 +3165,7 @@ test_that("fineMappingPipeline(ANY): unsupported input class errors", { trait = c("t1", "t1"), entry = list(e1, e2), genome = "hg19", - ldSketch = .fmp_makeHandle(), + ldReference = .fmp_makeHandle(), qcInfo = list(step1 = "ok") ) } @@ -3071,7 +3190,7 @@ test_that("fineMappingPipeline( trait = c("t1", "t2"), entry = list(.fmp_makeSumstatsGr(), .fmp_makeSumstatsGr()), genome = "hg19", - ldSketch = .fmp_makeHandle(), + ldReference = .fmp_makeHandle(), qcInfo = list(step1 = "ok") ) expect_error( @@ -3125,7 +3244,7 @@ test_that("fineMappingPipeline(QtlSumStats): cache hit short-circuits the RSS fi trait = "t1", method = "susie", entry = list(cachedEntry), - ldSketch = .fmp_makeHandle() + ldReference = .fmp_makeHandle() ) rss_calls <- 0 local_mocked_bindings( @@ -3173,7 +3292,7 @@ test_that("fineMappingPipeline(GwasSumStats): cache hit short-circuits the RSS f method = "susie", blockId = "chr1_100_500", entry = list(cachedEntry), - ldSketch = .fmp_makeHandle() + ldReference = .fmp_makeHandle() ) rss_calls <- 0 local_mocked_bindings( @@ -3387,10 +3506,10 @@ test_that(".fmResidGeno / .fmResidPheno forward the bundle to the accessors", { ) # Passed, not scraped: the settings reach the accessors because the # caller hands them over, with no enclosing frame involved. - pecotmr:::.fmResidGeno(NULL, contexts = "c1", residualizationArgs = res) - pecotmr:::.fmResidPheno(NULL, contexts = "c1", residualizationArgs = res) + pecotmr:::.fmResidGeno(NULL, contexts = "c1", residualizationParam = res) + pecotmr:::.fmResidPheno(NULL, contexts = "c1", residualizationParam = res) for (captured in list(capturedGeno, capturedPheno)) { - got <- captured$residualizationArgs + got <- captured$residualizationParam expect_s4_class(got, "ResidualizationParam") expect_equal(got$phenotypeCovariates, "age") expect_false(got$residualizePhenotype) @@ -3407,10 +3526,10 @@ test_that("an absent bundle becomes the constructor's own defaults", { }, .package = "pecotmr" ) - pecotmr:::.fmResidPheno(NULL, contexts = "c1", residualizationArgs = NULL) - expect_s4_class(captured$residualizationArgs, "ResidualizationParam") + pecotmr:::.fmResidPheno(NULL, contexts = "c1", residualizationParam = NULL) + expect_s4_class(captured$residualizationParam, "ResidualizationParam") # Nothing pinned: every flag is unset, which the accessors read as "on". - expect_length(captured$residualizationArgs, 0L) + expect_length(captured$residualizationParam, 0L) }) # =========================================================================== @@ -3517,6 +3636,25 @@ test_that(".fmMergeEntries returns a single entry unchanged", { expect_identical(pecotmr:::.fmMergeEntries(list(e)), e) }) +test_that(".fmMergeEntries renumbers past a region with no cs column", { + # A region whose fit found no set reports its top loci without a cs_95 + # column; it adds no sets, so the next region's numbering continues. + mk <- function(vids, cs95 = NULL) { + tl <- data.frame(variant_id = vids, pip = rep(0.5, length(vids))) + if (!is.null(cs95)) { + tl$cs_95 <- cs95 + } + fineMappingRow(variantIds = vids, susieFit = NULL, topLoci = tl) + } + m <- pecotmr:::.fmMergeEntries(list( + mk("chr1:100:A:G", "susie_1"), + mk("chr1:200:A:G"), + mk("chr1:300:A:G", "susie_1") + )) + tl <- pecotmr:::.fmrPartsTopLoci(m) + expect_equal(tl$cs_95, c("susie_1", NA, "susie_2")) +}) + test_that("fineMappingPipeline(QtlDataset): region + cisWindow is rejected", { qd <- .fmp_makeQtlDataset() expect_error( @@ -3764,6 +3902,17 @@ test_that(".fmBuildMvsusiePriorCv: NULL CV -> NULL; NULL fold fits are skipped", expect_null(out[["2"]]) # NULL fold -> next (831) }) +test_that(".fmFoldFitAt finds a fold's fit by name, else by position", { + fn <- pecotmr:::.fmFoldFitAt + named <- list(fold_2 = "fit2", fold_1 = "fit1") + expect_equal(fn(1L, c(1, 2), named), "fit1") + # Fits not named fold_ are taken in fold order, and a fold beyond + # them has none. + unnamed <- list("first", "second") + expect_equal(fn(2L, c(1, 2), unnamed), "second") + expect_null(fn(3L, c(1, 2, 3), unnamed)) +}) + test_that(".fmTopPcScores: PCA scores for multi-trait Y; degenerate inputs -> NULL", { expect_null(pecotmr:::.fmTopPcScores(matrix(1, 5, 1), 2L)) # < 2 traits expect_null(pecotmr:::.fmTopPcScores(matrix(c(1, NA), 2, 2), 2L)) # < 2 complete @@ -3893,6 +4042,53 @@ test_that("fineMappingPipeline(QtlSumStats): mvsusie-only jointSpec returns the expect_setequal(as.character(res$method), "mvsusie") # 1843-1857 }) +test_that("fineMappingPipeline(QtlSumStats): joint spec plus per-entry susie", { + # The joint spec consumes mvsusie; susie, asked for alongside it, still + # runs per entry, and the two results are combined. + ss <- .fmp_makeQtlSumStats() + jr <- QtlFineMappingResult( + studyName = "Q1", + context = "c1", + trait = "t1", + method = "mvsusie", + entry = list(fineMappingRow( + "chr1:100:A:G", + list(), + data.frame(variant_id = "chr1:100:A:G", pip = 0.9) + )) + ) + local_mocked_bindings( + .fmDispatchJointSpecsQtlSumStats = function(...) jr, + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieRss = .fmp_mockFitRss(), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr" + ) + res <- suppressMessages(fineMappingPipeline( + ss, + methods = c("mvsusie", "susie"), + jointSpecification = "context" + )) + expect_s4_class(res, "QtlFineMappingResult") + expect_equal(sum(res$method == "mvsusie"), 1L) + expect_equal(sum(res$method == "susie"), nrow(ss)) +}) + +test_that("fineMappingPipeline(QtlSumStats): no auto-joint fit is an error", { + # Without a joint spec mvsusie is fit by the automatic cross-context + # joint; with no other method to run, a joint that produces nothing + # leaves no result at all. + ss <- .fmp_makeMultiCtxQtlSumStats() + local_mocked_bindings( + .fmDispatchJointSpecsQtlSumStats = function(...) NULL, + .package = "pecotmr" + ) + expect_error( + suppressMessages(fineMappingPipeline(ss, methods = "mvsusie")), + "no entries produced a result" + ) +}) + test_that("fineMappingPipeline(QtlSumStats): mvsusie-only jointSpec with no fits -> error", { ss <- .fmp_makeQtlSumStats() local_mocked_bindings( @@ -3996,6 +4192,106 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): mvsusie-only jointSpec ret expect_setequal(as.character(res$method), "mvsusie") # 1709-1726 }) +test_that("fineMappingPipeline(MultiStudy): joint spec, rest per component", { + # The joint spec consumes mvsusie; susie, asked for alongside it, still + # runs on every component -- the study and the embedded sumstats. + mt <- .fmp_makeMultiStudy() + jr <- QtlFineMappingResult( + studyName = "study1", + context = "brain", + trait = "ENSG_A", + method = "mvsusie", + entry = list(fineMappingRow( + "chr1:100:A:G", + list(), + data.frame(variant_id = "chr1:100:A:G", pip = 0.9) + )) + ) + local_mocked_bindings( + .fmDispatchJointSpecsMultiStudy = function(...) jr, + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieIndiv = .fmp_mockFitIndiv(), + .fmFitSusieRss = .fmp_mockFitRss(), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr" + ) + res <- suppressMessages(fineMappingPipeline( + mt, + methods = c("mvsusie", "susie"), + jointSpecification = "context", + cisWindow = 1000L, + initializeWithSusieInf = FALSE + )) + expect_s4_class(res, "QtlFineMappingResult") + expect_equal(sum(res$method == "mvsusie"), 1L) + expect_gt(sum(res$method == "susie"), 1L) +}) + +test_that("fineMappingPipeline(MultiStudy): an unselected component sits out", { + # One context vector applies to every component; one lacking it keeps + # none of its tuples and contributes no rows. + mt <- .fmp_makeMultiStudy() + local_mocked_bindings( + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieIndiv = .fmp_mockFitIndiv(), + .fmFitSusieRss = .fmp_mockFitRss(), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr" + ) + fit <- function(contexts) { + suppressMessages(fineMappingPipeline( + mt, + methods = "susie", + contexts = contexts, + cisWindow = 1000L, + initializeWithSusieInf = FALSE + )) + } + expect_warning( + sumstatsOnly <- fit("c1"), + "study 'study1' is missing requested context\\(s\\): c1" + ) + expect_setequal(as.character(sumstatsOnly$study), "Q1") + expect_warning( + studyOnly <- fit("brain"), + "study 'Q1' is missing requested context\\(s\\): brain" + ) + expect_setequal(as.character(studyOnly$study), "study1") +}) + +test_that("fineMappingPipeline(MultiStudy): joint rows record scale override", { + # The study's own slot scales its residuals; the per-call override says + # otherwise and wins, and the joint rows record what was used. + mt <- .fmp_makeMultiStudy() + jr <- QtlFineMappingResult( + studyName = "study1", + context = "brain", + trait = "ENSG_A", + method = "mvsusie", + entry = list(fineMappingRow( + "chr1:100:A:G", + list(), + data.frame(variant_id = "chr1:100:A:G", pip = 0.9) + )) + ) + local_mocked_bindings( + .fmDispatchJointSpecsMultiStudy = function(...) jr, + .package = "pecotmr" + ) + fit <- function(residualizationParam) { + suppressMessages(fineMappingPipeline( + mt, + methods = "mvsusie", + jointSpecification = "context", + residualizationParam = residualizationParam + )) + } + expect_true(fit(ResidualizationParam())$standardized) + expect_false( + fit(ResidualizationParam(scaleResiduals = FALSE))$standardized + ) +}) + # ============================================================================= # Coverage top-ups (mock the fitters, exercise the orchestration) # ============================================================================= @@ -4705,7 +5001,7 @@ test_that("fineMappingPipeline RSS cutoffs agree with .panelVariantFilter", { ids <- variantIds(ss) for (cut in c(0.05, 0.2)) { expected <- length(.panelVariantFilter( - ldSketch(ss), + ldReference(ss), ids, PanelFilterParam(mafCutoff = cut) )) @@ -4719,7 +5015,7 @@ test_that("fineMappingPipeline RSS cutoffs agree with .panelVariantFilter", { test_that("fineMappingPipeline RSS treats MAC as a MAF equivalent", { ss <- .rssf_qcd() - nSamp <- ncol(ldSketch(ss)) + nSamp <- ncol(ldReference(ss)) expect_equal( .rssf_n(ss, macCutoff = 0.1 * 2 * nSamp), .rssf_n(ss, mafCutoff = 0.1) @@ -4736,12 +5032,12 @@ test_that("fineMappingPipeline RSS honours a missingness cutoff", { test_that(".fmExtractZn keeps z, ids and n aligned after filtering", { ss <- .rssf_qcd() entry <- pecotmr:::.collectionEntry(ss, 1L) - sketch <- ldSketch(ss) + sketch <- ldReference(ss) unfiltered <- pecotmr:::.fmExtractZn(entry, "t") filtered <- suppressMessages(pecotmr:::.fmExtractZn( entry, "t", - ldSketch = sketch, + ldReference = sketch, cutoffs = list(mafCutoff = 0.2, macCutoff = 0, imissCutoff = 1) )) expect_lt(length(filtered$variantIds), length(unfiltered$variantIds)) @@ -4897,6 +5193,18 @@ test_that("mvsusie becomes checkable on the individual-level path", { ) }) +test_that("a method with no engine for the input is left to the components", { + # A multi-study run checks against the summary-statistics engine, which + # fsusie lacks; its arguments are checked by the per-study recursion, + # whose engine is susiF. + expect_silent( + pecotmr:::.fmCheckMethodArgsForInput( + list(fsusie = list(anyName = 1)), + "MultiStudyQtlDataset" + ) + ) +}) + test_that("pecotmr's own seeded arguments are not checked against the engine", { skip_if_not_installed("susieR") # L_greedy is a pecotmr concept seeded onto susie-family tokens; it is not @@ -4953,46 +5261,23 @@ test_that(".fmRssArgsResolved fills rFinite without leaving the class", { 99 ) }, - .ldSketchNSamples = function(x) 4321L, + .ldRefNSamples = function(x) 4321L, .package = "pecotmr" ) }) -test_that("a path-exact method constructor refuses the other path's names", { - skip_if_not_installed("susieR") - indiv <- pecotmr:::.fmTokenPathConfig("susie", "QtlDataset") - sumst <- pecotmr:::.fmTokenPathConfig("susie", "QtlSumStats") - # `z` is a susie_rss argument and not a susie one. - expect_error(indiv(z = 1), "unknown argument") - expect_no_error(sumst(z = 1)) - # `y` is susie-only, so the mirror image holds. - expect_no_error(indiv(y = 1)) - expect_error(sumst(y = 1), "unknown argument") - # A name both callees accept is fine either way. - expect_no_error(indiv(L = 5)) - expect_no_error(sumst(L = 5)) - # Why this matters: the retired aggregator validated against the UNION - # of both callees, so it accepted `z` even for an individual-level run - # and the setting reached an engine that never reads it. - both <- pecotmr:::.engineAcceptedNames( - c("susieR::susie", "susieR::susie_rss") - ) - expect_true(is_in("z", both)) - expect_false(is_in("z", pecotmr:::.engineAcceptedNames("susieR::susie"))) -}) - test_that("each input path offers only the methods it implements", { expect_setequal( - names(pecotmr:::.fmMethodCtorsFor("QtlDataset")), + pecotmr:::.fmMethodsFor("QtlDataset"), c("susie", "susieInf", "susieAsh", "mvsusie", "fsusie") ) expect_setequal( - names(pecotmr:::.fmMethodCtorsFor("QtlSumStats")), + pecotmr:::.fmMethodsFor("QtlSumStats"), c("susie", "susieInf", "susieAsh", "ser", "mvsusie") ) # fsusie has no summary-statistics implementation; ser no individual one. - expect_null(pecotmr:::.fmTokenPathConfig("fsusie", "QtlSumStats")) - expect_null(pecotmr:::.fmTokenPathConfig("ser", "QtlDataset")) + expect_null(pecotmr:::.fmMethodCalleeFor("fsusie", "QtlSumStats")) + expect_null(pecotmr:::.fmMethodCalleeFor("ser", "QtlDataset")) }) test_that("CredibleSetParam owns the single-effect bounds", { @@ -5083,12 +5368,12 @@ test_that("every recursion forwards each cfg field its callee accepts", { ), list( site = ".twasPerStudy", - builder = ".twasMsDriver", + builder = ".twasMsCfg", callee = ".twasPipelineQtlDataset" ), list( site = ".twasSumStats", - builder = ".twasMsDriver", + builder = ".twasMsCfg", callee = ".twasPipelineQtlSumStats" ) ) @@ -5117,6 +5402,108 @@ test_that("every recursion forwards each cfg field its callee accepts", { } }) +test_that("MultiStudyQtlDataset takes every component argument", { + # Same contract as the TWAS twin: every argument a component method takes + # is a MultiStudy argument, and the record handed to the components + # carries it (the test above checks record -> component). + ms <- .methodFormalNames("fineMappingPipeline", "MultiStudyQtlDataset") + comp <- union( + .methodFormalNames("fineMappingPipeline", "QtlDataset"), + .methodFormalNames("fineMappingPipeline", "QtlSumStats") + ) + expect_equal(setdiff(comp, ms), character(0)) + expect_equal(setdiff(ms, comp), character(0)) + expect_equal( + setdiff( + ms, + c(.cfgFieldNames(".fmPipelineMultiStudy"), "jointSpecification") + ), + character(0) + ) +}) + +test_that("QtlDataset: a CV-only run keeps the CV and skips the full fit", { + skip_if_not_installed("susieR") + qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + # The full-data post-processor stops the test if it is reached: a + # cross-validation-only run must not fit, or summarize, the full data. + local_mocked_bindings( + extractBlockGenotypes = .fmp_mockExtractor(), + .fmPostprocessOne = function(...) stop("the full-data fit ran"), + .package = "pecotmr" + ) + res <- suppressMessages(fineMappingPipeline( + qd, + methods = "susie", + cisWindow = 1000L, + initializeWithSusieInf = FALSE, + crossValidationParam = CrossValidationParam( + folds = 3, + fitFullData = FALSE + ), + verbose = 0 + )) + expect_equal(nrow(res), 1L) + expect_equal(lengths(res), 0L) + expect_null(susieFit( + res, + studyName = "study1", + context = "brain", + trait = "ENSG_A", + method = "susie" + )) + cv <- cvResult( + res, + studyName = "study1", + context = "brain", + trait = "ENSG_A", + method = "susie" + ) + expect_true("susie_predicted" %in% names(cv$prediction)) + # Fold-level results cannot be published, so the export refuses. + expect_error(exportToBed(res, tempfile(fileext = ".bed")), "fitFullData") +}) + +test_that(".fmMergeEntries keeps a merged cross-validation-only row fit-free", { + # A list of per-region NULL fits would read as a fit; a merged row with no + # full-data fit in any region keeps NULL, and each region's CV. + cv <- list(samplePartition = data.frame(Sample = "s1", Fold = 1L)) + merged <- pecotmr:::.fmMergeEntries(list( + pecotmr:::.fmCvOnlyRow(cv), + pecotmr:::.fmCvOnlyRow(cv) + )) + expect_null(pecotmr:::.fmrPartsSusieFit(merged)) + expect_length(pecotmr:::.fmrPartsVariantIds(merged), 0L) + expect_named(cvResult(merged), c("region1", "region2")) +}) + +test_that(".fmCacheForRun reuses only rows that carry what the run asks for", { + vid <- "chr1:100:A:G" + tl <- tibble::tibble(variant_id = vid, pip = 0.5) + cv <- list(samplePartition = data.frame(Sample = "s1", Fold = 1L)) + cache <- QtlFineMappingResult( + studyName = rep("s", 3L), + context = rep("c", 3L), + trait = c("fullCv", "full", "cvOnly"), + method = rep("susie", 3L), + entry = list( + fineMappingRow(vid, list(a = 1), tl, cvResult = cv), + fineMappingRow(vid, list(a = 1), tl), + pecotmr:::.fmCvOnlyRow(cv) + ) + ) + kept <- function(cvp) { + out <- pecotmr:::.fmCacheForRun(cache, pecotmr:::.cvResolve(cvp)) + as.character(out$trait) + } + expect_equal(kept(CrossValidationParam()), c("fullCv", "full")) + expect_equal(kept(CrossValidationParam(folds = 3)), "fullCv") + expect_equal( + kept(CrossValidationParam(folds = 3, fitFullData = FALSE)), + c("fullCv", "cvOnly") + ) +}) + test_that("CredibleSetParam accessors read and replace, L is get-only", { cs <- CredibleSetParam(coverage = 0.95) expect_equal(csCoverage(cs), 0.95) @@ -5385,7 +5772,6 @@ test_that(".fmBlockWindow falls back to the trait's own cis window", { tid <- rownames(molecularTraits(qtlDatasetExample, contexts = ctx))[[1L]] narrow <- .fmBlockWindow(NULL, ctx, tid, cfgNarrow) wide <- .fmBlockWindow(NULL, ctx, tid, cfgWide) - skip_if(is.null(narrow) || is.null(wide)) expect_lt(GenomicRanges::start(wide), GenomicRanges::start(narrow)) expect_gt(GenomicRanges::end(wide), GenomicRanges::end(narrow)) expect_identical( @@ -5513,28 +5899,19 @@ test_that("no pipeline takes a weight-scale declaration any more", { }) test_that(".fmMsDataSource leaves a mixed collection's joint rows NA", { - mixed <- structure(list(), class = "fmprov_mixed") - local_mocked_bindings( - qtlDatasets = function(x, ...) list(1), - sumStats = function(x, ...) list(1), - .package = "pecotmr" - ) - expect_true(is.na(pecotmr:::.fmMsDataSource(mixed))) + expect_true(is.na(pecotmr:::.fmMsDataSource(.fmp_makeMultiStudy()))) }) -test_that(".fmMsDataSource derives a single-kind collection's joint rows", { - local_mocked_bindings( - qtlDatasets = function(x, ...) list(), - sumStats = function(x, ...) list(1), - .package = "pecotmr" - ) - expect_equal(pecotmr:::.fmMsDataSource(NULL), "sumstat") - local_mocked_bindings( - qtlDatasets = function(x, ...) list(1), - sumStats = function(x, ...) list(), - .package = "pecotmr" +test_that(".fmMsDataSource gives an individual-level collection's joint rows", { + # A collection always holds individual-level studies (its validity + # requires one), so without summary statistics its joint rows are those. + mt <- MultiStudyQtlDataset( + qtlDatasets = list( + A = .fmp_twoContextStudy("A"), + B = .fmp_twoContextStudy("B") + ) ) - expect_equal(pecotmr:::.fmMsDataSource(NULL), "individual") + expect_equal(pecotmr:::.fmMsDataSource(mt), "individual") }) test_that("individual-level genotypes reach the fitter standardized", { @@ -5579,7 +5956,7 @@ test_that("the genotype scale comes from the accessor, not the pipeline", { dataset, methods = "susie", cisWindow = 1e6, - residualizationArgs = ResidualizationParam(...) + residualizationParam = ResidualizationParam(...) )) unique(as.logical(S4Vectors::mcols(res)$standardized)) } @@ -5615,3 +5992,202 @@ test_that("the hatch does not reach a summary-statistics fit", { )) expect_true(all(as.logical(S4Vectors::mcols(res)$standardized))) }) + +# ---- joint fits receive the caller's settings ------------------------------ + +test_that("QtlDataset: joint fits get every caller setting", { + # The joint engine reads residualization from its `args`. The dispatcher + # filed it only in the pipeline config, which nothing reads, so joint fits + # ran on default residualization while the result recorded the caller's + # scaling as its provenance. + cap <- new.env(parent = emptyenv()) + .captureJointEngine(cap) + rp <- ResidualizationParam(scaleResiduals = FALSE) + expect_error( + suppressMessages(fineMappingPipeline( + .fmp_makeQtlDataset(contexts = c("brain", "liver")), + methods = "mvsusie", + traitId = "ENSG_A", + cisWindow = 1000L, + jointSpecification = "context", + residualizationParam = rp, + crossValidationParam = CrossValidationParam(folds = 3), + signalScreenParam = SignalScreenParam(pip = 0.1), + fitRetention = "full", + seed = 7L + )), + "no joint fits produced" + ) + ind <- .capturedCall(cap, "individual") + expect_identical(ind$args$residualizationParam, rp) + expect_equal(ind$config$crossValidationParam$folds, 3) + expect_equal(ind$config$fitRetention, "full") + expect_equal(ind$config$seed, 7L) + expect_equal( + ind$args$pipCutoffToSkip, + pecotmr:::.screenResolve(SignalScreenParam(pip = 0.1)) + ) +}) + +test_that("MultiStudyQtlDataset: per-study joint fits get every setting", { + # The per-study joint dispatch re-listed its own subset of the settings + # and dropped cross-validation, residualization, the signal screen, + # fitRetention, the seed and the genotype-filter overrides. + cap <- new.env(parent = emptyenv()) + .captureJointEngine(cap) + rp <- ResidualizationParam(scaleResiduals = FALSE) + expect_error( + suppressMessages(fineMappingPipeline( + .fmp_makeMultiStudy(), + methods = "mvsusie", + cisWindow = 1000L, + jointSpecification = "context", + residualizationParam = rp, + crossValidationParam = CrossValidationParam(folds = 3), + signalScreenParam = SignalScreenParam(pip = 0.1), + genotypeFilterParam = GenotypeFilterParam(mafCutoff = 0.05), + fitRetention = "full", + seed = 7L + )), + "no joint fits produced" + ) + ind <- .capturedCall(cap, "individual") + expect_identical(ind$args$residualizationParam, rp) + expect_equal(ind$config$crossValidationParam$folds, 3) + expect_equal(ind$config$fitRetention, "full") + expect_equal(ind$config$seed, 7L) + expect_equal( + ind$args$pipCutoffToSkip, + pecotmr:::.screenResolve(SignalScreenParam(pip = 0.1)) + ) + expect_equal(mafCutoff(ind$data), 0.05) +}) + +test_that("MultiStudyQtlDataset: cross-study joint fits get their settings", { + # The cross-study dispatch omitted fitRetention, which has no default + # further down, so any study-axis spec failed before fitting anything. + cap <- new.env(parent = emptyenv()) + .captureJointEngine(cap) + panel <- PanelFilterParam(mafCutoff = 0.05) + expect_error( + suppressMessages(fineMappingPipeline( + .fmp_makeMultiStudy(), + methods = "mvsusie", + jointSpecification = "study", + fitRetention = "full", + panelFilterParam = panel + )), + "no joint fits produced" + ) + ss <- .capturedCall(cap, "sumstats") + expect_equal(ss$config$fitRetention, "full") + expect_equal(ss$args$cutoffs, pecotmr:::.panelCutoffs(panel)) +}) + + +# ============================================================================= +# The LD reference dispatch: an LdMatrix or a GenotypeMixture as ldReference +# ============================================================================= + +# The bundled GWAS collection, with its panel's LD copied into an LdMatrix +# and used as the reference instead. +.fmp_withLdMatrix <- function(gss, nSamples = ncol(ldReference(gss))) { + panel <- ldReference(gss) + ld <- LdMatrix( + unname(computeLd(panel)), + variants = SummarizedExperiment::rowRanges(panel), + nSamples = nSamples + ) + GwasSumStats( + studyName = studyName(gss), + entry = list(.collectionEntry(gss, 1L)), + genome = "hg19", + ldReference = ld, + qcInfo = qcInfo(gss) + ) +} + +# @noRd +.fmp_fitSusie <- function(x) { + suppressWarnings(suppressMessages(fineMappingPipeline( + x, + methods = "susie", + initializeWithSusieInf = FALSE + ))) +} + +test_that("fine-mapping with an LdMatrix reference matches its panel", { + # Every step reads LD through the reference dispatch, so a matrix holding + # the panel's LD gives the panel's fit. + data(gwasSumStatsS4Example) + gss <- gwasSumStatsS4Example + withLd <- .fmp_withLdMatrix(gss) + viaMatrix <- .fmp_fitSusie(withLd) + # The panel's fit reads the panel's factor; the matrix's reads the matrix. + viaPanel <- .fmp_fitSusie(gss) + expect_equal(pip(viaMatrix), pip(viaPanel)) + expect_equal(credibleSets(viaMatrix), credibleSets(viaPanel)) + expect_s4_class(ldReference(viaMatrix), "LdMatrix") +}) + +test_that("an RSS block reads a genotype reference's factor, not its LD", { + data(gwasSumStatsS4Example) + gss <- gwasSumStatsS4Example + panel <- ldReference(gss) + ids <- names(SummarizedExperiment::rowRanges(panel))[1:25] + plain <- .fmRssLd(panel, ids, "susie", FALSE) + expect_null(plain$R) + expect_equal( + crossprod(plain$X) / (nrow(plain$X) - 1), + .ldFromRef(panel, ids, label = "t") + ) + # susieInf (and a chain initialised from it) and susieAsh need the matrix. + for (toRun in list(c("susie", "susieInf"), "susieAsh")) { + both <- .fmRssLd(panel, ids, toRun, TRUE) + expect_equal(both$R, .ldFromRef(panel, ids, label = "t")) + expect_identical(both$X, plain$X) + } + ldOnly <- .fmRssLd(ldReference(.fmp_withLdMatrix(gss)), ids, "susie", FALSE) + expect_null(ldOnly$X) + expect_equal(ldOnly$R, .ldFromRef(panel, ids, label = "t")) +}) + +test_that("fine-mapping runs on a GenotypeMixture reference", { + data(gwasSumStatsS4Example) + gss <- gwasSumStatsS4Example + panel <- ldReference(gss) + mix <- GenotypeMixture( + list(a = panel[, 1:80], b = panel[, 81:165]), + mixtureWeights = c(0.5, 0.5) + ) + withMix <- GwasSumStats( + studyName = studyName(gss), + entry = list(.collectionEntry(gss, 1L)), + genome = "hg19", + ldReference = mix, + qcInfo = qcInfo(gss) + ) + res <- .fmp_fitSusie(withMix) + expect_s4_class(ldReference(res), "GenotypeMixture") + expect_true(all(is.finite(unlist(pip(res))))) +}) + +test_that("the rFinite default needs the reference's size", { + unknown <- LdMatrix( + diag(2), + variants = data.frame(chrom = "1", pos = 1:2, A1 = "A", A2 = "G") + ) + expect_error( + .fmResolveRFinite(NULL, TRUE, "none", unknown), + "needs the LD reference's size" + ) + known <- LdMatrix( + diag(2), + variants = data.frame(chrom = "1", pos = 1:2, A1 = "A", A2 = "G"), + nSamples = 300 + ) + expect_identical(.fmResolveRFinite(NULL, TRUE, "none", known), 300L) + # An explicit rFinite, or no mismatch mode, never asks. + expect_identical(.fmResolveRFinite(50, TRUE, "none", unknown), 50) + expect_null(.fmResolveRFinite(NULL, FALSE, "none", unknown)) +}) diff --git a/tests/testthat/test_fineMappingWrappers.R b/tests/testthat/test_fineMappingWrappers.R index 0300aef2b..048dc90b5 100644 --- a/tests/testthat/test_fineMappingWrappers.R +++ b/tests/testthat/test_fineMappingWrappers.R @@ -371,24 +371,6 @@ test_that("glmnetWeights handles zero-variance columns", { expect_equal(w[3], 0) }) -# ============================================================================= -# init_prior_sd -# ============================================================================= - -test_that("init_prior_sd returns n standard deviations", { - skip_if_not_installed("susieR") - set.seed(42) - n_samples <- 50 - p <- 10 - X <- matrix(rnorm(n_samples * p), n_samples, p) - y <- X[, 1] * 2 + rnorm(n_samples) - - sds <- pecotmr:::initPriorSd(X, y, n = 15) - expect_length(sds, 15) - expect_equal(sds[1], 0) - expect_true(all(diff(sds) >= 0)) -}) - # ============================================================================= # postprocessFinemappingFits: analysisScript and V=NULL branches (Tier 1) # ============================================================================= @@ -638,6 +620,9 @@ if (!exists(".makeUnivariateData", inherits = FALSE)) { "pip", "posterior_mean", "posterior_sd", + # The infinitesimal half of posterior_mean (susieInf / susieAsh), which + # coef.susie() already summed into it; 0 for methods without one. + "posterior_theta", "logBF", # CS columns are derived from the coverages the pipeline produced; for the # default coverages (0.95/0.70/0.50) memberships lead, then purities. @@ -782,7 +767,7 @@ if (!exists(".makeUnivariateData", inherits = FALSE)) { ) } -test_that("buildTopLoci returns the exact 22-column schema in order with stable dtypes", { +test_that("buildTopLoci returns the fixed schema in order with stable dtypes", { # `.emptyTopLoci` is a package-internal helper. Use the namespace lookup # so the test works both source-loaded and after R CMD INSTALL. empty_fn <- if ( @@ -1036,7 +1021,7 @@ test_that("buildTopLoci: per-variant logBF is the max single-effect lbf", { expect_true("logBF" %in% names(.fmrRowTopLoci(e, signalCutoff = 0))) }) -test_that("buildTopLoci emits 22 columns in the fixed order on a non-empty fit", { +test_that("buildTopLoci emits the fixed columns in order on a non-empty fit", { variant_ids <- c("chr1:100:A:G", "chr1:200:C:T") inp <- .fakeFitAndCs( variant_ids, @@ -2677,25 +2662,37 @@ test_that(".susie_rss_extract_weights returns correct-length vector", { fit <- susieR::susie_rss(z = z, R = R, n = n, L = 5) w <- pecotmr:::.susieRssExtractWeights( fit = fit, - R = R, + nVariants = p, requiredFields = c("alpha", "mu", "X_column_scale_factors") ) expect_equal(length(w), p) expect_true(all(is.finite(w))) }) -test_that("susieRssWeights follows (stat, LD) convention", { +test_that("susieRssWeights checks the fit against the statistics' variants", { skip_if_not_installed("susieR") set.seed(42) p <- 20 n <- 500 R <- diag(p) z <- rnorm(p) - stat <- list(b = z / sqrt(n), cor = z / sqrt(n), z = z, n = rep(n, p)) + stat <- list(z = z, n = rep(n, p), variantNames = .rrwIds(p)) fit <- susieR::susie_rss(z = z, R = R, n = n, L = 5) - w <- susieRssWeights(stat, R, susieRssFit = fit) + w <- susieRssWeights(stat, .rrwLdMatrix(R), susieRssFit = fit) expect_equal(length(w), p) expect_true(all(is.finite(w))) + # No LD is read, so the reference is optional: without one the + # statistics' own variants are the block. + expect_equal(susieRssWeights(stat, susieRssFit = fit), w) + # With one, every variant must be in it. + stranger <- list_modify( + stat, + variantNames = replace(stat$variantNames, 1L, "chr2:1:A:G") + ) + expect_error( + susieRssWeights(stranger, .rrwLdMatrix(R), susieRssFit = fit), + "1 variant id\\(s\\) not present in the LD reference" + ) }) test_that("susieRssWeights retains fit unless fitRetention is none", { @@ -2705,9 +2702,9 @@ test_that("susieRssWeights retains fit unless fitRetention is none", { n <- 500 R <- diag(p) z <- rnorm(p) - stat <- list(b = z / sqrt(n), cor = z / sqrt(n), z = z, n = rep(n, p)) + stat <- list(z = z, n = rep(n, p), variantNames = .rrwIds(p)) fit <- susieR::susie_rss(z = z, R = R, n = n, L = 5) - w <- susieRssWeights(stat, R, susieRssFit = fit, fitRetention = "slim") + w <- susieRssWeights(stat, susieRssFit = fit, fitRetention = "slim") expect_false(is.null(attr(w, "fit"))) }) @@ -2718,9 +2715,9 @@ test_that("susieInfRssWeights works", { n <- 500 R <- diag(p) z <- rnorm(p) - stat <- list(b = z / sqrt(n), cor = z / sqrt(n), z = z, n = rep(n, p)) + stat <- list(z = z, n = rep(n, p), variantNames = .rrwIds(p)) fit <- susieR::susie_rss(z = z, R = R, n = n, L = 5) - w <- susieInfRssWeights(stat, R, susieInfRssFit = fit) + w <- susieInfRssWeights(stat, .rrwLdMatrix(R), susieInfRssFit = fit) expect_equal(length(w), p) expect_true(all(is.finite(w))) }) @@ -2752,7 +2749,7 @@ test_that("susieAshRssWeights returns weights of length p", { n = median(f$stat$n), L = 5 ) - w <- susieAshRssWeights(f$stat, f$LD, susieAshRssFit = fit) + w <- susieAshRssWeights(f$stat, f$ldReference, susieAshRssFit = fit) expect_length(w, f$p) expect_true(all(is.finite(w))) }) @@ -2765,34 +2762,62 @@ test_that("mvsusieRssWeights returns p x K weights from a supplied fit", { coef.mvsusie = function(...) fakeCoef, .package = "mvsusieR" ) - w <- mvsusieRssWeights(m$stat, m$LD, mvsusieRssFit = "precomputed_fit") + w <- mvsusieRssWeights( + m$stat, + m$ldReference, + mvsusieRssFit = "precomputed_fit" + ) expect_equal(dim(w), c(m$p, m$K)) expect_true(all(is.finite(w))) }) -test_that("mvsusieRssWeights checks the fit against the LD block", { +test_that("mvsusieRssWeights checks the fit against the statistics' block", { skip_if_not_installed("mvsusieR") - # It takes (stat, LD) like every other *RssWeights wrapper, and used to - # read NEITHER -- a fit from a different block was extracted without - # complaint. The susie siblings have always checked this. + # It used to read neither `stat` nor the LD -- a fit from a different + # block was extracted without complaint. The susie siblings have always + # checked this. m <- .rrwMulti(n = 80, p = 8, K = 2) fakeCoef <- matrix(rnorm((m$p + 1) * m$K), nrow = m$p + 1, ncol = m$K) local_mocked_bindings( coef.mvsusie = function(...) fakeCoef, .package = "mvsusieR" ) - # An LD block of the wrong size cannot belong to this fit. + # Statistics over fewer variants cannot belong to this fit, with or + # without a reference. + fewer <- list( + z = m$stat$z[-m$p, , drop = FALSE], + n = m$stat$n, + variantNames = m$stat$variantNames[-m$p] + ) + msg <- "mvsusieRss fit has 8 variants but the statistics describe 7" expect_error( mvsusieRssWeights( - m$stat, - m$LD[seq_len(m$p - 1), seq_len(m$p - 1), drop = FALSE], + fewer, + m$ldReference, mvsusieRssFit = "precomputed_fit" ), - "Dimension mismatch: mvsusieRss fit has 8 variants but LD has 7" + msg + ) + expect_error( + mvsusieRssWeights(fewer, mvsusieRssFit = "precomputed_fit"), + msg + ) + # A variant the reference does not hold cannot be in its block. + stranger <- list_modify( + m$stat, + variantNames = replace(m$stat$variantNames, 1L, "chr2:1:A:G") + ) + expect_error( + mvsusieRssWeights( + stranger, + m$ldReference, + mvsusieRssFit = "precomputed_fit" + ), + "1 variant id\\(s\\) not present in the LD reference" ) # `stat` is validated as the list the contract says it is. expect_error( - mvsusieRssWeights("not-a-list", m$LD, mvsusieRssFit = "f"), + mvsusieRssWeights("not-a-list", m$ldReference, mvsusieRssFit = "f"), "stat" ) }) @@ -2801,7 +2826,7 @@ test_that("mvsusieRssWeights refuses to fine-map when no fit is supplied", { skip_if_not_installed("mvsusieR") m <- .rrwMulti(n = 80, p = 8, K = 2) expect_error( - mvsusieRssWeights(m$stat, m$LD), + mvsusieRssWeights(m$stat, m$ldReference), "`mvsusieRssFit` is required" ) }) @@ -2814,7 +2839,7 @@ test_that("mvsusieRssWeights demands a fit before anything else", { # the fitting branch; with no fit supplied, the missing fit is the # fundamental problem and `stat` is not read at all. expect_error( - mvsusieRssWeights(oneCol, f$LD), + mvsusieRssWeights(oneCol, f$ldReference), "`mvsusieRssFit` is required" ) }) @@ -3120,7 +3145,7 @@ test_that("mergeSusieCs: single condition with one credible set", { expect_equal(res$credibleSetNames, c("cs_1_1", "cs_1_1")) }) -test_that("mergeSusieCs: non-FineMappingResult input errors", { +test_that("mergeSusieCs: input that is not a fine-mapping result errors", { expect_error(mergeSusieCs(list(1, 2)), "QtlFineMappingResult") }) @@ -3157,13 +3182,13 @@ test_that("mergeSusieCs: non-FineMappingResult input errors", { test_that("computeCsCorrelation (SumStats) matches get_cs_correlation", { data(qtlSumStatsExample) ss <- qtlSumStatsExample - vids <- rownames(ldSketch(ss)) + vids <- rownames(ldReference(ss)) set.seed(1) fe <- .ccMakeEntry(vids, list(L1 = c(1L, 2L, 3L), L2 = c(90L, 91L))) cc <- computeCsCorrelation(fe, ss) # Reference: the same LD (from the sketch, aligned to the fit variables) # fed to the same fit. Equality proves the on-demand path + alignment. - xcorr <- pecotmr:::.ldFromSketch(ldSketch(ss), vids, onMissing = "error") + xcorr <- pecotmr:::.ldFromRef(ldReference(ss), vids, onMissing = "error") ref <- susieR::get_cs_correlation( list(sets = susieFit(fe)$sets, pip = susieFit(fe)$pip), Xcorr = xcorr @@ -3172,10 +3197,90 @@ test_that("computeCsCorrelation (SumStats) matches get_cs_correlation", { expect_equal(unname(cc), unname(ref)) }) +test_that("computeCsCorrelation reads a panel's factor or an LdMatrix alike", { + # A genotype reference gives its factor and an LdMatrix its matrix; the + # same LD gives the same between-CS correlation. + data(gwasSumStatsS4Example) + gss <- gwasSumStatsS4Example + panel <- ldReference(gss) + withLd <- GwasSumStats( + studyName = studyName(gss), + entry = list(pecotmr:::.collectionEntry(gss, 1L)), + genome = "hg19", + ldReference = LdMatrix( + unname(computeLd(panel)), + variants = SummarizedExperiment::rowRanges(panel) + ), + qcInfo = qcInfo(gss) + ) + vids <- names(SummarizedExperiment::rowRanges(panel))[1:40] + set.seed(3) + fe <- .ccMakeEntry(vids, list(L1 = c(1L, 2L, 3L), L2 = c(30L, 31L))) + expect_equal( + computeCsCorrelation(fe, gss), + computeCsCorrelation(fe, withLd) + ) +}) + +# A single-row fSuSiE result over `vids`, in fsusieR's own layout: class +# "susiF", credible sets (indices into vids) in $cs rather than $sets$cs. +.ccMakeFsusieEntry <- function(vids, cs) { + pip <- stats::runif(length(vids)) + QtlFineMappingResult( + studyName = "s1", + context = "c1", + trait = "t1", + method = "fsusie", + entry = list(fineMappingRow( + variantIds = vids, + susieFit = structure(list(cs = cs, pip = pip), class = "susiF"), + topLoci = data.frame( + variant_id = vids, + pip = pip, + stringsAsFactors = FALSE + ) + )) + ) +} + +# The between-set correlation fsusieR::cal_cor_cs() defines: the largest +# correlation between a member of one set and a member of the other. +.ccMaxCorrelation <- function(R, cs) { + pairMax <- function(l, k) max(R[cs[[l]], cs[[k]]]) + outer(seq_along(cs), seq_along(cs), Vectorize(pairMax)) +} + +test_that("computeCsCorrelation reads an fSuSiE fit's sets, from LD", { + # fSuSiE keeps its credible sets in $cs, not $sets$cs; reading only the + # latter made every fSuSiE fit look set-less, so this came back NULL. + data(qtlSumStatsExample) + ss <- qtlSumStatsExample + vids <- rownames(ldReference(ss)) + cs <- list(c(1L, 2L, 3L), c(90L, 91L)) + set.seed(1) + cc <- computeCsCorrelation(.ccMakeFsusieEntry(vids, cs), ss) + R <- pecotmr:::.ldFromRef(ldReference(ss), vids, onMissing = "error") + expect_equal(cc, .ccMaxCorrelation(R, cs)) + expect_equal(diag(cc), c(1, 1)) +}) + +test_that("computeCsCorrelation reads an fSuSiE fit's sets, from genotypes", { + # The genotype route hands the sets to fsusieR::cal_cor_cs() itself, a + # branch the count bug above kept from ever running. + skip_if_not_installed("fsusieR") + data(qtlDatasetExample) + geno <- genotypes(qtlDatasetExample) + vids <- colnames(geno)[1:6] + cs <- list(c(1L, 2L), c(4L, 5L, 6L)) + set.seed(2) + cc <- computeCsCorrelation(.ccMakeFsusieEntry(vids, cs), qtlDatasetExample) + expect_equal(cc, .ccMaxCorrelation(stats::cor(geno[, vids]), cs)) +}) + test_that("computeCsCorrelation is NULL for fewer than two credible sets", { data(qtlSumStatsExample) ss <- qtlSumStatsExample - vids <- rownames(ldSketch(ss)) + vids <- rownames(ldReference(ss)) set.seed(1) expect_null(computeCsCorrelation(.ccMakeEntry(vids, list()), ss)) expect_null( @@ -3185,7 +3290,7 @@ test_that("computeCsCorrelation is NULL for fewer than two credible sets", { test_that("computeCsCorrelation requires a QtlDataset / SumStats ldSource", { data(qtlSumStatsExample) - vids <- rownames(ldSketch(qtlSumStatsExample)) + vids <- rownames(ldReference(qtlSumStatsExample)) set.seed(1) fe <- .ccMakeEntry(vids, list(L1 = c(1L, 2L, 3L), L2 = c(90L, 91L))) expect_error(computeCsCorrelation(fe, 42), "requires a QtlDataset") @@ -3198,11 +3303,14 @@ test_that("computeCsCorrelation requires a QtlDataset / SumStats ldSource", { test_that("computeCsCorrelation errors when a fit variant is off-panel", { data(qtlSumStatsExample) ss <- qtlSumStatsExample - vids <- rownames(ldSketch(ss)) + vids <- rownames(ldReference(ss)) vids[1] <- "chr22:99999999:A:G" set.seed(1) fe <- .ccMakeEntry(vids, list(L1 = c(1L, 2L, 3L), L2 = c(90L, 91L))) - expect_error(computeCsCorrelation(fe, ss), "not present in the LD sketch") + expect_error( + computeCsCorrelation(fe, ss), + "not present in the LD reference" + ) }) test_that("computeCsCorrelation resolves on the paired fixture", { @@ -3317,6 +3425,19 @@ test_that("susieResult returns NULL when finemappingEntry missing", { expect_null(result) }) +test_that("susieResult reads a bare FineMappingRow, its documented input", { + # The guard used to require a FineMappingResultBase, so the documented + # input -- a row -- came back NULL without a word. + fit <- list(pip = c(0.2, 0.8), sets = list(cs = list())) + ids <- c("chr1:100:A:G", "chr1:200:C:T") + row <- fineMappingRow( + variantIds = ids, + susieFit = fit, + topLoci = data.frame(variant_id = ids, pip = c(0.2, 0.8)) + ) + expect_equal(susieResult(list(finemappingEntry = row)), fit) +}) + test_that("susieResult returns trimmed result when present", { mock_result <- list(pip = c(0.1, 0.5, 0.3), sets = list(cs = list())) con_data <- list( @@ -3413,7 +3534,7 @@ test_that("extractCsInfo extracts single CS correctly", { test_that("extractCsInfo builds correlation columns from the ldSource", { data(qtlSumStatsExample) ss <- qtlSumStatsExample - vids <- rownames(ldSketch(ss)) + vids <- rownames(ldReference(ss)) set.seed(1) fit <- list( sets = list(cs = list(L_1 = c(1L, 2L, 3L), L_2 = c(90L, 91L))), @@ -3498,17 +3619,26 @@ test_that("susieResult returns NULL when the trimmed susie fit is empty", { # Weight extraction and variant parsing guards # =========================================================================== -test_that("susieRss weight extraction rejects a fit that does not match R", { - # A pip vector of a different length than R means the fit and the LD - # describe different variant sets; the weights would be silently - # mis-assigned rather than wrong-looking. +test_that("susieRss weight extraction rejects a fit of another block", { + # A pip vector of a different length than the statistics means the fit + # and the statistics describe different variant sets; the weights would + # be silently mis-assigned rather than wrong-looking. expect_error( pecotmr:::.susieRssExtractWeights( fit = list(pip = c(0.1, 0.2)), - R = diag(3), + nVariants = 3L, requiredFields = c("alpha", "mu") ), - "Dimension mismatch: susieRss fit has 2 variants but R has 3 rows" + "susieRss fit has 2 variants but the statistics describe 3" + ) + # With nothing to compare against, the fit is taken as it is. + expect_equal( + pecotmr:::.susieRssExtractWeights( + fit = list(pip = c(0.1, 0.2)), + nVariants = NA_integer_, + requiredFields = c("alpha", "mu") + ), + c(0, 0) ) }) @@ -3517,7 +3647,7 @@ test_that("susieRss weights are zero when the fit lacks the coefficient fields", # contribution is zero rather than an error or a partial answer. w <- pecotmr:::.susieRssExtractWeights( fit = list(pip = c(0.1, 0.2, 0.3)), - R = diag(3), + nVariants = 3L, requiredFields = c("alpha", "mu", "X_column_scale_factors") ) expect_equal(w, c(0, 0, 0)) @@ -3526,7 +3656,7 @@ test_that("susieRss weights are zero when the fit lacks the coefficient fields", test_that("susieRss weights carry the fit when asked to retain it", { w <- pecotmr:::.susieRssExtractWeights( fit = list(pip = c(0.1, 0.2, 0.3)), - R = diag(3), + nVariants = 3L, requiredFields = "absentField", fitRetention = "slim" ) @@ -3560,16 +3690,24 @@ test_that("merging overlapping sets with nothing to merge yields nothing", { expect_null(pecotmr:::.combineTopLoci(list())) }) -test_that("correlation extraction reports NA when every value is self-correlation", { - # A single-variant set has only the diagonal, so there is no pairwise - # correlation to summarise -- reported as NA rather than 1. - both <- pecotmr:::.extractCorrelations(c(1, 1, 1)) - expect_true(is.na(both$max_corr)) - expect_true(is.na(both$min_corr)) - # Perfect correlations are excluded, magnitudes are used. - mixed <- pecotmr:::.extractCorrelations(c(1, 0.5, -0.9)) - expect_equal(mixed$max_corr, 0.9) - expect_equal(mixed$min_corr, 0.5) +test_that("correlation extraction drops only each set's own entry", { + # By position, not by value: a genuine |r| = 1 between two sets counts, + # magnitudes are used, and a diagonal a few ulps short of 1 (as a + # factor's correlation gives) is still the set with itself. + csCorr <- rbind(c(1 - 2e-16, 0.5, -1), c(0.5, 1, -0.9), c(-1, -0.9, 1)) + expect_equal( + pecotmr:::.extractCorrelations(1L, csCorr), + list(max_corr = 1, min_corr = 0.5) + ) + expect_equal( + pecotmr:::.extractCorrelations(2L, csCorr), + list(max_corr = 0.9, min_corr = 0.5) + ) + out <- pecotmr:::.csAppendCorrelationCols(tibble(cs = 1:3), csCorr) + expect_equal(out$cs_corr_max, c(1, 0.9, 1)) + expect_equal(out$cs_corr_min, c(0.5, 0.5, 0.9)) + single <- pecotmr:::.csAppendCorrelationCols(tibble(cs = 1L), NULL) + expect_true(is.na(single$cs_corr_max)) }) test_that("susieResult returns NULL when there is no fine-mapping entry", { @@ -3591,11 +3729,13 @@ test_that("purity lookup answers 0 for a missing or out-of-range set", { expect_equal(pecotmr:::.csPurityAt(0L, c(0.5)), 0) }) -test_that("a cs label parses to its trailing index", { - expect_equal(pecotmr:::.cs95ToIndex("susie_3"), 3L) +test_that("cs labels parse to their trailing index", { + expect_identical( + pecotmr:::.csLabelIndex(c("susie_3", "susie_inf_12", "susie_0")), + c(3L, 12L, 0L) + ) # 0 marks "in no credible set", which is what an empty or NA label means. - expect_equal(pecotmr:::.cs95ToIndex(NA_character_), 0L) - expect_equal(pecotmr:::.cs95ToIndex(""), 0L) + expect_identical(pecotmr:::.csLabelIndex(c(NA, "")), c(0L, 0L)) }) test_that("the alpha row helper returns a plain numeric row", { @@ -3875,7 +4015,7 @@ test_that("susieInf is skipped as a result when it was only a chain input", { chainOnly, "INFFIT", z = NULL, - R = NULL, + ld = list(), n = 100L, coverage = 0.95, methodArgs = list(), @@ -3913,7 +4053,7 @@ test_that("susieInf is returned as its own fit when it was requested", { asked, "INFFIT", z = NULL, - R = NULL, + ld = list(), n = 100L, coverage = 0.95, methodArgs = list(), @@ -4157,7 +4297,7 @@ test_that(".fmRssFitStd threads the shared susieInf fit when chained", { chain, list(S = TRUE), z = NULL, - R = NULL, + ld = list(), n = 100L, coverage = 0.95, methodArgs = list(), @@ -4188,7 +4328,7 @@ test_that(".fmFitRssBlock skips a token that produced no fit", { ) out <- pecotmr:::.fmFitRssBlock( z = NULL, - R = NULL, + ld = list(), n = 100L, toRun = c("susie", "susieAsh"), initializeWithSusieInf = FALSE @@ -4337,7 +4477,7 @@ test_that("susieResult returns NULL for an empty susie fit", { method = "susie", entry = list(row) ) - # A FineMappingResult is present, but it carries no fit to return. + # A fine-mapping result is present, but it carries no fit to return. expect_null(susieResult(list(finemappingEntry = res))) }) @@ -4400,7 +4540,7 @@ test_that("mvsusieRssWeights attaches the fit only when asked", { ) kept <- mvsusieRssWeights( m$stat, - m$LD, + m$ldReference, mvsusieRssFit = "precomputed_fit", fitRetention = "slim" ) @@ -4479,15 +4619,15 @@ test_that("susie*Weights: fitRetention / stat / methodArgs guards fire", { "must be one of" ) expect_error( - susieRssWeights(stat = "nope", LD = NULL), + susieRssWeights(stat = "nope"), "stat.*Must be of type 'list'" ) expect_error( - susieInfRssWeights(stat = "nope", LD = NULL), + susieInfRssWeights(stat = "nope"), "stat.*Must be of type 'list'" ) expect_error( - susieAshRssWeights(stat = "nope", LD = NULL), + susieAshRssWeights(stat = "nope"), "stat.*Must be of type 'list'" ) }) @@ -5357,15 +5497,15 @@ test_that("the RSS weight extractors refuse to fine-map themselves", { # These read weights off an existing fit; without one there is nothing to # extract, and the message says where the fit comes from. expect_error( - susieRssWeights(stat = list(z = 1), LD = diag(2)), + susieRssWeights(stat = list(z = 1)), "susieRssWeights: no 'susie' fit supplied" ) expect_error( - susieInfRssWeights(stat = list(z = 1), LD = diag(2)), + susieInfRssWeights(stat = list(z = 1)), "susieInfRssWeights: no 'susieInf' fit supplied" ) expect_error( - susieAshRssWeights(stat = list(z = 1), LD = diag(2)), + susieAshRssWeights(stat = list(z = 1)), "susieAshRssWeights: no 'susieAsh' fit supplied" ) }) diff --git a/tests/testthat/test_genotypeHandle.R b/tests/testthat/test_genotypeHandle.R index 373c9c170..de075fdf2 100644 --- a/tests/testthat/test_genotypeHandle.R +++ b/tests/testthat/test_genotypeHandle.R @@ -25,9 +25,11 @@ test_that("GenotypeHandle: two simultaneous sources errors", { ) }) -test_that("GenotypeHandle: partial bed/bim/fam triplet errors", { +test_that("readGenotypes: partial bed/bim/fam triplet errors", { + # GenotypeHandle() no longer takes a PLINK1 triplet: a BED fileset is + # read as a panel, through readGenotypes(), which checks the triplet. expect_error( - GenotypeHandle(bed = "x.bed", bim = "x.bim"), + readGenotypes(bed = "x.bed", bim = "x.bim"), "all three must be provided" ) }) @@ -57,30 +59,20 @@ test_that("GenotypeHandle: region without ldMeta errors", { # Format-specific constructor branches (real file reads) # =========================================================================== -test_that("GenotypeHandle: path = .gds uses readGenotypes (gds backend)", { - skip_if_not_installed("SNPRelate") - h <- GenotypeHandle(path = gds_path) - expect_s4_class(h, "GenotypeHandle") - expect_equal(genotypeFormat(h), "gds") - expect_equal(nSamples(h), 100L) - expect_equal(nrow(snpInfo(h)), 349L) -}) - -test_that("GenotypeHandle: path = .vcf.gz uses readGenotypes (vcf backend)", { - skip_if_not_installed("VariantAnnotation") - h <- GenotypeHandle(path = vcf_path) - expect_s4_class(h, "GenotypeHandle") - expect_equal(genotypeFormat(h), "vcf") - expect_equal(nSamples(h), 100L) -}) - -test_that("GenotypeHandle: plink1Prefix builds a plink1 handle", { - skip_if_not_installed("snpStats") - h <- GenotypeHandle(plink1Prefix = plink_prefix) - expect_s4_class(h, "GenotypeHandle") - expect_equal(genotypeFormat(h), "plink1") - expect_equal(nSamples(h), 100L) - expect_equal(nrow(snpInfo(h)), 349L) +test_that("GenotypeHandle refuses a VCF, GDS or PLINK1 path, read as a panel", { + # A VCF, GDS or PLINK1 file reads through its own DelayedArray seed, not + # a handle; asking for a handle points at readGenotypes() rather than + # failing somewhere inside a reader. + expect_error(GenotypeHandle(path = gds_path), "read as a genotype panel") + expect_error(GenotypeHandle(path = vcf_path), "read as a genotype panel") + expect_error( + GenotypeHandle(path = paste0(plink_prefix, ".bed")), + "read as a genotype panel" + ) + expect_error( + GenotypeHandle(path = gds_path, format = "gds"), + "readGenotypes" + ) }) test_that("GenotypeHandle: plink2Prefix builds a plink2 handle", { @@ -95,21 +87,20 @@ test_that("GenotypeHandle: plink2Prefix builds a plink2 handle", { # Explicit triplet constructors # =========================================================================== -test_that("GenotypeHandle: bed/bim/fam triplet with matching stems builds plink1 handle", { - skip_if_not_installed("snpStats") - h <- GenotypeHandle( - bed = paste0(plink_prefix, ".bed"), - bim = paste0(plink_prefix, ".bim"), - fam = paste0(plink_prefix, ".fam") +test_that(".plink1TripletStem: the stem the three files share", { + expect_equal( + pecotmr:::.plink1TripletStem( + bed = paste0(plink_prefix, ".bed"), + bim = paste0(plink_prefix, ".bim"), + fam = paste0(plink_prefix, ".fam") + ), + plink_prefix ) - expect_s4_class(h, "GenotypeHandle") - expect_equal(genotypeFormat(h), "plink1") - expect_equal(nSamples(h), 100L) }) -test_that(".genotypeHandleFromPlink1Triplet: errors when stems disagree", { +test_that(".plink1TripletStem: errors when stems disagree", { expect_error( - pecotmr:::.genotypeHandleFromPlink1Triplet( + pecotmr:::.plink1TripletStem( bed = "a/x.bed", bim = "b/y.bim", fam = "c/z.fam" @@ -118,9 +109,9 @@ test_that(".genotypeHandleFromPlink1Triplet: errors when stems disagree", { ) }) -test_that(".genotypeHandleFromPlink1Triplet: errors on non-character input", { +test_that(".plink1TripletStem: errors on non-character input", { expect_error( - pecotmr:::.genotypeHandleFromPlink1Triplet( + pecotmr:::.plink1TripletStem( bed = 1L, bim = "x.bim", fam = "x.fam" @@ -261,31 +252,62 @@ test_that(".genotypeHandleFromPlink2Triplet: errors on non-character input", { list(meta = f, cor = corPath) } -test_that("GenotypeHandle ldMeta: dispatches to gds reader for .gds path", { - skip_if_not_installed("SNPRelate") +test_that("an LD-meta row naming a .gds file is read as a panel", { + skip_if_not_installed("gdsfmt") + skip_if_not_installed("GDSArray") f <- .gh_makeLdMetaForGds() on.exit(unlink(f), add = TRUE) - h <- GenotypeHandle(ldMeta = f, region = "chr21:17513228-17592874") - expect_s4_class(h, "GenotypeHandle") - expect_equal(genotypeFormat(h), "gds") + region <- "chr21:17513228-17592874" + expect_error( + GenotypeHandle(ldMeta = f, region = region), + "read as a genotype panel" + ) + panel <- readGenotypes(ldMeta = f, region = region) + expect_s4_class(panel, "RangedSummarizedExperiment") + expect_equal(dim(panel), c(349L, 100L)) + expect_equal(S4Vectors::metadata(panel)$genotypeSource$format, "gds") }) -test_that("GenotypeHandle ldMeta: dispatches to vcf reader for .vcf.gz path", { +test_that("an LD-meta row naming a .vcf.gz file is read as a panel", { skip_if_not_installed("VariantAnnotation") f <- .gh_makeLdMetaForVcf() on.exit(unlink(f), add = TRUE) - h <- GenotypeHandle(ldMeta = f, region = "chr21:17513228-17592874") - expect_s4_class(h, "GenotypeHandle") - expect_equal(genotypeFormat(h), "vcf") + region <- "chr21:17513228-17592874" + expect_error( + GenotypeHandle(ldMeta = f, region = region), + "read as a genotype panel" + ) + panel <- readGenotypes(ldMeta = f, region = region) + expect_equal(dim(panel), c(349L, 100L)) + expect_equal(S4Vectors::metadata(panel)$genotypeSource$format, "vcf") }) -test_that("GenotypeHandle ldMeta: dispatches to plink1 reader for .bed path", { - skip_if_not_installed("snpStats") +test_that("an LD-meta row's file is read by the reader its format names", { + # A PLINK file or prefix an LD-meta row names is read through a handle, + # as before; the panel route wraps it rather than reading it another way. + skip_if_not_installed("pgenlibr") + panel <- pecotmr:::.ghLdPathToPanel(paste0(plink_prefix, ".pgen")) + expect_equal(S4Vectors::metadata(panel)$genotypeSource$format, "plink2") + prefixed <- pecotmr:::.ghLdPathToPanel(plink_prefix) + expect_equal(dim(prefixed), dim(panel)) + expect_error( + pecotmr:::.ghLdPathToPanel(tempfile(fileext = ".txt")), + "ldMeta: .* is neither a genotype file nor a PLINK prefix" + ) +}) + +test_that("an LD-meta row naming a .bed is read as a PLINK1 panel", { + skip_if_not_installed("PlinkMatrix") f <- .gh_makeLdMetaForBed() on.exit(unlink(f), add = TRUE) - h <- GenotypeHandle(ldMeta = f, region = "chr21:17513228-17592874") - expect_s4_class(h, "GenotypeHandle") - expect_equal(genotypeFormat(h), "plink1") + region <- "chr21:17513228-17592874" + panel <- readGenotypes(ldMeta = f, region = region) + expect_equal(dim(panel), c(349L, 100L)) + expect_equal(S4Vectors::metadata(panel)$genotypeSource$format, "plink1") + expect_error( + GenotypeHandle(ldMeta = f, region = region), + "read as a genotype panel" + ) }) test_that("GenotypeHandle ldMeta: dispatches to plink2 reader for .pgen path", { @@ -323,21 +345,38 @@ test_that("GenotypeHandle ldMeta: region with no covering row errors", { test_that("GenotypeHandle constructs and validates correctly", { obj <- new( "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", + path = "/tmp/test", + format = "plink2", snpInfo = makeTestSnpInfo(), nSamples = 100L, sampleIds = paste0("sample_", 1:100), pgenPtr = NULL ) expect_s4_class(obj, "GenotypeHandle") - expect_equal(genotypeFormat(obj), "gds") + expect_equal(genotypeFormat(obj), "plink2") expect_true(methods::validObject(obj)) }) +test_that("GenotypeHandle refuses the formats it no longer reads", { + for (fmt in c("vcf", "gds", "plink1")) { + expect_error( + new( + "GenotypeHandle", + path = "/tmp/test", + format = fmt, + snpInfo = data.frame(), + nSamples = 0L, + sampleIds = character(), + pgenPtr = NULL + ), + "'format' must be one of: plink2, bgen" + ) + } +}) + test_that("GenotypeHandle accepts all valid formats", { - for (fmt in c("gds", "vcf", "plink1", "plink2")) { + for (fmt in c("plink2", "bgen")) { obj <- new( "GenotypeHandle", path = "/tmp/test", @@ -358,7 +397,7 @@ test_that("GenotypeHandle rejects invalid format", { new( "GenotypeHandle", path = "/tmp/test", - format = "bgen", + format = "zarr", snpInfo = data.frame(), nSamples = 0L, sampleIds = character(), @@ -375,26 +414,30 @@ test_that("GenotypeHandle rejects invalid format", { # Extraction routing for sharded handles is covered in test_genotypeIo.R. # =========================================================================== test_that("genoMeta (named vector) builds a sharded handle", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") h <- GenotypeHandle( genoMeta = c( - "21" = file.path(test_data_dir, "test_variants"), - "22" = file.path(test_data_dir, "test_variants_chr22") + "21" = file.path(test_data_dir, "test_variants.pgen"), + "22" = file.path(test_data_dir, "test_variants_chr22.pgen") ) ) expect_s4_class(h, "GenotypeHandle") - expect_equal(genotypeFormat(h), "plink1") + expect_equal(genotypeFormat(h), "plink2") expect_equal(sort(names(chromPaths(h))), c("21", "22")) expect_equal(nrow(snpInfo(h)), 2L * 349L) }) test_that("genoMeta meta-file resolves payloads relative to its own directory", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") # A meta file living in test_data referencing payloads by basename only. metafile <- file.path(test_data_dir, "tmp_chrom_meta_relative.tsv") on.exit(unlink(metafile), add = TRUE) writeLines( - c("#chr\tpath", "21\ttest_variants", "22\ttest_variants_chr22"), + c( + "#chr\tpath", + "21\ttest_variants.pgen", + "22\ttest_variants_chr22.pgen" + ), metafile ) h <- GenotypeHandle(genoMeta = metafile) @@ -459,12 +502,23 @@ test_that(".parseChromMeta errors when a chromosome maps to multiple payloads", }) test_that("genoMeta errors on mismatched samples across shards", { - skip_if_not_installed("snpStats") - # protocol_example.genotype is a different sample panel. + skip_if_not_installed("pgenlibr") + skip_if_not_installed("PlinkMatrix") + # dummy_data and protocol_example.genotype are different sample panels: + # one a sharded handle's check, the other a stacked PLINK1 panel's. expect_error( GenotypeHandle( genoMeta = c( - "21" = file.path(test_data_dir, "test_variants"), + "21" = file.path(test_data_dir, "test_variants.pgen"), + "1" = file.path(test_data_dir, "dummy_data.pgen") + ) + ), + "identical sample IDs" + ) + expect_error( + readGenotypes( + genoMeta = c( + "21" = file.path(test_data_dir, "test_variants.bed"), "22" = file.path(test_data_dir, "protocol_example.genotype") ) ), @@ -473,12 +527,21 @@ test_that("genoMeta errors on mismatched samples across shards", { }) test_that("genoMeta errors on mixed formats across shards", { - skip_if_not_installed("snpStats") - skip_if_not_installed("SNPRelate") + # A panel's shards are told apart before any is read, so a mix is + # refused for the mix, whichever reader each shard would take. expect_error( - GenotypeHandle( + readGenotypes( genoMeta = c( - "21" = file.path(test_data_dir, "test_variants"), + "21" = paste0(plink_prefix, ".bed"), + "22" = paste0(plink_prefix, ".pgen") + ) + ), + "share one" + ) + expect_error( + readGenotypes( + genoMeta = c( + "21" = file.path(test_data_dir, "test_variants.bed"), "22" = file.path(test_data_dir, "test_variants_chr22.gds") ) ), @@ -487,12 +550,22 @@ test_that("genoMeta errors on mixed formats across shards", { }) test_that("genoMeta errors when a chromosome appears in two files", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") + skip_if_not_installed("PlinkMatrix") expect_error( GenotypeHandle( genoMeta = c( - "a" = file.path(test_data_dir, "test_variants"), - "b" = file.path(test_data_dir, "test_variants") + "a" = file.path(test_data_dir, "test_variants.pgen"), + "b" = file.path(test_data_dir, "test_variants.pgen") + ) + ), + "more than one" + ) + expect_error( + readGenotypes( + genoMeta = c( + "a" = file.path(test_data_dir, "test_variants.bed"), + "b" = file.path(test_data_dir, "test_variants.bed") ) ), "more than one" @@ -500,11 +573,11 @@ test_that("genoMeta errors when a chromosome appears in two files", { }) test_that("genoMeta sharded handle show() reports the layout", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") sh <- GenotypeHandle( genoMeta = c( - "21" = file.path(test_data_dir, "test_variants"), - "22" = file.path(test_data_dir, "test_variants_chr22") + "21" = file.path(test_data_dir, "test_variants.pgen"), + "22" = file.path(test_data_dir, "test_variants_chr22.pgen") ) ) out <- paste(capture.output(show(sh)), collapse = "\n") @@ -515,10 +588,10 @@ test_that("genoMeta sharded handle show() reports the layout", { # genoMeta `chroms`: read only the requested per-chromosome shards (I/O win). # =========================================================================== test_that("genoMeta chroms reads only the requested shard", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") meta <- c( - "21" = file.path(test_data_dir, "test_variants"), - "22" = file.path(test_data_dir, "test_variants_chr22") + "21" = file.path(test_data_dir, "test_variants.pgen"), + "22" = file.path(test_data_dir, "test_variants_chr22.pgen") ) full <- GenotypeHandle(genoMeta = meta) only21 <- GenotypeHandle(genoMeta = meta, chroms = "21") @@ -530,12 +603,12 @@ test_that("genoMeta chroms reads only the requested shard", { }) test_that("genoMeta chroms canonicalises chromosome labels", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") # "chr21" canonicalises to the panel's declared "21" shard. h <- GenotypeHandle( genoMeta = c( - "21" = file.path(test_data_dir, "test_variants"), - "22" = file.path(test_data_dir, "test_variants_chr22") + "21" = file.path(test_data_dir, "test_variants.pgen"), + "22" = file.path(test_data_dir, "test_variants_chr22.pgen") ), chroms = "chr21" ) @@ -543,13 +616,13 @@ test_that("genoMeta chroms canonicalises chromosome labels", { }) test_that("genoMeta chroms falls back to all shards when none match", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") # chr9 is absent from the panel: rather than build an empty handle, read all # so the caller's own absence check can report the mismatch. h <- GenotypeHandle( genoMeta = c( - "21" = file.path(test_data_dir, "test_variants"), - "22" = file.path(test_data_dir, "test_variants_chr22") + "21" = file.path(test_data_dir, "test_variants.pgen"), + "22" = file.path(test_data_dir, "test_variants_chr22.pgen") ), chroms = "9" ) @@ -557,11 +630,11 @@ test_that("genoMeta chroms falls back to all shards when none match", { }) test_that("genoMeta chroms skips a shard whose file does not exist", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") # A bogus chr21 payload proves the skip: restricting to chr22 must never open # it, while requesting chr21 too fails on the missing files. meta <- c( - "22" = file.path(test_data_dir, "test_variants_chr22"), + "22" = file.path(test_data_dir, "test_variants_chr22.pgen"), "21" = "/no/such/chr21/prefix" ) h <- GenotypeHandle(genoMeta = meta, chroms = "22") @@ -570,9 +643,8 @@ test_that("genoMeta chroms skips a shard whose file does not exist", { }) test_that("chroms is rejected for a non-genoMeta source", { - skip_if_not_installed("snpStats") expect_error( - GenotypeHandle( + readGenotypes( plink1Prefix = file.path(test_data_dir, "test_variants"), chroms = "21" ), @@ -638,7 +710,7 @@ test_that(".genotypeHandleFromLdMeta errors on an unsupported payload extension" ) expect_error( pecotmr:::.genotypeHandleFromLdMeta("dummy.tsv", "chr1:1-100"), - "unsupported LD-meta file extension" + "ldMeta: .* is neither a genotype file nor a PLINK prefix" ) }) @@ -681,15 +753,6 @@ test_that(".genotypeHandleFromChromMeta errors when the meta has no rows", { # prefix sidecar probing, and the unresolvable-format error. # =========================================================================== -test_that(".resolveGenotypeShard honours explicit plink1 format and .bed extension", { - skip_if_not_installed("snpStats") - h1 <- pecotmr:::.resolveGenotypeShard(plink_prefix, format = "plink1") - expect_s4_class(h1, "GenotypeHandle") - expect_equal(genotypeFormat(h1), "plink1") - h2 <- pecotmr:::.resolveGenotypeShard(paste0(plink_prefix, ".bed")) - expect_equal(genotypeFormat(h2), "plink1") -}) - test_that(".resolveGenotypeShard honours explicit plink2 format and .pgen extension", { skip_if_not_installed("pgenlibr") h1 <- pecotmr:::.resolveGenotypeShard(plink_prefix, format = "plink2") @@ -699,18 +762,35 @@ test_that(".resolveGenotypeShard honours explicit plink2 format and .pgen extens expect_equal(genotypeFormat(h2), "plink2") }) -test_that(".resolveGenotypeShard dispatches gds via explicit format and .gds extension", { - skip_if_not_installed("SNPRelate") - h1 <- pecotmr:::.resolveGenotypeShard(gds_path, format = "gds") - expect_equal(genotypeFormat(h1), "gds") - h2 <- pecotmr:::.resolveGenotypeShard(gds_path) - expect_equal(genotypeFormat(h2), "gds") +test_that(".shardFormat tells a shard's format without reading it", { + f <- pecotmr:::.shardFormat + expect_equal(f(gds_path), "gds") + expect_equal(f(vcf_path), "vcf") + expect_equal(f("/nonexistent/x.vcf.bgz"), "vcf") + expect_equal(f("/nonexistent/x.bgen"), "bgen") + # A prefix with both a .pgen and a .bed beside it is PLINK2. + expect_equal(f(plink_prefix), "plink2") + # A forced format wins over the extension. + expect_equal(f(gds_path, format = "plink2"), "plink2") }) -test_that(".resolveGenotypeShard dispatches vcf by extension", { - skip_if_not_installed("VariantAnnotation") - h <- pecotmr:::.resolveGenotypeShard(vcf_path) - expect_equal(genotypeFormat(h), "vcf") +test_that(".resolveGenotypeShard refuses a VCF, GDS or PLINK1 shard", { + expect_error( + pecotmr:::.resolveGenotypeShard(gds_path), + "read as a genotype panel" + ) + expect_error( + pecotmr:::.resolveGenotypeShard(vcf_path, format = "vcf"), + "read as a genotype panel" + ) + expect_error( + pecotmr:::.resolveGenotypeShard(paste0(plink_prefix, ".bed")), + "read as a genotype panel" + ) + expect_error( + pecotmr:::.resolveGenotypeShard(plink_prefix, format = "plink1"), + "read as a genotype panel" + ) }) test_that(".resolveGenotypeShard probes the .pgen sidecar for an extension-less prefix", { @@ -730,7 +810,7 @@ test_that(".resolveGenotypeShard errors when the format cannot be determined", { # No recognized extension and no .bed/.pgen sidecar to probe. expect_error( pecotmr:::.resolveGenotypeShard(tempfile()), - "cannot determine genotype format" + "genoMeta: .* is neither a genotype file nor a PLINK prefix" ) }) @@ -739,8 +819,8 @@ test_that(".resolveGenotypeShard errors when the format cannot be determined", { test_that("show(GenotypeHandle) does not error", { gh <- new( "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", + path = "/tmp/test", + format = "plink2", snpInfo = makeTestSnpInfo(), nSamples = 100L, sampleIds = paste0("s", 1:100), @@ -756,15 +836,19 @@ test_that("show(GenotypeHandle) does not error", { # extractBlockGenotypes() already reads only the requested variants, so the # seed is an adapter rather than a new reader. What needs pinning is the three # ways an adapter like this goes quietly wrong: orientation, the meaning of a -# NULL index, and whether anything is read before it is asked for. +# NULL index, and whether anything is read before it is asked for. The handle +# is test_variants' PLINK2 copy: 349 variants x 100 samples. # --------------------------------------------------------------------------- +.gh_pgenHandle <- function() { + skip_if_not_installed("pgenlibr") + readGenotypeHandle(paste0(plink_prefix, ".pgen")) +} + test_that("extractBlockGenotypes answers an empty index without a reader", { - # Regression: snpStats::read.plink(select.snps = character(0)) SEGFAULTS, - # taking the session down rather than raising a catchable condition. The - # sharded branch always returned early; the single-file branch did not. - data(qtlDatasetExample, envir = environment()) - gh <- genotypeHandle(qtlDatasetExample) + # A reader need not accept an empty request -- snpStats segfaulted on + # one when it read PLINK1 -- so none is ever made. + gh <- .gh_pgenHandle() se <- extractBlockGenotypes(gh, snpIdx = integer(0)) expect_s4_class(se, "SummarizedExperiment") expect_equal(nrow(se), 0L) @@ -775,44 +859,42 @@ test_that("genotypeDelayedArray reports variants x samples", { # The Bioconductor assay orientation, which is the TRANSPOSE of # genotypes(). Backwards, this returns a plausible matrix and a # silently transposed LD matrix. - data(qtlDatasetExample, envir = environment()) - qd <- qtlDatasetExample - da <- genotypeDelayedArray(genotypeHandle(qd)) + gh <- .gh_pgenHandle() + da <- genotypeDelayedArray(gh) expect_s4_class(da, "DelayedMatrix") - expect_equal(dim(da), rev(dim(genotypes(qd)))) + expect_equal(dim(da), c(nrow(snpInfo(gh)), nSamples(gh))) }) test_that("genotypeDelayedArray values match genotypes transposed", { - data(qtlDatasetExample, envir = environment()) - qd <- qtlDatasetExample - da <- genotypeDelayedArray(genotypeHandle(qd)) - truth <- t(genotypes(qd)) + gh <- .gh_pgenHandle() + da <- genotypeDelayedArray(gh) + truth <- t(pecotmr:::.dosageMatrix(gh, 1:5, meanImpute = FALSE)) got <- as.matrix(da[1:5, 1:4]) - expect_equal(unname(got), unname(truth[1:5, 1:4])) - expect_identical(rownames(got), rownames(truth)[1:5]) - expect_identical(colnames(got), colnames(truth)[1:4]) + expect_equal(unname(got), unname(truth[, 1:4])) + expect_identical( + rownames(got), + normalizeVariantId(snpInfo(gh)$SNP[1:5]) + ) + expect_identical(colnames(got), sampleIds(gh)[1:4]) }) test_that("a NULL index means every row or column, not none", { - data(qtlDatasetExample, envir = environment()) - gh <- genotypeHandle(qtlDatasetExample) + gh <- .gh_pgenHandle() seed <- DelayedArray::seed(genotypeDelayedArray(gh)) full <- S4Arrays::extract_array(seed, list(NULL, NULL)) expect_equal(dim(full), c(nrow(snpInfo(gh)), nSamples(gh))) }) test_that("the seed answers an empty extraction on either axis", { - data(qtlDatasetExample, envir = environment()) - seed <- DelayedArray::seed( - genotypeDelayedArray(genotypeHandle(qtlDatasetExample)) - ) + gh <- .gh_pgenHandle() + seed <- DelayedArray::seed(genotypeDelayedArray(gh)) expect_equal( dim(S4Arrays::extract_array(seed, list(integer(0), NULL))), - c(0L, 165L) + c(0L, nSamples(gh)) ) expect_equal( dim(S4Arrays::extract_array(seed, list(NULL, integer(0)))), - c(200L, 0L) + c(nrow(snpInfo(gh)), 0L) ) }) @@ -820,8 +902,7 @@ 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 <- genotypeHandle(qtlDatasetExample) + gh <- .gh_pgenHandle() seed <- genotypeDelayedArray(gh)@seed expect_null(seed@dn[[2L]]) # not stored expect_identical(dimnames(seed)[[2L]], as.character(sampleIds(gh))) # derived @@ -830,8 +911,7 @@ test_that("genotypeDelayedArray stores the sample axis once, derives it on read" }) test_that(".emptyGenotypeHandle empties the sample axis as well as the variants", { - data(qtlDatasetExample, envir = environment()) - gh <- genotypeHandle(qtlDatasetExample) + gh <- .gh_pgenHandle() e <- pecotmr:::.emptyGenotypeHandle(gh) expect_equal(nrow(snpInfo(e)), 0L) expect_equal(length(sampleIds(e)), 0L) @@ -842,19 +922,20 @@ test_that(".emptyGenotypeHandle empties the sample axis as well as the variants" expect_equal(lengths(dimnames(seed)), c(0L, 0L)) }) -test_that(".emptySketch drops the sample axis on an RSE sketch", { - data(qtlDatasetExample, envir = environment()) - gh <- genotypeHandle(qtlDatasetExample) - empty <- pecotmr:::.emptySketch(pecotmr:::.genotypeExperiment(gh)) - h <- pecotmr:::.ldSketchHandle(empty) - expect_equal(length(sampleIds(h)), 0L) - expect_equal(nrow(snpInfo(h)), 0L) +test_that(".emptyLdRef drops both axes and the seed on an RSE sketch", { + # The seed carries every variant's metadata; an empty panel keeps none + # of it, only the record of what it was read from. + gh <- .gh_pgenHandle() + empty <- pecotmr:::.emptyLdRef(pecotmr:::.genotypeExperiment(gh)) + expect_equal(dim(empty), c(0L, 0L)) + expect_null(pecotmr:::.panelSeed(empty)) + expect_null(pecotmr:::.ldRefHandle(empty)) + expect_equal(pecotmr:::.ldRefFormat(empty), genotypeFormat(gh)) }) 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()) - gh <- genotypeHandle(qtlDatasetExample) + gh <- .gh_pgenHandle() reads <- 0L # Captured before mocking: calling extractBlockGenotypes by name inside # the mock would re-enter the mock, not the reader. @@ -877,8 +958,7 @@ test_that("nothing is read until a block is actually touched", { }) test_that("only the requested variants are read", { - data(qtlDatasetExample, envir = environment()) - gh <- genotypeHandle(qtlDatasetExample) + gh <- .gh_pgenHandle() seen <- integer(0) realExtract <- extractBlockGenotypes local_mocked_bindings( @@ -929,8 +1009,8 @@ test_that("pgenPtr returns the handle's pgen pointer", { # by the pgen reader, so the accessor's job is to report its absence. h <- new( "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", + path = "/tmp/test", + format = "plink2", snpInfo = makeTestSnpInfo(), nSamples = 100L, sampleIds = paste0("sample_", 1:100), diff --git a/tests/testthat/test_genotypeIo.R b/tests/testthat/test_genotypeIo.R index a30ff15da..808b0e094 100644 --- a/tests/testthat/test_genotypeIo.R +++ b/tests/testthat/test_genotypeIo.R @@ -17,18 +17,6 @@ test_that("readBim dummy data works", { expect_equal(nrow(res), 100) }) -test_that("readFam dummy data works", { - example_path <- "test_data/protocol_example.genotype.bed" - res <- pecotmr:::readFam(example_path) - expect_equal(nrow(res), 100) -}) - -test_that("openBed dummy data works", { - example_path <- "test_data/protocol_example.genotype.bed" - res <- pecotmr:::openBed(example_path) - expect_equal(res$class, "pgen") -}) - test_that("findValidFilePath works", { ref_path <- "test_data/protocol_example.genotype.bed" expect_error( @@ -61,7 +49,6 @@ test_that("findValidFilePath works", { ) }) - dummyGenoData <- function( number_of_samples = 10, number_of_snps = 10, @@ -212,7 +199,6 @@ dummyCovarData <- function( return(covar) } - test_that("Test loadGenotypeRegion", { res <- loadGenotypeRegion( "test_data/protocol_example.genotype" @@ -317,7 +303,7 @@ test_that("Test loadGenotypeRegion with region and no indels", { test_that("loadGenotypeRegion errors on missing genotype files", { expect_error( loadGenotypeRegion("/nonexistent/geno"), - "Genotype files not found" + "neither a genotype file nor a PLINK prefix" ) }) @@ -354,6 +340,17 @@ test_that("findStochasticMeta finds sidecar from GDS path", { expect_true(grepl("\\.(afreq|stochastic_meta\\.tsv)$", result)) }) +test_that("findStochasticMeta finds the sidecar of a BGEN or .vcf.bgz file", { + dir <- withr::local_tempdir() + file.create(file.path(dir, "sketch.afreq")) + for (file in c("sketch.bgen", "sketch.vcf.bgz", "sketch.VCF.GZ")) { + expect_equal( + pecotmr:::findStochasticMeta(file.path(dir, file)), + file.path(dir, "sketch.afreq") + ) + } +}) + test_that("findStochasticMeta returns NULL when no sidecar exists", { td <- test_path("test_data") result <- pecotmr:::findStochasticMeta(file.path( @@ -485,7 +482,6 @@ test_that("loadGenotypeRegion applies stochastic inversion with explicit sidecar expect_false(all(res$X == round(res$X), na.rm = TRUE)) }) - # =========================================================================== # readBim vroom-based tests # =========================================================================== @@ -506,22 +502,6 @@ test_that("readBim returns correct columns and types", { file.remove(bim_path) }) -# =========================================================================== -# tabixRegion -# =========================================================================== - -# =========================================================================== -# extractPhenotypeCoordinates -# =========================================================================== - -# =========================================================================== -# loadTsvRegion -# =========================================================================== - -# =========================================================================== -# batchLoadTwasWeights -# =========================================================================== - # =========================================================================== # .colocFilterCsByConcentration # =========================================================================== @@ -560,64 +540,6 @@ test_that(".colocFilterCsByConcentration returns numeric index vector", { # refVariantInfo # =========================================================================== -test_that("refVariantInfo processes precomputed bim with 6 columns", { - td <- test_path("test_data") - meta_file <- file.path(td, "ld_meta_refinfo_6col_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste( - "1", - "1000", - "1200", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.bim", - sep = "\t" - ), - "\n", - file = meta_file, - append = TRUE - ) - result <- refVariantInfo(meta_file, "chr1:1000-1190") - expect_true(is.data.frame(result)) - expect_true(all(c("chrom", "id", "pos", "A2", "A1") %in% colnames(result))) - expect_equal(nrow(result), 5L) -}) - -test_that("refVariantInfo processes precomputed bim with 9 columns", { - td <- test_path("test_data") - meta_file <- file.path(td, "ld_meta_refinfo_9col_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste( - "1", - "1000", - "1200", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.9col.bim", - sep = "\t" - ), - "\n", - file = meta_file, - append = TRUE - ) - result <- refVariantInfo(meta_file, "chr1:1000-1190") - expect_true(all( - c( - "chrom", - "id", - "pos", - "A2", - "A1", - "variance", - "allele_freq", - "n_nomiss" - ) %in% - colnames(result) - )) - expect_equal(nrow(result), 5L) - expect_equal(result$allele_freq, c(0.3, 0.4, 0.2, 0.5, 0.15)) -}) - # ---- invertMinmaxScaling ---- test_that("invertMinmaxScaling exactly recovers original U", { @@ -679,22 +601,25 @@ test_that("invertMinmaxScaling errors on mismatched lengths", { ) }) -# =========================================================================== -# batchLoadTwasWeights (additional coverage) -# =========================================================================== - -# =========================================================================== -# loadCovariateData with real fixture -# =========================================================================== - -# =========================================================================== -# loadTsvRegion with real tabix-indexed fixture -# =========================================================================== - # =========================================================================== # refVariantInfo with PLINK2 fixture # =========================================================================== +test_that("refVariantInfo reads a genotype file or prefix given directly", { + # It used to read every source as LD metadata, so a direct path failed + # whatever its format. + stem <- str_remove( + system.file("extdata", "toy_ref.bed", package = "pecotmr"), + "\\.bed$" + ) + bim <- read.table(str_c(stem, ".bim")) + plink1 <- refVariantInfo(stem) + expect_equal(nrow(plink1), nrow(bim)) + expect_equal(plink1$pos, bim[[4L]]) + vcf <- refVariantInfo(test_path("test_data", "test_variants.vcf.gz")) + expect_equal(nrow(vcf), 349L) +}) + test_that("refVariantInfo returns variant info for PLINK2 source", { skip_if_not_installed("pgenlibr") meta_file <- file.path(test_path("test_data"), "ld_meta_refinfo_tmp.tsv") @@ -954,59 +879,6 @@ test_that("matchVariantsToKeep returns all FALSE for non-matching variants", { expect_true(all(!mask)) }) -# =========================================================================== -# readVariantMetadata -# =========================================================================== - -test_that("readVariantMetadata reads 6-column bim file", { - tmp <- tempfile(fileext = ".bim") - on.exit(unlink(tmp), add = TRUE) - writeLines( - c( - "1\trs1\t0\t100\tA\tG", - "1\trs2\t0\t200\tC\tT" - ), - tmp - ) - res <- pecotmr:::readVariantMetadata(tmp) - expect_equal(nrow(res), 2) - expect_true("gpos" %in% names(res)) - expect_equal(as.character(res$chrom), c("1", "1")) - expect_equal(res$pos, c(100L, 200L)) -}) - -test_that("readVariantMetadata reads 9-column bim file", { - tmp <- tempfile(fileext = ".bim") - on.exit(unlink(tmp), add = TRUE) - writeLines( - c( - "1\trs1\t0\t100\tA\tG\t0.5\t0.3\t100", - "1\trs2\t0\t200\tC\tT\t0.4\t0.2\t99" - ), - tmp - ) - res <- pecotmr:::readVariantMetadata(tmp) - expect_equal(nrow(res), 2) - expect_true(all(c("variance", "allele_freq", "n_nomiss") %in% names(res))) -}) - -test_that("readVariantMetadata delegates to readPvar for .pvar files", { - pvar_path <- test_path("test_data", "test_variants.pvar") - res <- pecotmr:::readVariantMetadata(pvar_path) - expect_true(all(c("chrom", "id", "pos", "A1", "A2") %in% names(res))) - expect_false("gpos" %in% names(res)) -}) - -test_that("readVariantMetadata errors on unexpected column count", { - tmp <- tempfile(fileext = ".bim") - on.exit(unlink(tmp), add = TRUE) - writeLines(c("1\trs1\t0\t100\tA"), tmp) - expect_error( - pecotmr:::readVariantMetadata(tmp), - "Unexpected number of columns" - ) -}) - # =========================================================================== # matchVariantsToKeep (additional coverage) # =========================================================================== @@ -1052,10 +924,6 @@ test_that("matchVariantsToKeep uses position-only matching when no alleles", { expect_true(mask[5]) }) -# =========================================================================== -# standardiseSumstatsColumns -# =========================================================================== - # =========================================================================== # readGenotypes + extractblockgenotypes: plink2 tests (replacing load_plink2_data) # =========================================================================== @@ -1158,10 +1026,6 @@ test_that("readGenotypes plink2 sample names match psam IIDs", { expect_equal(length(unique(sampleIds(handle))), 100L) }) -# =========================================================================== -# loadPhenotypeData with real BED-style tabix-indexed fixture -# =========================================================================== - # ============================================================================= # Removed during the post-S4-refactor cleanup # ----------------------------------------------------------------------------- @@ -1227,7 +1091,7 @@ test_that("format detection supports dotted PLINK2 prefixes", { ) on.exit(unlink(paste0(prefix, c(".pgen", ".pvar", ".psam"))), add = TRUE) - expect_equal(pecotmr:::.h2DetectFormat(prefix), "plink2") + expect_equal(pecotmr:::.genotypePathFormat(prefix), "plink2") }) # Shared helper: validate the output structure from loadGenotypeRegion @@ -1261,19 +1125,20 @@ checkGenotypeResult <- function( ) } -# --- readGenotypes: PLINK1 (snpStats) ---------------------------------------- +# --- readGenotypes: PLINK1 (PlinkMatrix) ------------------------------------- -test_that("readGenotypes creates plink1 handle", { - skip_if_not_installed("snpStats") - handle <- readGenotypeHandle(plink_prefix, format = "plink1") - expect_s4_class(handle, "GenotypeHandle") - expect_equal(genotypeFormat(handle), "plink1") - expect_equal(nSamples(handle), n_samples) - expect_equal(nrow(snpInfo(handle)), n_variants) +test_that("readGenotypes reads a PLINK1 fileset as a panel", { + skip_if_not_installed("PlinkMatrix") + panel <- readGenotypes(plink1Prefix = plink_prefix) + expect_s4_class(panel, "RangedSummarizedExperiment") + expect_equal(dim(panel), c(n_variants, n_samples)) + expect_equal(S4Vectors::metadata(panel)$genotypeSource$format, "plink1") + expect_s4_class(pecotmr:::.panelSeed(panel), "GenotypeDosageSeed") + expect_null(pecotmr:::.ldRefHandle(panel)) }) test_that("loadGenotypeRegion loads plink1 via dispatch", { - skip_if_not_installed("snpStats") + skip_if_not_installed("PlinkMatrix") # Use .genotype suffix plink1 files tested elsewhere in test_file_utils plink1_path <- file.path(test_data_dir, "protocol_example.genotype") skip_if( @@ -1339,13 +1204,15 @@ test_that("loadGenotypeRegion errors on empty region for plink2", { # --- readGenotypes: VCF (VariantAnnotation) ----------------------------------- -test_that("readGenotypes creates vcf handle", { +test_that("readGenotypes reads a VCF as a panel over its own seed", { skip_if_not_installed("VariantAnnotation") - handle <- readGenotypeHandle(vcf_path, format = "vcf") - expect_s4_class(handle, "GenotypeHandle") - expect_equal(genotypeFormat(handle), "vcf") - expect_equal(nSamples(handle), n_samples) - expect_equal(nrow(snpInfo(handle)), n_variants) + panel <- readGenotypes(vcf_path) + expect_s4_class(panel, "RangedSummarizedExperiment") + expect_equal(dim(panel), c(n_variants, n_samples)) + # No handle: the panel reads through a GenotypeDosageSeed, and records + # where it came from itself. + expect_null(pecotmr:::.ldRefHandle(panel)) + expect_equal(S4Vectors::metadata(panel)$genotypeSource$format, "vcf") }) test_that("loadGenotypeRegion loads VCF via dispatch", { @@ -1386,14 +1253,14 @@ test_that("loadGenotypeRegion filters VCF indels", { # --- readGenotypes: GDS (SNPRelate) ------------------------------------------- -test_that("readGenotypes creates gds handle", { - skip_if_not_installed("SNPRelate") +test_that("readGenotypes reads a GDS file as a panel over its own seed", { skip_if_not_installed("gdsfmt") - handle <- readGenotypeHandle(gds_path, format = "gds") - expect_s4_class(handle, "GenotypeHandle") - expect_equal(genotypeFormat(handle), "gds") - expect_equal(nSamples(handle), n_samples) - expect_equal(nrow(snpInfo(handle)), n_variants) + skip_if_not_installed("GDSArray") + panel <- readGenotypes(gds_path) + expect_s4_class(panel, "RangedSummarizedExperiment") + expect_equal(dim(panel), c(n_variants, n_samples)) + expect_null(pecotmr:::.ldRefHandle(panel)) + expect_equal(S4Vectors::metadata(panel)$genotypeSource$format, "gds") }) test_that("loadGenotypeRegion loads GDS via dispatch", { @@ -1440,12 +1307,16 @@ test_that("loadGenotypeRegion errors on empty region for GDS", { # --- Cross-format consistency ------------------------------------------------- test_that("all formats return same dimensions and positions via loadGenotypeRegion", { - skip_if_not_installed("snpStats") + skip_if_not_installed("PlinkMatrix") skip_if_not_installed("pgenlibr") skip_if_not_installed("VariantAnnotation") skip_if_not_installed("SNPRelate") p2 <- loadGenotypeRegion(plink_prefix, returnVariantInfo = TRUE) + p1 <- loadGenotypeRegion( + paste0(plink_prefix, ".bed"), + returnVariantInfo = TRUE + ) vcf <- suppressWarnings(loadGenotypeRegion( vcf_path, returnVariantInfo = TRUE @@ -1453,22 +1324,31 @@ test_that("all formats return same dimensions and positions via loadGenotypeRegi gds <- loadGenotypeRegion(gds_path, returnVariantInfo = TRUE) # Same dimensions + expect_equal(dim(p2$X), dim(p1$X)) expect_equal(dim(p2$X), dim(vcf$X)) expect_equal(dim(p2$X), dim(gds$X)) # Same positions + expect_equal(p2$variant_info$pos, p1$variant_info$pos) expect_equal(p2$variant_info$pos, vcf$variant_info$pos) expect_equal(p2$variant_info$pos, gds$variant_info$pos) }) test_that("PLINK1 and PLINK2 readGenotypes return consistent alleles", { - skip_if_not_installed("snpStats") + skip_if_not_installed("PlinkMatrix") skip_if_not_installed("pgenlibr") - h1 <- readGenotypeHandle(plink_prefix, format = "plink1") - h2 <- readGenotypeHandle(plink_prefix, format = "plink2") - - expect_equal(snpInfo(h1)$A1, snpInfo(h2)$A1) - expect_equal(snpInfo(h1)$A2, snpInfo(h2)$A2) + # The fixture's two PLINK copies hold the same variants and calls, read + # by different readers: PlinkMatrix and pgenlibr. + p1 <- readGenotypes(plink1Prefix = plink_prefix) + p2 <- readGenotypes(plink2Prefix = plink_prefix) + rr1 <- S4Vectors::mcols(SummarizedExperiment::rowRanges(p1)) + rr2 <- S4Vectors::mcols(SummarizedExperiment::rowRanges(p2)) + expect_equal(rr1$A1, rr2$A1) + expect_equal(rr1$A2, rr2$A2) + expect_equal( + as.matrix(SummarizedExperiment::assay(p1, "dosage")), + as.matrix(SummarizedExperiment::assay(p2, "dosage")) + ) }) # --- loadGenotypeRegion (dispatch) ----------------------------------------- @@ -1514,7 +1394,10 @@ test_that("loadGenotypeRegion applies region filter", { }) test_that("loadGenotypeRegion errors on unrecognized format", { - expect_error(loadGenotypeRegion("/nonexistent/file.xyz"), "not found") + expect_error( + loadGenotypeRegion("/nonexistent/file.xyz"), + "loadGenotypeRegion: .* is neither a genotype file nor a PLINK prefix" + ) }) # =========================================================================== @@ -1541,6 +1424,22 @@ test_that("extractBlockGenotypes returns SummarizedExperiment", { expect_true("A2" %in% names(S4Vectors::mcols(rr))) }) +test_that("extractBlockGenotypes mean-imputes a missing call on request", { + skip_if_not_installed("DBI") + skip_if_not_installed("RSQLite") + # The BGEN fixture flags sample 2 missing at variant 3. + handle <- readGenotypeHandle(.bgw_fixture()$path) + dosageOf <- function(meanImpute) { + se <- extractBlockGenotypes(handle, 1:5, meanImpute = meanImpute) + t(as.matrix(SummarizedExperiment::assay(se, "dosage"))) + } + raw <- dosageOf(FALSE) + expect_true(is.na(raw[2L, 3L])) + imputed <- dosageOf(TRUE) + expect_equal(imputed[2L, 3L], mean(raw[-2L, 3L])) + expect_equal(imputed[-2L, ], raw[-2L, ]) +}) + # ============================================================================= # adjustPips # ============================================================================= @@ -1550,7 +1449,11 @@ test_that("extractBlockGenotypes returns SummarizedExperiment", { .makeAdjustEntry <- function(vids, maxNumSingleEffects = 2L) { p <- length(vids) set.seed(11L) - lbf <- matrix(rnorm(maxNumSingleEffects * p), nrow = maxNumSingleEffects, ncol = p) + lbf <- matrix( + rnorm(maxNumSingleEffects * p), + nrow = maxNumSingleEffects, + ncol = p + ) colnames(lbf) <- vids alpha <- lbfToAlpha(lbf) pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) @@ -1588,22 +1491,10 @@ test_that("extractBlockGenotypes returns SummarizedExperiment", { } # Per-backend single-file constructor + per-chromosome genoMeta payloads. +# Each payload names its file: the fixtures ship a .bed and a .pgen at one +# stem, and a bare stem with both is read as PLINK2. A PLINK1 set is not a +# sharded handle but stacked panels, tested with the VCF and GDS sets. .shardBackends <- list( - plink1 = list( - pkg = "snpStats", - ref = function(sfx) { - GenotypeHandle( - plink1Prefix = file.path( - test_data_dir, - paste0("test_variants", sfx) - ) - ) - }, - p21 = file.path(test_data_dir, "test_variants"), - p22 = file.path(test_data_dir, "test_variants_chr22") - ), - # PLINK2 payloads carry the .pgen extension because the fixtures also ship a - # .bed at the same stem; an explicit extension (or format=) disambiguates. plink2 = list( pkg = "pgenlibr", ref = function(sfx) { @@ -1616,32 +1507,6 @@ test_that("extractBlockGenotypes returns SummarizedExperiment", { }, p21 = file.path(test_data_dir, "test_variants.pgen"), p22 = file.path(test_data_dir, "test_variants_chr22.pgen") - ), - vcf = list( - pkg = "VariantAnnotation", - ref = function(sfx) { - GenotypeHandle( - path = file.path( - test_data_dir, - paste0("test_variants", sfx, ".vcf.gz") - ) - ) - }, - p21 = file.path(test_data_dir, "test_variants.vcf.gz"), - p22 = file.path(test_data_dir, "test_variants_chr22.vcf.gz") - ), - gds = list( - pkg = "SNPRelate", - ref = function(sfx) { - GenotypeHandle( - path = file.path( - test_data_dir, - paste0("test_variants", sfx, ".gds") - ) - ) - }, - p21 = file.path(test_data_dir, "test_variants.gds"), - p22 = file.path(test_data_dir, "test_variants_chr22.gds") ) ) @@ -1700,12 +1565,12 @@ for (.bk in names(.shardBackends)) { } test_that("single-shard sharded handle equals the single-file handle", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") ref <- GenotypeHandle( - plink1Prefix = file.path(test_data_dir, "test_variants") + plink2Prefix = file.path(test_data_dir, "test_variants") ) sh <- GenotypeHandle( - genoMeta = c("21" = file.path(test_data_dir, "test_variants")) + genoMeta = c("21" = file.path(test_data_dir, "test_variants.pgen")) ) expect_equal(length(chromPaths(sh)), 1L) expect_equal(nrow(snpInfo(sh)), nrow(snpInfo(ref))) @@ -1713,7 +1578,7 @@ test_that("single-shard sharded handle equals the single-file handle", { }) test_that("readGenotypes(genoMeta=) forwards `format` to the shard reader", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") # Regression: the path = "missing" method bound `format` to its own formal # and then called GenotypeHandle(...) without it, so an explicit format was # silently dropped and every shard fell back to extension probing. @@ -1722,34 +1587,34 @@ test_that("readGenotypes(genoMeta=) forwards `format` to the shard reader", { local_mocked_bindings( .resolveGenotypeShard = function(p, format = NULL) { seen$fmt <- if (is.null(format)) "" else format - pecotmr:::.makePlink1Handle(p) + pecotmr:::.makePlink2Handle(p) }, .package = "pecotmr" ) readGenotypes( - genoMeta = c("21" = file.path(test_data_dir, "test_variants")), - format = "plink1" + genoMeta = c("21" = file.path(test_data_dir, "test_variants.pgen")), + format = "plink2" ) - expect_identical(seen$fmt, "plink1") + expect_identical(seen$fmt, "plink2") }) test_that("genoMeta meta-file form matches the named-vector form", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") td_abs <- normalizePath(test_data_dir) metafile <- tempfile(fileext = ".tsv") writeLines( c( "#chr\tpath", - paste0("21\t", file.path(td_abs, "test_variants")), - paste0("22\t", file.path(td_abs, "test_variants_chr22")) + paste0("21\t", file.path(td_abs, "test_variants.pgen")), + paste0("22\t", file.path(td_abs, "test_variants_chr22.pgen")) ), metafile ) hFile <- GenotypeHandle(genoMeta = metafile) hVec <- GenotypeHandle( genoMeta = c( - "21" = file.path(td_abs, "test_variants"), - "22" = file.path(td_abs, "test_variants_chr22") + "21" = file.path(td_abs, "test_variants.pgen"), + "22" = file.path(td_abs, "test_variants_chr22.pgen") ) ) expect_equal(nrow(snpInfo(hFile)), nrow(snpInfo(hVec))) @@ -1763,7 +1628,7 @@ test_that("genoMeta meta-file form matches the named-vector form", { # =========================================================================== # Coverage top-ups for R/genotypeIo.R: dispatch/handle error stops, empty- and # missing-chromosome block paths, format-specific extractor edge cases, the -# GDS LD path, .h2DetectFormat / .plinkStem branches, resolvePlink2Paths +# GDS LD path, format detection / stem branches, resolvePlink2Paths # validation, readAfreq zstd guard, readStochasticMeta validation, the plink1 # refVariantInfo path with a multi-row region, and the non-integer-dosage # warning in loadGenotypeRegion. @@ -1778,61 +1643,25 @@ test_that("readGenotypes errors on unsupported format", { ) }) -test_that(".makeGdsHandle errors when GDS file is absent", { - skip_if_not_installed("SNPRelate") - skip_if_not_installed("gdsfmt") - expect_error( - pecotmr:::.makeGdsHandle("/no/such/file.gds"), - "GDS file.*File does not exist" - ) -}) - -test_that(".makeVcfHandle errors when VCF file is absent", { - skip_if_not_installed("VariantAnnotation") +test_that("a PLINK1 panel errors when its trio is absent", { + skip_if_not_installed("PlinkMatrix") expect_error( - pecotmr:::.makeVcfHandle("/no/such/file.vcf.gz"), - "VCF file.*File does not exist" - ) -}) - -test_that(".makePlink1Handle errors when plink1 trio is absent", { - skip_if_not_installed("snpStats") - expect_error( - pecotmr:::.makePlink1Handle(file.path( - tempdir(), - "missingPlink1Prefix" - )), + readGenotypes( + plink1Prefix = file.path(tempdir(), "missingPlink1Prefix") + ), "Plink file.*File does not exist" ) }) -# --- extractBlockGenotypes: NULL-from-extractor guard (line 237) ------------- - -test_that("extractBlockGenotypes returns NULL when extractor yields NULL", { - skip_if_not_installed("VariantAnnotation") - td <- test_path("test_data") - handle <- readGenotypeHandle( - file.path(td, "test_variants.vcf.gz"), - format = "vcf" - ) - # Force the format-specific extractor to return NULL so the early-return - # guard in extractBlockGenotypes is exercised. - testthat::local_mocked_bindings( - .extractBlockVcf = function(handle, snpIdx) NULL, - .package = "pecotmr" - ) - expect_null(extractBlockGenotypes(handle, 1:3)) -}) - # --- .extractBlockSharded: empty block + missing-chromosome stop ------------- test_that("extractBlockGenotypes on a sharded handle handles an empty block", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") td <- test_path("test_data") shard <- GenotypeHandle( genoMeta = c( - "21" = file.path(td, "test_variants"), - "22" = file.path(td, "test_variants_chr22") + "21" = file.path(td, "test_variants.pgen"), + "22" = file.path(td, "test_variants_chr22.pgen") ) ) se <- extractBlockGenotypes(shard, integer(0)) @@ -1844,12 +1673,12 @@ test_that("extractBlockGenotypes on a sharded handle handles an empty block", { }) test_that("sharded extraction errors for a chromosome with no payload", { - skip_if_not_installed("snpStats") + skip_if_not_installed("pgenlibr") td <- test_path("test_data") shard <- GenotypeHandle( genoMeta = c( - "21" = file.path(td, "test_variants"), - "22" = file.path(td, "test_variants_chr22") + "21" = file.path(td, "test_variants.pgen"), + "22" = file.path(td, "test_variants_chr22.pgen") ) ) # Drop the chr22 payload but keep its variants in @snpInfo, so routing a @@ -1862,101 +1691,6 @@ test_that("sharded extraction errors for a chromosome with no payload", { ) }) -# --- .extractBlockGds: NULL/empty result guard (line 336) -------------------- - -test_that(".extractBlockGds returns NULL when snpgdsGetGeno yields NULL", { - skip_if_not_installed("SNPRelate") - skip_if_not_installed("gdsfmt") - td <- test_path("test_data") - handle <- readGenotypeHandle( - file.path(td, "test_variants.gds"), - format = "gds" - ) - testthat::local_mocked_bindings( - snpgdsGetGeno = function(...) NULL, - .package = "SNPRelate" - ) - expect_null(pecotmr:::.extractBlockGds(handle, 1:3)) -}) - -# --- .extractBlockVcf: missing-genotype ("./.") parsing (line 361) ----------- - -.gioMakeMissingGtVcf <- function() { - dir <- tempfile("gioVcf_") - dir.create(dir) - plain <- file.path(dir, "mini.vcf") - writeLines( - c( - "##fileformat=VCFv4.2", - "##contig=", - "##FORMAT=", - paste( - "#CHROM", - "POS", - "ID", - "REF", - "ALT", - "QUAL", - "FILTER", - "INFO", - "FORMAT", - "S1", - "S2", - "S3", - sep = "\t" - ), - paste( - "21", - "1000", - "chr1:100:A:G", - "A", - "G", - ".", - ".", - ".", - "GT", - "0/1", - "./.", - "1/1", - sep = "\t" - ), - paste( - "21", - "2000", - "chr1:200:A:G", - "C", - "T", - ".", - ".", - ".", - "GT", - "0|0", - "1|1", - "./.", - sep = "\t" - ) - ), - plain - ) - bg <- Rsamtools::bgzip(plain, paste0(plain, ".gz"), overwrite = TRUE) - Rsamtools::indexTabix(bg, format = "vcf") - bg -} - -test_that(".extractBlockVcf parses missing genotypes as NA", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Rsamtools") - bg <- .gioMakeMissingGtVcf() - handle <- readGenotypeHandle(bg, format = "vcf") - expect_equal(nrow(snpInfo(handle)), 2L) - # meanImpute=FALSE keeps the "./." dosages as NA - se <- extractBlockGenotypes(handle, 1:2, meanImpute = FALSE) - dosage <- SummarizedExperiment::assay(se, "dosage") - expect_true(any(is.na(dosage))) - # Exactly the two "./." entries become NA (one per variant) - expect_equal(sum(is.na(dosage)), 2L) -}) - # --- .extractBlockPlink2: stale-pointer reopen path (lines 402-403) ---------- test_that("plink2 extraction reopens a stale (deserialized) pgen pointer", { @@ -1989,34 +1723,15 @@ test_that("computeLd on a GDS panel uses the in-memory path", { # The native SNPRelate route is no longer chosen implicitly by format: # it applies a different missing-data policy, so it is opt-in via # onDisk = TRUE rather than a silent consequence of the panel's format. - skip_if_not_installed("SNPRelate") skip_if_not_installed("gdsfmt") - td <- test_path("test_data") - handle <- readGenotypeHandle( - file.path(td, "test_variants.gds"), - format = "gds" - ) - R <- computeLd(handle, snpIdx = 1:6, backend = "internal") + skip_if_not_installed("GDSArray") + panel <- readGenotypes(test_path("test_data", "test_variants.gds")) + R <- computeLd(panel, snpIdx = 1:6, backend = "internal") expect_equal(dim(R), c(6L, 6L)) expect_true(all(is.finite(R))) expect_false(anyNA(R)) expect_equal(unname(diag(R)), rep(1, 6), tolerance = 1e-6) - expect_identical(rownames(R), snpInfo(handle)$SNP[1:6]) -}) - -test_that("computeLd returns identity when extraction is NULL", { - skip_if_not_installed("pgenlibr") - td <- test_path("test_data") - handle <- readGenotypeHandle( - file.path(td, "test_variants"), - format = "plink2" - ) - testthat::local_mocked_bindings( - extractBlockGenotypes = function(...) NULL, - .package = "pecotmr" - ) - R <- computeLd(handle, snpIdx = 1:4, backend = "internal") - expect_equal(R, diag(4)) + expect_identical(rownames(R), rownames(panel)[1:6]) }) test_that("computeLd returns identity for a single-variant block", { @@ -2042,49 +1757,74 @@ test_that("computeLd on a panel computes via the general path", { expect_equal(unname(diag(R)), rep(1, 5), tolerance = 1e-6) }) -# --- .h2DetectFormat branches ------------------------------------------------ +# --- genotype format detection ---------------------------------------------- -test_that(".h2DetectFormat detects .annot.gz as ldsc_annot", { - expect_equal(pecotmr:::.h2DetectFormat("something.annot.gz"), "ldsc_annot") -}) - -test_that(".h2DetectFormat detects a plink1 prefix by .bed sidecar", { +test_that("a PLINK prefix is told by the PLINK file beside it", { td <- test_path("test_data") - # protocol_example.genotype has .bed/.bim/.fam but no .pgen + # protocol_example.genotype has .bed/.bim/.fam but no .pgen. expect_equal( - pecotmr:::.h2DetectFormat(file.path(td, "protocol_example.genotype")), + pecotmr:::.genotypePathFormat( + file.path(td, "protocol_example.genotype") + ), "plink1" ) -}) - -test_that(".h2DetectFormat detects a gds-only prefix", { + # test_variants has both: PLINK2, which can hold dosages, wins. + expect_equal( + pecotmr:::.genotypePathFormat(file.path(td, "test_variants")), + "plink2" + ) + # A GDS file is named by its own path, never by a stem beside it. stem <- tempfile("gioGdsStem_") file.create(paste0(stem, ".gds")) on.exit(unlink(paste0(stem, ".gds")), add = TRUE) - expect_equal(pecotmr:::.h2DetectFormat(stem), "gds") -}) - -test_that(".h2DetectFormat errors on an unknown extension", { - expect_error( - pecotmr:::.h2DetectFormat(file.path(tempdir(), "thing.qzx")), - "Cannot detect format from extension" - ) + expect_null(pecotmr:::.genotypePathFormat(stem)) }) -test_that(".h2DetectFormat errors on an extensionless path with no sidecars", { +test_that("a path naming no genotype format is refused by its caller", { + for (path in file.path(tempdir(), c("thing.qzx", "noSuchStemXyz"))) { + expect_error( + pecotmr:::.requireGenotypeFormat(path, "caller"), + "caller: .* is neither a genotype file nor a PLINK prefix" + ) + } expect_error( - pecotmr:::.h2DetectFormat(file.path(tempdir(), "noSuchStemXyz")), - "Cannot detect genotype format for path" + readGenotypes(file.path(tempdir(), "thing.qzx")), + "readGenotypes: .* is neither a genotype file nor a PLINK prefix" ) }) -# --- .plinkStem strips a recognized plink extension -------------------------- +# --- .genotypeStem strips the extension naming a format ----------------------- -test_that(".plinkStem strips a known plink extension", { - td <- test_path("test_data") +test_that(".genotypeStem strips the extension naming a format", { expect_equal( - pecotmr:::.plinkStem(file.path(td, "test_variants.bed")), - file.path(td, "test_variants") + pecotmr:::.genotypeStem(c( + "a/x.vcf.gz", + "x.VCF.BGZ", + "x.bcf", + "x.gds", + "x.bgen", + "x.bed", + "x.bim", + "x.pgen", + "x.pvar.zst", + "x.Psam", + "plink/stem", + "dotted.prefix.chr21" + )), + c( + "a/x", + "x", + "x", + "x", + "x", + "x", + "x", + "x", + "x", + "x", + "plink/stem", + "dotted.prefix.chr21" + ) ) }) @@ -2210,24 +1950,23 @@ test_that("refVariantInfo applies a multi-row data.frame region filter", { expect_true(all(info$pos >= 17513228 & info$pos <= 17592874)) }) -# --- loadGenotypeRegion: non-integer dosages without a sidecar (warning) ----- +# --- loadGenotypeRegion: non-integer dosages without a sidecar -------------- -test_that("loadGenotypeRegion warns on non-integer dosages without a sidecar", { +test_that("loadGenotypeRegion keeps imputed dosages without a sidecar", { skip_if_not_installed("pgenlibr") td <- test_path("test_data") # dummy_data is a plink2 fixture with no .afreq / .stochastic_meta sidecar. - # Inject fractional dosages via the extractor so the no-sidecar branch sees - # non-integer values and emits its warning. + # A dosage need not be a whole number, so fractional dosages without a + # sidecar are an imputed file's, not a sketch's: returned untouched, and + # without a warning about restoring a scale they never had. testthat::local_mocked_bindings( .extractBlockPlink2 = function(handle, snpIdx) { matrix(0.5, nrow = nSamples(handle), ncol = length(snpIdx)) }, .package = "pecotmr" ) - expect_warning( - loadGenotypeRegion(file.path(td, "dummy_data")), - "Non-integer genotype values detected" - ) + expect_no_warning(X <- loadGenotypeRegion(file.path(td, "dummy_data"))) + expect_true(all(X == 0.5)) }) # ---- fileIdx + snpInfo subsetting (memory-safe LD-sketch trimming) ----------- @@ -2273,7 +2012,6 @@ test_that(".subsetGenotypeHandle is NULL-safe and a no-op when nothing dropped", ) }) - # --------------------------------------------------------------------------- # extractBlockGenotypes: an unsorted request must not mislabel the block. # @@ -2298,27 +2036,45 @@ test_that(".subsetGenotypeHandle is NULL-safe and a no-op when nothing dropped", expect_equal(unname(aP), unname(a6[perm, , drop = FALSE])) } -test_that("extractBlockGenotypes honours request order (plink1)", { - .gio_orderCheck("plink1", test_path("test_data", "test_variants")) -}) - test_that("extractBlockGenotypes honours request order (plink2)", { skip_if_not_installed("pgenlibr") .gio_orderCheck("plink2", test_path("test_data", "test_variants")) }) -test_that("extractBlockGenotypes honours request order (gds)", { - skip_if_not_installed("SNPRelate") +test_that("a PLINK1 panel honours request order", { + # snpStats returned file order when it read PLINK1; the panel's seed + # reads each block in file order and lays it out as asked. + skip_if_not_installed("PlinkMatrix") + panel <- readGenotypes( + plink1Prefix = test_path("test_data", "test_variants") + ) + a <- SummarizedExperiment::assay(panel, "dosage") + perm <- c(4L, 1L, 6L, 2L, 5L, 3L) + expect_equal( + unname(as.matrix(a[perm, 1:4])), + unname(as.matrix(a[1:6, 1:4])[perm, , drop = FALSE]) + ) +}) + +test_that("a GDS panel honours request order", { skip_if_not_installed("gdsfmt") - .gio_orderCheck("gds", test_path("test_data", "test_variants.gds")) + skip_if_not_installed("GDSArray") + panel <- readGenotypes(test_path("test_data", "test_variants.gds")) + a <- SummarizedExperiment::assay(panel, "dosage") + perm <- c(4L, 1L, 6L, 2L, 5L, 3L) + expect_equal( + unname(as.matrix(a[perm, 1:4])), + unname(as.matrix(a[1:6, 1:4])[perm, , drop = FALSE]) + ) }) test_that("a delayed read honours request order too", { # DelayedArray hands the index straight to extract_array(), so the seed # inherits whatever the reader does. + skip_if_not_installed("pgenlibr") handle <- readGenotypeHandle( test_path("test_data", "test_variants"), - format = "plink1" + format = "plink2" ) a <- genotypeDelayedArray(handle) perm <- c(4L, 1L, 6L, 2L, 5L, 3L) @@ -2329,14 +2085,15 @@ test_that("a delayed read honours request order too", { }) test_that("LD from a sketch does not depend on the request order", { + skip_if_not_installed("pgenlibr") handle <- readGenotypeHandle( test_path("test_data", "test_variants"), - format = "plink1" + format = "plink2" ) ids <- snpInfo(handle)$SNP[1:6] shuffled <- ids[c(4L, 1L, 6L, 2L, 5L, 3L)] - sorted <- pecotmr:::.ldFromSketch(handle, ids, label = "t") - mixed <- pecotmr:::.ldFromSketch(handle, shuffled, label = "t") + sorted <- pecotmr:::.ldFromRef(handle, ids, label = "t") + mixed <- pecotmr:::.ldFromRef(handle, shuffled, label = "t") expect_identical(rownames(mixed), shuffled) expect_equal(sorted[ids, ids], mixed[ids, ids]) }) @@ -2350,7 +2107,6 @@ test_that(".restoreRequestedOrder refuses a short block", { ) }) - # --------------------------------------------------------------------------- # computeLd(onDisk = TRUE): read the correlation off the GDS without ever # materialising dosages. The dosage matrix scales with samples x variants @@ -2360,10 +2116,8 @@ test_that(".restoreRequestedOrder refuses a short block", { test_that("onDisk LD matches the in-memory path on complete data", { skip_if_not_installed("SNPRelate") - handle <- readGenotypeHandle( - test_path("test_data", "test_variants.gds"), - format = "gds" - ) + skip_if_not_installed("GDSArray") + handle <- readGenotypes(test_path("test_data", "test_variants.gds")) idx <- c(4L, 1L, 6L, 2L, 5L, 3L) onDisk <- computeLd( handle, @@ -2379,26 +2133,25 @@ test_that("onDisk LD matches the in-memory path on complete data", { test_that("onDisk LD labels and orders by the request", { skip_if_not_installed("SNPRelate") - handle <- readGenotypeHandle( - test_path("test_data", "test_variants.gds"), - format = "gds" - ) + skip_if_not_installed("GDSArray") + handle <- readGenotypes(test_path("test_data", "test_variants.gds")) idx <- c(4L, 1L, 6L, 2L, 5L, 3L) R <- computeLd(handle, snpIdx = idx, backend = "snprelate", onDisk = TRUE) # snpgdsLDMat() returns file order and labels nothing; both are corrected. - expect_identical(rownames(R), snpInfo(handle)$SNP[idx]) + expect_identical( + rownames(R), + SummarizedExperiment::rowRanges(handle)$SNP[idx] + ) expect_identical(colnames(R), rownames(R)) }) test_that("onDisk LD is refused where it cannot be honoured", { skip_if_not_installed("SNPRelate") - gds <- readGenotypeHandle( - test_path("test_data", "test_variants.gds"), - format = "gds" - ) - plink <- readGenotypeHandle( - test_path("test_data", "test_variants"), - format = "plink1" + skip_if_not_installed("GDSArray") + skip_if_not_installed("PlinkMatrix") + gds <- readGenotypes(test_path("test_data", "test_variants.gds")) + plink <- readGenotypes( + plink1Prefix = test_path("test_data", "test_variants") ) expect_error( computeLd(plink, backend = "snprelate", onDisk = TRUE), @@ -2422,9 +2175,10 @@ test_that("ordering uses FILE position, not the snpInfo row number", { # A row-subset handle's snpInfo rows are no longer file positions, so # sorting the request by row number would ask the backend for the wrong # ascending order. fileIdx carries the real mapping. + skip_if_not_installed("pgenlibr") handle <- readGenotypeHandle( test_path("test_data", "test_variants"), - format = "plink1" + format = "plink2" ) keep <- c(9L, 2L, 7L, 4L) sub <- pecotmr:::.subsetGenotypeHandle(handle, keep) @@ -2440,7 +2194,6 @@ test_that("ordering uses FILE position, not the snpInfo row number", { expect_equal(unname(got), unname(want)) }) - # --------------------------------------------------------------------------- # readGenotypes(): the exported entry point returns a genotype PANEL. # @@ -2450,14 +2203,15 @@ test_that("ordering uses FILE position, not the snpInfo row number", { # --------------------------------------------------------------------------- test_that("readGenotypes returns a panel, not a handle", { + skip_if_not_installed("pgenlibr") panel <- readGenotypes( test_path("test_data", "test_variants"), - format = "plink1" + format = "plink2" ) expect_s4_class(panel, "RangedSummarizedExperiment") handle <- readGenotypeHandle( test_path("test_data", "test_variants"), - format = "plink1" + format = "plink2" ) # variants x samples, the Bioconductor orientation. expect_equal(nrow(panel), nrow(snpInfo(handle))) @@ -2472,20 +2226,23 @@ test_that("readGenotypes returns a panel, not a handle", { }) test_that("the panel's assay is delayed and its seed is the handle", { + skip_if_not_installed("pgenlibr") panel <- readGenotypes( test_path("test_data", "test_variants"), - format = "plink1" + format = "plink2" ) a <- SummarizedExperiment::assay(panel, "dosage") expect_s4_class(a, "DelayedMatrix") handle <- readGenotypeHandle( test_path("test_data", "test_variants"), - format = "plink1" + format = "plink2" ) - expect_identical(pecotmr:::.ldSketchHandle(panel), handle) + # Equal, not identical: each read opens its own pgen pointer. + expect_equal(pecotmr:::.ldRefHandle(panel), handle) }) test_that("a panel answers panel questions without the handle", { + skip_if_not_installed("PlinkMatrix") panel <- readGenotypes( test_path("test_data", "test_variants"), format = "plink1" @@ -2500,6 +2257,7 @@ test_that("a panel answers panel questions without the handle", { }) test_that("computeLd accepts the panel readGenotypes returns", { + skip_if_not_installed("PlinkMatrix") panel <- readGenotypes( test_path("test_data", "test_variants"), format = "plink1" @@ -2513,6 +2271,7 @@ test_that("readGenotypes names a panel by keyword when path is missing", { # GenotypeHandle is internal now, so its source vocabulary (prefixes, # explicit triplets, genoMeta) has to stay reachable from the public # entry point or it is gone from the API entirely. + skip_if_not_installed("PlinkMatrix") stem <- test_path("test_data", "test_variants") byPath <- readGenotypes(stem, format = "plink1") byPrefix <- readGenotypes(plink1Prefix = stem) @@ -2522,6 +2281,7 @@ test_that("readGenotypes names a panel by keyword when path is missing", { }) test_that("readGenotypes reaches the explicit-triplet source too", { + skip_if_not_installed("PlinkMatrix") stem <- test_path("test_data", "test_variants") panel <- readGenotypes( bed = str_c(stem, ".bed"), @@ -2532,6 +2292,23 @@ test_that("readGenotypes reaches the explicit-triplet source too", { expect_equal(dim(panel), dim(readGenotypes(stem, format = "plink1"))) }) +test_that("readGenotypes reaches the explicit PLINK2 triplet source", { + skip_if_not_installed("pgenlibr") + stem <- test_path("test_data", "test_variants") + panel <- readGenotypes( + pgen = str_c(stem, ".pgen"), + pvar = str_c(stem, ".pvar"), + psam = str_c(stem, ".psam") + ) + byPrefix <- readGenotypes(plink2Prefix = stem) + expect_s4_class(panel, "RangedSummarizedExperiment") + expect_equal(rownames(panel), rownames(byPrefix)) + expect_equal(colnames(panel), colnames(byPrefix)) + expect_equal( + as.matrix(SummarizedExperiment::assay(panel, "dosage")[1:5, ]), + as.matrix(SummarizedExperiment::assay(byPrefix, "dosage")[1:5, ]) + ) +}) # =========================================================================== # Format detection and handle/covariate helpers @@ -2541,23 +2318,26 @@ test_that("readGenotypes reaches the explicit-triplet source too", { # =========================================================================== test_that("every file extension maps to its genotype format", { - f <- pecotmr:::.h2FormatFromExt - expect_equal(f("vcf"), "vcf") - expect_equal(f("bcf"), "vcf") - expect_equal(f("bed"), "plink1") - expect_equal(f("bim"), "plink1") - expect_equal(f("fam"), "plink1") - expect_equal(f("pgen"), "plink2") - expect_equal(f("pvar"), "plink2") - expect_equal(f("psam"), "plink2") - expect_equal(f("gds"), "gds") - expect_equal(f("rds"), "rds") - expect_equal(f("rdata"), "rds") - expect_equal(f("annot"), "ldsc_annot") - expect_equal(f("bw"), "bigwig") - expect_equal(f("bigwig"), "bigwig") - # An unrecognised extension is NULL, not an error: the caller decides. - expect_null(f("zzz")) + f <- function(path) pecotmr:::.genotypeFileFormat(path) %||% "none" + paths <- c( + vcf = "x.vcf", + vcf = "x.vcf.gz", + vcf = "x.VCF.BGZ", + vcf = "x.bcf", + gds = "x.gds", + bgen = "x.bgen", + plink1 = "x.bed", + plink1 = "x.bim", + plink1 = "x.fam", + plink2 = "x.pgen", + plink2 = "x.pvar", + plink2 = "x.pvar.zst", + plink2 = "x.psam", + # An unrecognised extension is NULL, not an error: the caller decides. + none = "x.zzz", + none = "x.annot.gz" + ) + expect_equal(purrr::map_chr(unname(paths), f), names(paths)) }) test_that("the unsupported-format signaller names its context when given one", { @@ -2582,8 +2362,8 @@ test_that("a legacy handle without fileIdx is not subset", { # mis-indexed. h <- new( "GenotypeHandle", - path = "/tmp/x.gds", - format = "gds", + path = "/tmp/x", + format = "plink2", snpInfo = data.frame( SNP = c("a", "b", "c"), CHR = "1", @@ -2618,7 +2398,6 @@ test_that("covariate colData aligns to the panel's samples", { ) }) - test_that("a panel with no covariates gets an empty colData", { prefix <- sub( "\\.bed$", @@ -2639,8 +2418,8 @@ test_that("block extraction rejects a format it has no reader for", { # to catch. h <- new( "GenotypeHandle", - path = "/tmp/x.gds", - format = "gds", + path = "/tmp/x", + format = "plink2", snpInfo = data.frame( SNP = "a", CHR = "1", @@ -2726,3 +2505,686 @@ test_that("readGenotypes names its keyword sources, not `...`", { ) } }) + +# =========================================================================== +# The BGEN reader (and src/bgen.cpp). Synthetic files come from the writer in +# helper-bgen.R; complex.bgen and haplotypes.bgen are bgen's own examples +# (test_data/bgen, Boost Software License 1.0). A BGEN file is read through +# its .bgi index, an SQLite database, so every test reading one needs DBI and +# RSQLite. +# =========================================================================== + +.bgenPanelDosage <- function(panel) { + t(as.matrix(SummarizedExperiment::assay(panel, "dosage"))) +} + +test_that("a BGEN file reads as the dosages its probabilities give", { + skip_if_not_installed("DBI") + skip_if_not_installed("RSQLite") + # Every compression and a bit depth that does not fill bytes: the + # dosage is the expected count of the second allele, NA where a sample + # is flagged missing. + for (compression in 0:2) { + for (bits in c(3L, 8L, 16L)) { + fx <- .bgw_fixture(bits = bits, compression = compression) + panel <- readGenotypes(fx$path) + label <- str_c("compression ", compression, ", bits ", bits) + expect_equal(dim(panel), c(5L, 6L), label = label) + expect_equal(colnames(panel), fx$ids, label = label) + expect_equal( + unname(.bgenPanelDosage(panel)), + fx$dosage, + tolerance = 1e-12, + label = label + ) + } + } +}) + +test_that("a BGEN file's variants read as pecotmr's convention", { + skip_if_not_installed("DBI") + skip_if_not_installed("RSQLite") + # A2 the first allele, A1 the second; the record's rsid as its id when + # it has one, else chr:pos:A2:A1; a zero-padded chromosome is canonical. + fx <- .bgw_fixture() + handle <- pecotmr:::.readGenotypeHandle(fx$path) + si <- snpInfo(handle) + expect_equal(genotypeFormat(handle), "bgen") + expect_equal(si$A2, rep("A", 5L)) + expect_equal(si$A1, rep("G", 5L)) + expect_equal(si$CHR, rep("1", 5L)) + expect_equal(si$SNP, c("chr1:100:A:G", sprintf("rs%d", 1:4))) + expect_equal(si$BP, 100L * (1:5)) +}) + +test_that("a BGEN file without sample ids reads them from its .sample", { + skip_if_not_installed("DBI") + skip_if_not_installed("RSQLite") + fx <- .bgw_fixture(storeIds = FALSE) + panel <- readGenotypes(fx$path) + expect_equal(colnames(panel), fx$ids) + expect_equal(unname(.bgenPanelDosage(panel)), fx$dosage, tolerance = 1e-12) + file.remove(str_c(str_remove(fx$path, "\\.bgen$"), ".sample")) + expect_error(readGenotypes(fx$path), "stores no sample ids") +}) + +test_that("a BGEN 1.1 (layout 1) file reads as its probabilities give", { + skip_if_not_installed("DBI") + skip_if_not_installed("RSQLite") + # Diploid and biallelic, three 16-bit probabilities per sample out of + # 32768, zlib-compressed or not; a sample stored as all zeros is missing. + for (compression in 0:1) { + fx <- .bgw_fixture(compression = compression, layout = 1L) + panel <- readGenotypes(fx$path) + label <- str_c("layout 1, compression ", compression) + expect_equal(colnames(panel), fx$ids, label = label) + expect_equal( + unname(.bgenPanelDosage(panel)), + fx$dosage, + tolerance = 1e-12, + label = label + ) + } +}) + +test_that("a BGEN file needs its .bgi index and a layout the spec defines", { + skip_if_not_installed("DBI") + skip_if_not_installed("RSQLite") + fx <- .bgw_fixture() + file.remove(str_c(fx$path, ".bgi")) + expect_error(readGenotypes(fx$path), "is read through its .bgi index") + # The header is refused before any record is read. + header <- function(layout, compression) { + path <- withr::local_tempfile( + fileext = ".bgen", + .local_envir = parent.frame() + ) + .bgw_write( + path, + fx$variants[0L, ], + list(), + matrix(FALSE, 6L, 0L), + fx$ids, + compression = compression, + layout = layout + ) + path + } + expect_error(readGenotypes(header(3L, 1L)), "BGEN layout 3") + expect_error( + readGenotypes(header(1L, 2L)), + "compressed with zstd, which the spec does not allow" + ) +}) + +test_that("a corrupt BGEN header or sample block is refused", { + skip_if_not_installed("DBI") + skip_if_not_installed("RSQLite") + # The fixture's bytes: a 4-byte offset, the 20-byte header (its length, + # the variant and sample counts, the magic number, the flags), then the + # sample block (its length, the sample count again, the ids). + fx <- .bgw_fixture() + bytes <- readBin(fx$path, "raw", file.size(fx$path)) + dir <- withr::local_tempdir() + rewritten <- function(name, bytes) { + path <- file.path(dir, str_c(name, ".bgen")) + writeBin(bytes, path) + file.copy(str_c(fx$path, ".bgi"), str_c(path, ".bgi")) + path + } + expect_error( + readGenotypes(rewritten("short", bytes[1:10])), + "too short to be a BGEN file" + ) + expect_error( + readGenotypes(rewritten( + "magic", + replace(bytes, 17:20, charToRaw("bgex")) + )), + "no 'bgen' magic number" + ) + # The first flag byte's low two bits are the compression; 3 is undefined. + expect_error( + readGenotypes(rewritten("flags", replace(bytes, 21L, as.raw(3L + 8L)))), + "unknown BGEN compression \\(3\\)" + ) + expect_error( + readGenotypes(rewritten("count", replace(bytes, 29L, as.raw(7L)))), + "sample block's sample count disagrees with its header" + ) +}) + +test_that("a BGEN file's sample ids and records must match its header", { + skip_if_not_installed("DBI") + skip_if_not_installed("RSQLite") + # A .sample file listing fewer samples than the header declares. + fx <- .bgw_fixture(storeIds = FALSE) + writeLines( + c( + "ID_1 ID_2 missing", + "0 0 0", + str_c(fx$ids[-1], fx$ids[-1], "0", sep = " ") + ), + str_c(str_remove(fx$path, "\\.bgen$"), ".sample") + ) + expect_error( + readGenotypes(fx$path), + "declares 6 samples but 5 sample ids were found" + ) + # A layout-1 record holding five samples' probabilities under a header + # that declares six: refused when its dosages are read. + path <- file.path(withr::local_tempdir(), "short.bgen") + .bgw_write( + path, + fx$variants[1L, ], + list(matrix(c(10000L, 20000L), 5L, 2L, byrow = TRUE)), + matrix(FALSE, 5L, 1L), + fx$ids, + layout = 1L + ) + panel <- readGenotypes(path) + expect_error( + as.matrix(SummarizedExperiment::assay(panel, "dosage")), + "layout-1 BGEN record holds the wrong amount of data" + ) +}) + +test_that("bgen's complex example reads as its VCF gives it", { + skip_if_not_installed("DBI") + skip_if_not_installed("RSQLite") + # Haploid and diploid samples, phased and unphased records, multi- + # allelic records split one variant per non-first allele, and records + # of ploidy above 2. + path <- test_path("test_data", "bgen", "complex.bgen") + expect_warning( + handle <- pecotmr:::.readGenotypeHandle(path), + "carry more than two alleles" + ) + si <- snpInfo(handle) + m4 <- which(si$BP == 4L) + expect_equal(si$A1[m4], c("G", "T")) + dosageOf <- function(rows) { + pecotmr:::.extractBlockBgen(handle, rows) + } + # V1, V2: unphased, haploid sample 1; V3: phased; M4: G and T. + want <- cbind( + V1 = c(0, 0, 0, 1), + V2 = c(0, 0, 0, 1), + V3 = c(0, 2, 0, 1), + M4G = c(0, 0, 1, 0), + M4T = c(0, 0, 0, 1) + ) + rows <- c(which(si$BP %in% 1:3), m4) + expect_equal(unname(dosageOf(rows)), unname(want)) + # M5: phased, ploidies 1, 3, 3 and 2 (0, 0|0|0, 0|0|1, 0|1); M10: + # unphased tetraploid (0/0/0/0 to 0/1/1/1). A dosage runs from 0 to the + # sample's ploidy. + expect_equal( + unname(dosageOf(which(si$BP %in% c(5L, 10L)))), + cbind(c(0, 0, 1, 1), c(0, 1, 2, 3)) + ) +}) + +test_that("bgen's haplotype example reads as its .haps gives it", { + skip_if_not_installed("DBI") + skip_if_not_installed("RSQLite") + path <- test_path("test_data", "bgen", "haplotypes.bgen") + panel <- readGenotypes(path) + # Columns: chromosome, id, rsid, position, the two alleles, then two + # haplotypes per sample. + haps <- read.table(test_path("test_data", "bgen", "haplotypes.haps")) + alleles <- as.matrix(haps[, -(1:6)]) + want <- alleles[, c(TRUE, FALSE)] + alleles[, c(FALSE, TRUE)] + expect_equal( + unname(as.matrix(SummarizedExperiment::assay(panel, "dosage"))), + unname(want) + ) +}) + +test_that("a BGEN file reads as bigsnpr reads it", { + skip_if_not_installed("DBI") + skip_if_not_installed("RSQLite") + # An independent reader of the UK Biobank layout (8-bit zlib, biallelic), + # which rounds its dosages to two decimals. + skip_if_not_installed("bigsnpr") + fx <- .bgw_fixture(n = 40L, nVar = 12L, bits = 8L, compression = 1L) + ours <- .bgenPanelDosage(readGenotypes(fx$path)) + ids <- str_c( + fx$variants$chrom, + fx$variants$pos, + fx$variants$a1, + fx$variants$a2, + sep = "_" + ) + rds <- bigsnpr::snp_readBGEN( + fx$path, + backingfile = withr::local_tempfile(), + list_snp_id = list(ids), + read_as = "dosage", + ncores = 1 + ) + theirs <- bigsnpr::snp_attach(rds)$genotypes[] + expect_equal(is.na(theirs), unname(is.na(ours))) + present <- !is.na(ours) + expect_lt(max(abs(unname(ours)[present] - theirs[present])), 0.005 + 1e-9) +}) + +test_that("a BGEN file serves every genotype route", { + skip_if_not_installed("DBI") + skip_if_not_installed("RSQLite") + # The format is one of the GenotypeHandle's, so every route that reads + # genotypes reads it: a file, a per-chromosome manifest, an LD-meta + # table, the region loader, LD, and a mixture of cohorts. + fx <- .bgw_fixture(n = 30L, nVar = 8L, bits = 16L) + want <- fx$dosage + panel <- readGenotypes(fx$path) + sharded <- readGenotypes(genoMeta = c(`1` = fx$path)) + expect_equal(unname(.bgenPanelDosage(sharded)), want, tolerance = 1e-12) + meta <- withr::local_tempfile(fileext = ".tsv") + writeLines( + c("#chr\tstart\tend\tpath", str_c("chr1\t1\t10000\t", fx$path)), + meta + ) + viaMeta <- readGenotypes(ldMeta = meta, region = "chr1:1-10000") + expect_equal(unname(.bgenPanelDosage(viaMeta)), want, tolerance = 1e-12) + loaded <- loadGenotypeRegion(fx$path, region = "chr1:1-10000") + expect_equal(unname(loaded), want, tolerance = 1e-12) + expect_equal( + refVariantInfo(fx$path)$pos, + fx$variants$pos + ) + # LD is the samples' correlation, the missing call imputed with the + # variant's mean as everywhere else. + imputed <- want + imputed[is.na(imputed)] <- colMeans(want, na.rm = TRUE)[ + col(want)[is.na(want)] + ] + expect_equal(unname(computeLd(panel)), cor(imputed), tolerance = 1e-10) + mix <- GenotypeMixture( + list(a = panel[, 1:15], b = panel[, 16:30]), + mixtureWeights = c(0.5, 0.5) + ) + expect_equal(pecotmr:::.ldRefNVariants(mix), 8L) +}) + +test_that("the BGEN dosage kernel checks what it is given", { + expect_error( + pecotmr:::bgenDosageCpp(as.raw(1:5), 1L, 2L), + "truncated" + ) + # A record claiming more genotypes than its data could hold is refused + # before they are enumerated: ploidy 63 with 65535 alleles, one byte. + corrupt <- as.raw(c(1, 0, 0, 0, 255, 255, 63, 63, 63, 0, 8, 0)) + expect_error(pecotmr:::bgenDosageCpp(corrupt, 1L, 1L), "truncated") +}) + +test_that("the BGEN dosage kernel reads any ploidy and allele count", { + # One unphased triploid sample with three alleles: ten genotypes in colex + # order -- (3,0,0) (2,1,0) (1,2,0) (0,3,0) (2,0,1) (1,1,1) (0,2,1) + # (1,0,2) (0,1,2) (0,0,3) -- the last one's probability implied. + triploid <- function(genotype) { + stored <- integer(9L) + if (genotype <= 9L) { + stored[[genotype]] <- 255L + } + as.raw(c(1, 0, 0, 0, 3, 0, 3, 3, 3, 0, 8, stored)) + } + # All the mass on (0,2,1): two copies of allele 2, one of allele 3. + expect_equal( + pecotmr:::bgenDosageCpp(triploid(7L), 1L, c(2L, 3L)), + matrix(c(2, 1), 1L) + ) + # On the implied last genotype, (0,0,3). + expect_equal( + pecotmr:::bgenDosageCpp(triploid(10L), 1L, c(1L, 3L)), + matrix(c(0, 3), 1L) + ) +}) + +# =========================================================================== +# The VCF and GDS panel builders: what a VCF or GDS panel's variants are +# called, what is refused before anything is read, and how a per-chromosome +# set stacks. The seed's reads are tested in test_GenotypeDosageSeed.R. +# =========================================================================== + +samples3 <- c("s1", "s2", "s3") + +.dose <- function(panel) { + unname(as.matrix(SummarizedExperiment::assay(panel, "dosage"))) +} + +# A GDS file built node by node with gdsfmt, of root format `fileFormat` +# (NULL records none), by `build(gds)`. +.writeTestGds <- function(fileFormat, build) { + f <- tempfile(fileext = ".gds") + gds <- gdsfmt::createfn.gds(f) + if (!is.null(fileFormat)) { + gdsfmt::put.attr.gdsn(gds$root, "FileFormat", fileFormat) + } + build(gds) + gdsfmt::closefn.gds(gds) + f +} + +# A minimal SeqArray file of one biallelic record and two samples, all REF +# calls: its genotype calls stored as `storage`, with `nExtra` calls stored +# beyond its ploidy, and no annotation/id. +.writeFakeSeqArray <- function(storage = "bit2", nExtra = 0L) { + .writeTestGds("SEQ_ARRAY", function(gds) { + gdsfmt::add.gdsn(gds, "sample.id", c("a", "b")) + gdsfmt::add.gdsn(gds, "variant.id", 1L) + gdsfmt::add.gdsn(gds, "position", 100L) + gdsfmt::add.gdsn(gds, "chromosome", "1") + gdsfmt::add.gdsn(gds, "allele", "A,G") + geno <- gdsfmt::addfolder.gdsn(gds, "genotype") + gdsfmt::add.gdsn( + geno, + "data", + array(0L, c(2L, 2L, 1L)), + storage = storage + ) + gdsfmt::add.gdsn(geno, "@data", 1L, storage = "uint8", visible = FALSE) + gdsfmt::add.gdsn( + geno, + "extra.index", + matrix(1L, 3L, nExtra), + storage = "int32" + ) + }) +} + +# ---- VCF ------------------------------------------------------------------- + +test_that("a VCF panel names its variants and records where it came from", { + skip_if_not_installed("VariantAnnotation") + vcf <- .writeTestVcf(.vcfGtOnly(.vcfOverlapRecords()), samples3) + expect_warning( + panel <- readGenotypes(vcf), + "1 VCF record\\(s\\) of .* carry more than one ALT allele" + ) + rr <- SummarizedExperiment::rowRanges(panel) + # A record keeps its own ID when it has one and a single ALT allele; + # every other row is named by its alleles. + expect_equal( + rr$SNP, + c( + "chr22:100:A:G", + "rs2", + "rs3", + "rs4", + "rs4", + "chr22:400:A:C", + "chr22:400:A:G" + ) + ) + expect_equal(rr$A1, c("G", "A", "T", "T", "G", "C", "G")) + expect_equal(rr$A2, c("A", "ACGTA", "G", "C", "C", "A", "A")) + expect_equal(as.character(GenomicRanges::seqnames(rr)), rep("chr22", 7L)) + expect_equal(colnames(panel), samples3) + expect_equal( + S4Vectors::metadata(panel)$genotypeSource, + list( + format = "vcf", + path = normalizePath(vcf), + chromPaths = character(0) + ) + ) +}) + +test_that("a VCF record with no ALT allele holds no variant", { + skip_if_not_installed("VariantAnnotation") + records <- data.frame( + CHROM = "22", + POS = c(100L, 500L), + ID = c("rs1", "rs5"), + REF = "A", + ALT = c("G", "."), + s1 = c("0/1", "0/0"), + s2 = c("1/1", "0/0"), + s3 = c("0/0", "0/0"), + stringsAsFactors = FALSE + ) + panel <- readGenotypes(.writeTestVcf(records, samples3)) + expect_equal(rownames(panel), "rs1") + expect_equal(.dose(panel), matrix(c(1, 2, 0), 1L)) +}) + +test_that("vcfArgs reach the read of the records", { + skip_if_not_installed("VariantAnnotation") + vcf <- .writeTestVcf(.vcfGtOnly(.vcfOverlapRecords()), samples3) + # Read without row names, no record has an ID of its own. + panel <- suppressWarnings( + readGenotypes(vcf, vcfArgs = list(row.names = FALSE)) + ) + expect_equal( + SummarizedExperiment::rowRanges(panel)$SNP[2:3], + c("chr22:200:ACGTA:A", "chr22:202:G:T") + ) +}) + +test_that("a VCF that cannot be read lazily is refused before any read", { + skip_if_not_installed("VariantAnnotation") + expect_error( + readGenotypes("/no/such/file.vcf.gz"), + "VCF file.*File does not exist" + ) + vcf <- .writeTestVcf(.vcfGtOnly(.vcfOverlapRecords()), samples3) + unindexed <- file.path(tempfile("vcf_"), "copy.vcf.gz") + dir.create(dirname(unindexed)) + file.copy(vcf, unindexed) + expect_error(readGenotypes(unindexed), "tabix index") + bcf <- tempfile(fileext = ".bcf") + file.copy(vcf, bcf) + expect_error(readGenotypes(bcf), "BCF file") +}) + +test_that("a VCF's dosage field must be one pecotmr can read", { + skip_if_not_installed("VariantAnnotation") + records <- .vcfOverlapRecords() + perGenotype <- .writeTestVcf( + records, + samples3, + format = c("GT", "DS"), + ds = "G" + ) + expect_error(readGenotypes(perGenotype), "FORMAT/DS with Number=G") + noGenotypes <- .writeTestVcf( + .vcfGtOnly(records), + samples3, + format = "AD", + gt = FALSE + ) + expect_error( + suppressWarnings(readGenotypes(noGenotypes)), + "neither FORMAT/DS nor FORMAT/GT" + ) +}) + +test_that("a sketch's .afreq beside a VCF is recorded on its panel", { + skip_if_not_installed("VariantAnnotation") + vcf <- .writeTestVcf(.vcfGtOnly(.vcfOverlapRecords())[2:3, ], samples3) + writeLines( + c( + "#CHROM\tID\tREF\tALT\tALT_FREQS\tOBS_CT\tU_MIN\tU_MAX", + "22\trs2\tACGTA\tA\t0.25\t40\t-1\t1", + "22\trs3\tG\tT\t0.5\t38\t-1\t1" + ), + sub("\\.vcf\\.gz$", ".afreq", vcf) + ) + panel <- readGenotypes(vcf) + expect_equal(SummarizedExperiment::rowRanges(panel)$AF, c(0.25, 0.5)) + expect_equal(S4Vectors::metadata(panel)$ldProjection$nSamples, 20L) +}) + +# ---- GDS ------------------------------------------------------------------- + +test_that("a GDS file that holds no genotypes pecotmr reads is refused", { + skip_if_not_installed("gdsfmt") + skip_if_not_installed("GDSArray") + expect_error( + readGenotypes("/no/such/file.gds"), + "GDS file.*File does not exist" + ) + bare <- .writeTestGds(NULL, function(gds) { + gdsfmt::add.gdsn(gds, "x", 1L) + }) + expect_error(readGenotypes(bare), "GDS file of format 'unknown'") +}) + +test_that("a SNPRelate GDS whose genotypes disagree with its SNPs is refused", { + skip_if_not_installed("gdsfmt") + skip_if_not_installed("GDSArray") + f <- .writeTestGds("SNP_ARRAY", function(gds) { + gdsfmt::add.gdsn(gds, "sample.id", c("a", "b", "c")) + gdsfmt::add.gdsn(gds, "snp.id", c("v1", "v2")) + gdsfmt::add.gdsn(gds, "snp.position", c(10L, 20L)) + gdsfmt::add.gdsn(gds, "snp.chromosome", c(1L, 1L)) + gdsfmt::add.gdsn(gds, "snp.allele", c("A/G", "C/T")) + node <- gdsfmt::add.gdsn( + gds, + "genotype", + matrix(0L, 3L, 3L), + storage = "bit2" + ) + gdsfmt::put.attr.gdsn(node, "sample.order") + }) + expect_error( + readGenotypes(f), + "genotype matrix of .* is 3 x 3, but the file lists 2 SNPs" + ) +}) + +test_that("a SeqArray GDS without IDs names its variants by their alleles", { + skip_if_not_installed("gdsfmt") + skip_if_not_installed("GDSArray") + panel <- readGenotypes(.writeFakeSeqArray()) + expect_equal(rownames(panel), "chr1:100:A:G") + expect_equal(.dose(panel), matrix(0, 1L, 2L)) +}) + +test_that("SeqArray calls stored otherwise than as read are refused", { + skip_if_not_installed("gdsfmt") + skip_if_not_installed("GDSArray") + expect_error( + readGenotypes(.writeFakeSeqArray(storage = "int8")), + "stores its genotype calls as Int8" + ) + expect_error( + readGenotypes(.writeFakeSeqArray(nExtra = 1L)), + "1 genotype call\\(s\\) beyond its ploidy" + ) +}) + +test_that("a SeqArray FORMAT/DS of another Number is refused", { + skip_if_not_installed("SeqArray") + skip_if_not_installed("GDSArray") + vcf <- .writeTestVcf( + .vcfOverlapRecords(), + samples3, + format = c("GT", "DS"), + ds = "A" + ) + gds <- .writeTestSeqArray(vcf, ds = TRUE) + opened <- gdsfmt::openfn.gds(gds, readonly = FALSE) + gdsfmt::put.attr.gdsn( + gdsfmt::index.gdsn(opened, "annotation/format/DS"), + "Number", + "G" + ) + gdsfmt::closefn.gds(opened) + expect_error(readGenotypes(gds), "stores FORMAT/DS with Number=G") +}) + +# ---- PLINK1 ---------------------------------------------------------------- + +test_that("a PLINK1 panel reads the dosages snpStats reads", { + # toy_ref has missing calls. snpStats counts the .bim's sixth allele, so + # its count of A1, the fifth, is two minus that. + skip_if_not_installed("PlinkMatrix") + skip_if_not_installed("snpStats") + stem <- str_remove( + system.file("extdata", "toy_ref.bed", package = "pecotmr"), + "\\.bed$" + ) + sm <- snpStats::read.plink( + str_c(stem, ".bed"), + str_c(stem, ".bim"), + str_c(stem, ".fam") + ) + want <- t(2 - methods::as(sm$genotypes, "numeric")) + panel <- readGenotypes(plink1Prefix = stem) + expect_true(anyNA(want)) + expect_equal(.dose(panel), unname(want)) + expect_identical(rownames(panel), normalizeVariantId(sm$map$snp.name)) + expect_identical(colnames(panel), as.character(sm$fam$member)) + expect_identical( + S4Vectors::metadata(panel)$genotypeSource$path, + file.path(normalizePath(dirname(stem)), basename(stem)) + ) +}) + +test_that("a PLINK1 panel cut to a few variants keeps only those", { + # Its seed is cut with it, so a saved panel carries the kept variants' + # metadata only, and reads them back from the file. + skip_if_not_installed("PlinkMatrix") + panel <- readGenotypes(plink1Prefix = plink_prefix) + cut <- pecotmr:::.panelSubsetRows(panel, c(3L, 10L, 200L)) + expect_equal(dim(pecotmr:::.panelSeed(cut)), c(3L, n_samples)) + expect_equal(.dose(cut), .dose(panel)[c(3L, 10L, 200L), ]) + saved <- tempfile(fileext = ".rds") + saveRDS(cut, saved) + expect_equal(.dose(readRDS(saved)), .dose(cut)) +}) + +# ---- Per-chromosome sets --------------------------------------------------- + +test_that("a per-chromosome VCF, GDS or PLINK1 set stacks into one panel", { + skip_if_not_installed("VariantAnnotation") + skip_if_not_installed("GDSArray") + skip_if_not_installed("PlinkMatrix") + for (ext in c(".vcf.gz", ".gds", ".bed")) { + p21 <- file.path(test_data_dir, paste0("test_variants", ext)) + p22 <- file.path(test_data_dir, paste0("test_variants_chr22", ext)) + one21 <- readGenotypes(p21) + one22 <- readGenotypes(p22) + stacked <- readGenotypes(genoMeta = c("21" = p21, "22" = p22)) + expect_equal(dim(stacked), c(nrow(one21) + nrow(one22), ncol(one21))) + expect_equal(.dose(stacked), rbind(.dose(one21), .dose(one22))) + source <- S4Vectors::metadata(stacked)$genotypeSource + # A PLINK1 file is recorded by its stem, as a PLINK prefix is. + recorded <- str_remove(normalizePath(c(p21, p22)), "\\.bed$") + expect_equal( + source$chromPaths, + c("21" = recorded[[1L]], "22" = recorded[[2L]]) + ) + # A stacked panel has no single seed to read through. + expect_null(pecotmr:::.panelSeed(stacked)) + # Only the files of the chromosomes asked for are read. + only22 <- readGenotypes( + genoMeta = c("21" = p21, "22" = p22), + chroms = "22" + ) + expect_equal(.dose(only22), .dose(one22)) + } +}) + +test_that("a set's shards hold the same samples, one chromosome each", { + skip_if_not_installed("VariantAnnotation") + records <- .vcfGtOnly(.vcfOverlapRecords()) + chr22 <- .writeTestVcf(records, samples3) + other <- .writeTestVcf( + `[<-`(records, "CHROM", value = "21")[c(names(records)[1:5], "s1")], + "s1" + ) + expect_error( + suppressWarnings(readGenotypes( + genoMeta = c("22" = chr22, "21" = other) + )), + "identical sample IDs" + ) + again <- .writeTestVcf(records, samples3) + expect_error( + suppressWarnings(readGenotypes(genoMeta = c(a = chr22, b = again))), + "appears in more than one per-chromosome file" + ) +}) diff --git a/tests/testthat/test_h2EstimationWrappers.R b/tests/testthat/test_h2EstimationWrappers.R index 9383b9998..579243dac 100644 --- a/tests/testthat/test_h2EstimationWrappers.R +++ b/tests/testthat/test_h2EstimationWrappers.R @@ -245,6 +245,161 @@ test_that("computeLdScores LdEigen annotation column names match", { expect_equal(colnames(result), c("base_l2", "annot_A", "annot_B")) }) +test_that("computeLdScores gives the same scores from LdEigen and LdScore", { + # Both are ldsc's unbiased r^2 summed against each annotation. Weighted + # by an annotation, the cross terms between eigenvectors do not cancel, + # so an eigen shortcut that drops them fails here -- the LdEigen route + # rebuilds R for those columns instead. + ld <- makeTestLdMatrixBlocks(sizes = c(5L, 4L), rho = 0.6) + scoreRef <- buildLdScore(ld, genome = "hg19") + eigenRef <- buildLdEigen(ld, genome = "hg19") + set.seed(5) + mat <- cbind(binary = c(1, 0, 1, 1, 0, 0, 1, 0, 1), cont = runif(9)) + annot <- AnnotationMatrix( + mat, + GenomicRanges::granges(scoreRef, use.mcols = FALSE), + data.frame( + name = c("binary", "cont"), + tier = "baseline", + type = c("binary", "continuous") + ), + genome = "hg19" + ) + viaScore <- computeLdScores(scoreRef, annotations = annot) + expect_equal( + computeLdScores(eigenRef, annotations = annot), + viaScore, + tolerance = 1e-12 + ) + # Both are the definition, block by block, at the fixture's n = 500. + blockScores <- function(R, idx) { + u <- R^2 - (1 - R^2) / (500 - 2) + cbind(rowSums(u), u %*% mat[idx, ]) + } + want <- rbind( + blockScores(unname(ldMatrix(ld[[1]])), 1:5), + blockScores(unname(ldMatrix(ld[[2]])), 6:9) + ) + expect_equal(unname(viaScore), unname(want), tolerance = 1e-12) +}) + +test_that("LD scores read from a panel match its blocks' stored LD", { + # The stored route squares each block's matrix; the panel route forms R's + # rows from the panel's factor a stripe at a time, and the LdEigen route + # from each block's SVD. + fx <- .h2PanelFixture() + lazyScore <- buildLdScore(fx$panel, ldBlocks = fx$blocks, genome = "hg19") + storedScore <- buildLdScore(fx$ld, genome = "hg19") + lazyEigen <- buildLdEigen(fx$panel, ldBlocks = fx$blocks, genome = "hg19") + annot <- .h2PanelAnnotations(storedScore) + want <- computeLdScores(storedScore, annotations = annot) + expect_equal( + computeLdScores(lazyScore, annotations = annot), + want, + tolerance = 1e-10 + ) + expect_equal( + computeLdScores(lazyEigen, annotations = annot), + want, + tolerance = 1e-10 + ) + expect_equal( + computeLdScores(lazyEigen)[, 1], + mcols(lazyScore)$ldScores[, 1], + tolerance = 1e-10 + ) +}) + +test_that("estimators read a panel's LD on demand as they read stored LD", { + # The same blocks two ways: read from the genotype panel one block at a + # time, and stored as LdMatrix blocks. The middle block has more variants + # than the panel has samples, so its LD has 40 zero eigenvalues that the + # SVD of the panel's factor does not list; LDER and HDL count those + # directions without them. g-LDSC forms each block's Omega from the + # factor rather than from R. + fx <- .h2PanelFixture() + lazyScore <- buildLdScore(fx$panel, ldBlocks = fx$blocks, genome = "hg19") + storedScore <- buildLdScore(fx$ld, genome = "hg19") + lazyEigen <- buildLdEigen(fx$panel, ldBlocks = fx$blocks, genome = "hg19") + storedEigen <- buildLdEigen(fx$ld, genome = "hg19") + annot <- .h2PanelAnnotations(storedScore) + n <- 2000 + z <- .h2PanelZ(fx$ld, n, h2 = 0.5) + runs <- list( + lder = list(pecotmr:::lderUnivariate, lazyEigen, storedEigen), + gldsc = list(pecotmr:::gldscUnivariate, lazyScore, storedScore), + sldsc = list(pecotmr:::sldscUnivariate, lazyScore, storedScore) + ) + for (method in names(runs)) { + fn <- runs[[method]][[1L]] + for (an in list(NULL, annot)) { + lazy <- fn(z, n, runs[[method]][[2L]], an, TRUE) + stored <- fn(z, n, runs[[method]][[3L]], an, TRUE) + expect_equal(lazy, stored, tolerance = 1e-8, label = method) + } + } + # HDL's likelihood is the same function either way. Its fit then agrees + # to the optimizer's tolerance: L-BFGS-B turns the likelihood's rounding + # (1e-13) into differences near 1e-7 in the optimum. + hdlDesign <- function(ref) { + data <- map( + pecotmr:::.ldEigenBlocks(ref), + pecotmr:::.hdlBlockData, + eigenRef = ref, + z = z, + n = n, + baselineMat = NULL, + candMat = NULL + ) + pecotmr:::.hdlDesign(data, length(ref), NULL) + } + lazyDesign <- hdlDesign(lazyEigen) + storedDesign <- hdlDesign(storedEigen) + expect_equal(length(lazyDesign$lam), length(storedDesign$lam)) + for (par in list(c(0.3, 1), c(0.5, 1.2))) { + expect_equal( + pecotmr:::.hdlNll( + par, + n, + 100, + lazyDesign$lam, + lazyDesign$bstar, + lazyDesign$ldAnnotScaled + ), + pecotmr:::.hdlNll( + par, + n, + 100, + storedDesign$lam, + storedDesign$bstar, + storedDesign$ldAnnotScaled + ), + tolerance = 1e-10 + ) + } + hdl <- pecotmr:::hdlUnivariate + for (an in list(NULL, annot)) { + expect_equal( + suppressWarnings(hdl(z, n, lazyEigen, an, TRUE)), + suppressWarnings(hdl(z, n, storedEigen, an, TRUE)), + tolerance = 1e-6 + ) + } + # The truncated decompositions HDL conventionally uses agree too. + lazy9 <- buildLdEigen( + fx$panel, + ldBlocks = fx$blocks, + genome = "hg19", + eigenvalueTruncation = 0.9 + ) + stored9 <- buildLdEigen(fx$ld, genome = "hg19", eigenvalueTruncation = 0.9) + expect_equal( + suppressWarnings(hdl(z, n, lazy9, annot, TRUE)), + suppressWarnings(hdl(z, n, stored9, annot, TRUE)), + tolerance = 1e-6 + ) +}) + # =========================================================================== # computeLdScores for LdScore # =========================================================================== @@ -260,7 +415,7 @@ test_that("computeLdScores LdScore with annotations but no ld_matrix_list errors annot <- makeTestAnnotations() expect_error( computeLdScores(score_ref, annotations = annot), - "ldMatrixList" + "need each LD block's LD" ) }) @@ -395,7 +550,10 @@ test_that("h2EstimateToSldscTrait creates 1-row dummy when annotationJackknifeCo result <- h2EstimateToSldscTrait(h2_obj) expect_equal(nrow(result$annotationJackknifeCoefs), 1) expect_equal(result$nBlocks, 1L) - expect_equal(colnames(result$annotationJackknifeCoefs), c("annot1", "annot2")) + expect_equal( + colnames(result$annotationJackknifeCoefs), + c("annot1", "annot2") + ) }) # =========================================================================== @@ -405,8 +563,8 @@ test_that("h2EstimateToSldscTrait creates 1-row dummy when annotationJackknifeCo makeTestGwasGenotypeHandle <- function() { new( "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", + path = "/tmp/test", + format = "plink2", snpInfo = data.frame(), nSamples = 0L, sampleIds = character(), @@ -453,7 +611,7 @@ makeTestSumstatsForRef <- function( studyName = traitName, entry = list(.dfToGwasGr(df)), genome = "hg19", - ldSketch = makeTestGwasGenotypeHandle(), + ldReference = makeTestGwasGenotypeHandle(), varY = varY ) } @@ -493,7 +651,7 @@ test_that("estimateh2 with method='lder' returns H2Estimate with correct slots", studyName = "test", entry = list(gr), genome = "hg19", - ldSketch = makeTestGwasGenotypeHandle() + ldReference = makeTestGwasGenotypeHandle() ) } @@ -504,7 +662,7 @@ test_that("estimateH2 rejects a sumstats with a different variant count", { studyName = "test", entry = list(sumStats(ss)[1:10]), genome = "hg19", - ldSketch = makeTestGwasGenotypeHandle() + ldReference = makeTestGwasGenotypeHandle() ) expect_error( estimateH2(short, ref, method = "lder"), @@ -561,7 +719,7 @@ test_that("estimateH2 rejects a genome build mismatch", { studyName = "test", entry = list(sumStats(ss)), genome = "hg38", - ldSketch = makeTestGwasGenotypeHandle() + ldReference = makeTestGwasGenotypeHandle() ) expect_error(estimateH2(hg38, ref, method = "lder"), "build mismatch") }) @@ -569,7 +727,7 @@ test_that("estimateH2 rejects a genome build mismatch", { test_that("estimateH2 accepts an LD reference that records no genome build", { ref <- makeTestEigenRef() ss <- makeTestSumstatsForRef(ref) - # loadLdMatrix() leaves the build unset, so a reference built from it + # An LD reference often records no build, so one built from it # names none. An unknown build must not read as a mismatch. GenomeInfoDb::genome(ref) <- NA_character_ expect_s4_class(estimateH2(ss, ref, method = "lder"), "H2Estimate") @@ -589,7 +747,7 @@ test_that("unstratified S-LDSC runs without the per-block LD matrices", { # LdScore is enough, which is why it is the cheap option. noMat <- makeTestScoreRef(with_ld_matrices = FALSE) ss <- makeTestSumstatsForRef(noMat) - expect_error(estimateH2(ss, noMat, method = "gldsc"), "per-block LD") + expect_error(estimateH2(ss, noMat, method = "gldsc"), "each LD block's LD") res <- estimateH2(ss, noMat, method = "sldsc") expect_s4_class(res, "H2Estimate") expect_equal(methodNames(res), "sldsc") @@ -602,7 +760,7 @@ test_that("stratified S-LDSC needs the per-block LD matrices", { annot <- makeTestAnnotations(nSnps = length(noMat)) expect_error( estimateH2(ss, noMat, method = "sldsc", annotations = annot), - "stratified S-LDSC requires full per-block LD matrices" + "stratified S-LDSC needs each LD block's LD" ) }) @@ -640,7 +798,7 @@ test_that("S-LDSC requires an LdScore, not an LdEigen", { ) }) -test_that("the S-LDSC weights reproduce upstream Hsq.weights", { +test_that("the S-LDSC weights reproduce the original Hsq.weights", { # het_w = 1 / (2 (intercept + hsq*N/M * ld)^2), oc_w = 1 / w_ld, both # LD scores floored at 1 and hsq clamped to [0, 1]. w <- pecotmr:::.sldscWeights( @@ -756,7 +914,7 @@ test_that(".lderWeights never returns a negative weight", { # =========================================================================== test_that("estimateH2 runs on references built by buildLdEigen/buildLdScore", { - ld <- makeTestLdDataMultiBlock(sizes = rep(10L, 5), rho = 0.6) + ld <- makeTestLdMatrixBlocks(sizes = rep(10L, 5), rho = 0.6) eigenRef <- buildLdEigen(ld, genome = "hg19") scoreRef <- buildLdScore(ld, genome = "hg19") ss <- makeTestSumstatsForRef(eigenRef) @@ -771,7 +929,7 @@ test_that("estimateH2 runs on references built by buildLdEigen/buildLdScore", { test_that("estimateH2 rejects a single-block LD reference", { # One block used to fail inside the jackknife fold fit with "'x' must be # a matrix" (LDER, g-LDSC) or return an SE of exactly 0 (HDL). - ld <- makeTestLdData(n = 30L, rho = 0.6) + ld <- makeTestLdMatrix(n = 30L, rho = 0.6) eigenRef <- buildLdEigen(ld, genome = "hg19") ss <- makeTestSumstatsForRef(eigenRef) expect_error( @@ -785,12 +943,12 @@ test_that("estimateH2 rejects a single-block LD reference", { }) test_that("buildLdScore(keepLdMatrices = FALSE) is rejected by g-LDSC", { - ld <- makeTestLdDataMultiBlock(sizes = rep(10L, 5)) + ld <- makeTestLdMatrixBlocks(sizes = rep(10L, 5)) scoreRef <- buildLdScore(ld, genome = "hg19", keepLdMatrices = FALSE) ss <- makeTestSumstatsForRef(scoreRef) expect_error( estimateH2(ss, scoreRef, method = "gldsc"), - "requires full per-block LD matrices" + "g-LDSC needs each LD block's LD" ) }) @@ -872,55 +1030,31 @@ test_that("computeLdScores LdScore with annotations and ld_matrix_list returns c context("h2_utils") # ============================================================================= -# jackknifeSe +# .jackknifeSeFromLoo # ============================================================================= -test_that("jackknifeSe returns zero when all LOO estimates equal full", { - nBlocks <- 5 - n_params <- 3 - estimates_full <- c(1.0, 2.0, 3.0) - estimates_loo <- matrix( - rep(estimates_full, each = nBlocks), - nrow = nBlocks, - ncol = n_params - ) - se <- pecotmr:::jackknifeSe(estimates_full, estimates_loo) - expect_length(se, n_params) - expect_equal(se, rep(0, n_params)) +test_that(".jackknifeSeFromLoo is zero when every LOO estimate is equal", { + expect_equal(pecotmr:::.jackknifeSeFromLoo(rep(2, 5)), 0) }) -test_that("jackknifeSe returns positive SE with varying LOO estimates", { +test_that(".jackknifeSeFromLoo is positive when the LOO estimates vary", { set.seed(42) - nBlocks <- 10 - estimates_full <- c(5.0, 10.0) - estimates_loo <- matrix( - rnorm( - nBlocks * 2, - mean = rep(estimates_full, each = nBlocks), - sd = 0.5 - ), - nrow = nBlocks, - ncol = 2 - ) - se <- pecotmr:::jackknifeSe(estimates_full, estimates_loo) - expect_length(se, 2) - expect_true(all(se > 0)) + expect_gt(pecotmr:::.jackknifeSeFromLoo(rnorm(10, mean = 5, sd = 0.5)), 0) }) -test_that("jackknifeSe computes known case correctly", { - # If full estimate is the mean of 5 values and LOO removes each one, - # we can verify the formula +test_that(".jackknifeSeFromLoo equals the pseudo-value jackknife", { + # The delete-one form sqrt((n - 1) / n * sum((loo - mean)^2)) and the + # pseudo-value form sqrt(var(n * full - (n - 1) * loo) / n) are the same + # quantity -- the full estimate cancels -- which is why one helper serves + # every estimator. Leave-one-out means of a known vector: vals <- c(2, 4, 6, 8, 10) - full_mean <- mean(vals) n <- length(vals) - # Leave-one-out means: remove element i, compute mean of remaining - loo_means <- map_dbl(seq_len(n), function(i) mean(vals[-i])) - estimates_loo <- matrix(loo_means, ncol = 1) - se <- pecotmr:::jackknifeSe(full_mean, estimates_loo) - # Pseudo-values: n * full - (n-1) * loo - pseudo <- n * full_mean - (n - 1) * loo_means - expected_se <- sqrt(var(pseudo) / n) - expect_equal(se, expected_se) + looMeans <- map_dbl(seq_len(n), function(i) mean(vals[-i])) + pseudo <- n * mean(vals) - (n - 1) * looMeans + expect_equal( + pecotmr:::.jackknifeSeFromLoo(looMeans), + sqrt(var(pseudo) / n) + ) }) # ============================================================================= @@ -1009,7 +1143,11 @@ test_that("computeBaselineEnrichment uses jackknife blocks when provided", { tauSe <- c(0.002, 0.001) h2 <- 0.5 annot_names <- c("annot1", "base") - annotationJackknifeCoefs <- matrix(rep(tau, each = nBlocks), nrow = nBlocks, ncol = 2) + annotationJackknifeCoefs <- matrix( + rep(tau, each = nBlocks), + nrow = nBlocks, + ncol = 2 + ) res <- pecotmr:::computeBaselineEnrichment( tau, tauSe, @@ -1032,8 +1170,18 @@ test_that("standardize_tau_star computes tauStar = tau * sd_annot * M_ref / h2g" M_ref <- 1000L h2g <- 0.4 nBlocks <- 5 - annotationJackknifeCoefs <- matrix(rep(tau, each = nBlocks), nrow = nBlocks, ncol = 2) - res <- pecotmr:::standardizeTauStar(tau, annotationJackknifeCoefs, sd_annot, M_ref, h2g) + annotationJackknifeCoefs <- matrix( + rep(tau, each = nBlocks), + nrow = nBlocks, + ncol = 2 + ) + res <- pecotmr:::standardizeTauStar( + tau, + annotationJackknifeCoefs, + sd_annot, + M_ref, + h2g + ) expected <- tau * sd_annot * M_ref / h2g expect_equal(res$tauStar, expected) expect_length(res$tauStarSe, 2) @@ -1070,8 +1218,18 @@ test_that("standardize_tau_star returns list with tauStar and tauStarSe", { sd_annot <- c(0.5) M_ref <- 1000L h2g <- 0.4 - annotationJackknifeCoefs <- matrix(rnorm(5, mean = 0.01, sd = 0.001), nrow = 5, ncol = 1) - res <- pecotmr:::standardizeTauStar(tau, annotationJackknifeCoefs, sd_annot, M_ref, h2g) + annotationJackknifeCoefs <- matrix( + rnorm(5, mean = 0.01, sd = 0.001), + nrow = 5, + ncol = 1 + ) + res <- pecotmr:::standardizeTauStar( + tau, + annotationJackknifeCoefs, + sd_annot, + M_ref, + h2g + ) expect_true(is.list(res)) expect_named(res, c("tauStar", "tauStarSe")) expect_length(res$tauStar, 1) @@ -1257,70 +1415,6 @@ test_that("checkGenomeBuild works with AnnotationMatrix", { expect_true(pecotmr:::checkGenomeBuild(am, ld_blocks)) }) -# ============================================================================= -# shrinkLd -# ============================================================================= - -test_that("shrinkLd constant shrinkage applies (1-lambda)*R + lambda*I", { - set.seed(42) - p <- 5 - # Create a valid correlation matrix - A <- matrix(rnorm(p * p), p, p) - R <- cov2cor(crossprod(A)) - n_ref <- 100 - - res <- pecotmr:::shrinkLd(R, n_ref, shrinkageType = "constant") - lambda <- 1 / sqrt(n_ref) - expected <- (1 - lambda) * R + lambda * diag(p) - expect_equal(res, expected) -}) - -test_that("shrinkLd constant shrinkage preserves diagonal of 1", { - set.seed(42) - p <- 4 - A <- matrix(rnorm(p * p), p, p) - R <- cov2cor(crossprod(A)) - n_ref <- 200 - res <- pecotmr:::shrinkLd(R, n_ref, shrinkageType = "constant") - expect_equal(diag(res), rep(1, p)) -}) - -test_that("shrinkLd constant shrinkage result is symmetric", { - set.seed(42) - p <- 4 - A <- matrix(rnorm(p * p), p, p) - R <- cov2cor(crossprod(A)) - n_ref <- 200 - res <- pecotmr:::shrinkLd(R, n_ref, shrinkageType = "constant") - expect_equal(res, t(res)) -}) - -test_that("shrinkLd wen_stephens uses genetic map when provided", { - set.seed(42) - p <- 4 - A <- matrix(rnorm(p * p), p, p) - R <- cov2cor(crossprod(A)) - n_ref <- 500 - genetic_map <- c(0.0, 0.1, 0.5, 1.0) - res <- pecotmr:::shrinkLd( - R, - n_ref, - shrinkageType = "wen_stephens", - geneticMap = genetic_map - ) - # Diagonal should be 1 - expect_equal(diag(res), rep(1, p)) - # Result should be symmetric - expect_equal(res, t(res)) - # Off-diagonal elements should be shrunk (closer to zero than original) - for (i in seq_len(p - 1)) { - for (j in (i + 1):p) { - expect_true(abs(res[i, j]) <= abs(R[i, j]) + 1e-10) - } - } -}) - - # Tests for heritability estimation methods: # lderUnivariate (h2Lder.R) # gldscUnivariate (h2Gldsc.R) @@ -1859,14 +1953,13 @@ test_that("gldscUnivariate with annotations returns scoreStats", { # Coverage-gap tests (appended) # # Targets the specific uncovered branches in R/h2EstimationWrappers.R: -# bplapplyBlocks, checkGenomeBuild (unknown type), .rmaMeta (length -# mismatch), .fglsSolve +# checkGenomeBuild (unknown type), .rmaMeta (length mismatch), .fglsSolve # (diagonal path), .gldscLocal (fine-grained blocks), .hdlLocal (p<3 and # tau=NULL), .lderLocalH2 (small block + baseline path), .hdlSeFisher- # Stratified / .hdlJackknifeTau (lambda>0 + singular fallback), the # multi-candidate (cor) and no-candidate (NULL) paths of the stratified -# score-statistic helpers, h2EstimateToSldscTrait (unnamed annotationJackknifeCoefs), and -# the multi-study estimateH2 dispatch error. +# score-statistic helpers, h2EstimateToSldscTrait (unnamed +# annotationJackknifeCoefs), and the multi-study estimateH2 dispatch error. # =========================================================================== # Flexible annotation builder: one baseline column (all-ones or spatial @@ -1920,27 +2013,6 @@ makeCoverageAnnot <- function( AnnotationMatrix(mat, snp_gr, meta, genome = "hg19") } -# --------------------------------------------------------------------------- -# bplapplyBlocks -# --------------------------------------------------------------------------- - -test_that("bplapplyBlocks applies FUN per block with default BPPARAM", { - skip_if_not_installed("BiocParallel") - res <- pecotmr:::bplapplyBlocks(list(1, 2, 3), function(i, ...) i^2) - expect_equal(res, list(1, 4, 9)) -}) - -test_that("bplapplyBlocks works with SerialParam and extra args", { - skip_if_not_installed("BiocParallel") - res <- pecotmr:::bplapplyBlocks( - list(2, 3), - function(i, k) i + k, - BPPARAM = BiocParallel::SerialParam(), - k = 10 - ) - expect_equal(res, list(12, 13)) -}) - # --------------------------------------------------------------------------- # checkGenomeBuild — unknown object type branch # --------------------------------------------------------------------------- @@ -2077,7 +2149,10 @@ test_that("h2EstimateToSldscTrait assigns category names to unnamed annotationJa colnames(tb) <- NULL h2_obj@annotationJackknifeCoefs <- tb result <- h2EstimateToSldscTrait(h2_obj) - expect_equal(colnames(result$annotationJackknifeCoefs), c("annot1", "annot2")) + expect_equal( + colnames(result$annotationJackknifeCoefs), + c("annot1", "annot2") + ) expect_equal(result$nBlocks, 10L) }) @@ -2108,7 +2183,7 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" studyName = c("studyA", "studyB"), entry = list(gr, gr), genome = "hg19", - ldSketch = makeTestGwasGenotypeHandle(), + ldReference = makeTestGwasGenotypeHandle(), varY = NA_real_ ) expect_error( @@ -2122,7 +2197,7 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" # # These validate the LDER / gLDSC / HDL estimators against data simulated with # a KNOWN heritability, using fixed seeds so every run is deterministic and -# self-contained (no dependence on the upstream LDER/gLDSC/HDL packages). +# self-contained (no dependence on the original LDER/gLDSC/HDL packages). # Recovery tests check the mean estimate recovers the true h2; the stored means # pin the known-input -> known-output values. Behavioral tests lock in the # nRef / inSample wiring and the g-LDSC bug fixes. @@ -2308,7 +2383,7 @@ test_that("gLDSC requires full LD matrices and gives a positive jackknife SE", { ss <- makeTestSumstatsForRef(noMat) expect_error( estimateH2(ss, noMat, method = "gldsc"), - "requires full per-block LD matrices" + "g-LDSC needs each LD block's LD" ) d <- .h2RecoveryRefs() set.seed(1) @@ -2365,9 +2440,9 @@ test_that("S-LDSC tracks h2 upward when the true h2 rises", { test_that("the S-LDSC intercept is estimated on the low-chi2 variants", { # Two-step: step 1 fits the intercept on chi2 < 30, step 2 holds it fixed - # while fitting the slopes. The value is reported as estimated -- upstream - # does not floor it at 1, and one below 1 is informative rather than an - # error to be clamped away. + # while fitting the slopes. The value is reported as estimated -- the + # original ldsc does not floor it at 1, and one below 1 is informative + # rather than an error to be clamped away. d <- .h2RecoveryRefs(N = 5000) set.seed(1) res <- pecotmr:::sldscUnivariate( @@ -2411,48 +2486,97 @@ test_that("S-LDSC recovers enrichment direction for one annotation", { # ============================================================================= -# Numerical agreement with upstream LDSC +# Numerical agreement with the original ldsc # # Values below were produced by running ldsc's own `ldscore.regressions.Hsq` -# (github.com/CBIIT/ldsc) on exactly the data these tests regenerate, in the -# two configurations `ldscore/sumstats.py` selects: +# (github.com/CBIIT/ldsc) on exactly the data these tests rebuild, in the +# two configurations `ldscore/sumstats.py` selects. The LD scores, base and +# stratified alike, sum ldsc's unbiased r^2 at n = 1000, as ldsc's own scores +# do, so .h2ParityRef() builds them at that n: # # univariate -> Hsq(..., twostep = 30) # partitioned -> chi2 < max(0.001 N, 80) filter, then Hsq(..., old_weights # = True) # # Agreement is to about 1e-6 relative; the residual is the small ridge in -# .sldscWlsCoef(), which upstream has no equivalent of. Case 2's intercept -# sits below 1 and case 3's partitioned h2 is negative -- upstream returns -# those too, and reproducing them is the point: the implementation should -# track the reference, pathologies included. +# .sldscWlsCoef(), which the original has no equivalent of. Case 2's +# intercept sits below 1 and case 3's partitioned h2 is negative -- the +# original returns those too, and reproducing them is the point: the +# implementation should track the reference, pathologies included. # ============================================================================= -# The z-scores upstream was run on: z ~ N(0, N R diag(v) R + R), drawn block -# by block over the bundled reference and PINNED as data. +# The z-scores the original implementations were run on: +# z ~ N(0, N R diag(v) R + R), drawn block by block over the parity LD below +# and PINNED as data. # # Read from a fixture rather than re-simulated because the draw used # `eigen()`: z = V sqrt(D) w. eigen() fixes eigenvectors only up to sign, and # the sign LAPACK returns differs between builds, so the same seed produced # different z -- and therefore different estimates -- on linux-64 than on # osx-arm64 / linux-aarch64. The comparisons above are only meaningful -# against the exact vectors upstream was run on, so those are stored. +# against the exact vectors the original implementations were run on, so +# those are stored. # -# Rebuild with inst/scripts/build_sldsc_upstream_z.R, and ONLY together with -# re-deriving the upstream values: the data and the expected numbers are a +# Rebuild with inst/scripts/build_h2_parity_z.R, and ONLY together with +# re-deriving the expected values: the data and the expected numbers are a # matched pair. -.sldscUpstreamZ <- function(ref, h2, n, seed) { +.h2ParityZ <- function(h2, n, seed) { key <- paste(h2, n, seed, sep = "_") - zAll <- readRDS(test_path("test_data", "sldscUpstreamZ.rds")) + zAll <- readRDS(test_path("test_data", "h2ParityZ.rds")) if (!(key %in% names(zAll))) { stop("no pinned z-scores for case '", key, "'") } zAll[[key]] } -test_that("univariate S-LDSC reproduces upstream ldsc to 1e-5", { - data(ldScoreExample) - ref <- ldScoreExample +# The LD every pinned value in this file was derived from: the 14 chr22 LD +# blocks (1,300 variants) the bundled ldScoreExample / ldEigenExample held +# until 2026-10-20, frozen in test_data/h2ParityLd.rds as each block's strict +# upper triangle. Keeping them apart from the bundled examples lets those be +# rebuilt without moving a single pin. The S-LDSC scores are ldsc's unbiased +# r^2 at `nSamples`; eigen() fixes each eigenvector only up to sign, which +# none of the estimators depends on. +.h2ParityRef <- function(nSamples = 1000L) { + fx <- readRDS(test_path("test_data", "h2ParityLd.rds")) + blocks <- map(fx$blocks, function(b) { + R <- diag(length(b$snpIdx)) + R[upper.tri(R)] <- b$upper + R[lower.tri(R)] <- t(R)[lower.tri(R)] + ids <- fx$snpInfo$SNP[b$snpIdx] + list(R = `dimnames<-`(R, list(ids, ids)), snpIdx = b$snpIdx) + }) + base <- numeric(nrow(fx$snpInfo)) + for (b in blocks) { + base[b$snpIdx] <- rowSums( + pecotmr:::.ldscUnbiasedR2(b$R^2, nSamples) + ) + } + eigens <- map(blocks, function(b) { + e <- eigen(b$R, symmetric = TRUE) + list(values = e$values, vectors = e$vectors, snpIdx = b$snpIdx) + }) + list( + score = LdScore( + snpInfo = fx$snpInfo, + ldScores = matrix(base, ncol = 1, dimnames = list(NULL, "base_l2")), + ldScoreWeights = base, + ldBlocks = fx$ldBlocks, + nSamples = nSamples, + genome = fx$genome, + ldMatrixList = blocks + ), + eigen = LdEigen( + snpInfo = fx$snpInfo, + eigenList = eigens, + ldBlocks = fx$ldBlocks, + nSamples = nSamples, + genome = fx$genome + ) + ) +} + +test_that("univariate S-LDSC reproduces the original ldsc to 1e-5", { + ref <- .h2ParityRef()$score M <- length(ref) scores <- matrix(as.vector(mcols(ref)$ldScores[, 1]), ncol = 1) baseScore <- as.vector(mcols(ref)$ldScores[, 1]) @@ -2462,26 +2586,26 @@ test_that("univariate S-LDSC reproduces upstream ldsc to 1e-5", { h2 = 0.4, n = 10000, seed = 42, - h2Hat = 0.300334136, - int = 5.736461154 + h2Hat = 0.307612483, + int = 5.724347641 ), list( h2 = 0.15, n = 4000, seed = 7, - h2Hat = 0.152728247, - int = 0.780709941 + h2Hat = 0.152458832, + int = 0.826813787 ), list( h2 = 0.6, n = 25000, seed = 99, - h2Hat = 0.503086101, - int = 8.456195324 + h2Hat = 0.515391513, + int = 8.460347119 ) ) for (g in reference) { - z <- .sldscUpstreamZ(ref, g$h2, g$n, g$seed) + z <- .h2ParityZ(g$h2, g$n, g$seed) fit <- pecotmr:::.sldscFit( z^2, scores, @@ -2495,9 +2619,8 @@ test_that("univariate S-LDSC reproduces upstream ldsc to 1e-5", { } }) -test_that("partitioned S-LDSC reproduces upstream ldsc to 1e-5", { - data(ldScoreExample) - ref <- ldScoreExample +test_that("partitioned S-LDSC reproduces the original ldsc to 1e-5", { + ref <- .h2ParityRef()$score M <- length(ref) inA <- as.integer(seq_len(M) <= M / 2) baselineMat <- matrix(inA, ncol = 1, dimnames = list(NULL, "annotA")) @@ -2509,41 +2632,40 @@ test_that("partitioned S-LDSC reproduces upstream ldsc to 1e-5", { h2 = 0.4, n = 10000, seed = 42, - h2Hat = 0.361252238, - int = 2.027277477 + h2Hat = 0.366278912, + int = 2.143763992 ), list( h2 = 0.15, n = 4000, seed = 7, - h2Hat = 0.146509163, - int = 0.858189571 + h2Hat = 0.146933464, + int = 0.894710259 ), list( h2 = 0.6, n = 25000, seed = 99, - h2Hat = -0.043265091, - int = 22.163686076 + h2Hat = -0.042445193, + int = 22.018356554 ) ) for (g in reference) { - z <- .sldscUpstreamZ(ref, g$h2, g$n, g$seed) + z <- .h2ParityZ(g$h2, g$n, g$seed) fit <- pecotmr:::.sldscFit(z^2, scores, scores[, 1], g$n, A, 2L) expect_equal(fit$h2, g$h2Hat, tolerance = 1e-5) expect_equal(fit$intercept, g$int, tolerance = 1e-5) } }) -test_that("the two S-LDSC routes differ, as upstream's do", { +test_that("the two S-LDSC routes differ, as the original ldsc's do", { # Univariate takes the two-step estimator; partitioned takes the - # chi2-filtered single-pass `old_weights` route. Upstream refuses to run - # two-step on a partitioned design at all, so these must not converge to - # one shared code path. - data(ldScoreExample) - ref <- ldScoreExample + # chi2-filtered single-pass `old_weights` route. The original ldsc refuses + # to run two-step on a partitioned design at all, so these must not + # converge to one shared code path. + ref <- .h2ParityRef()$score M <- length(ref) - z <- .sldscUpstreamZ(ref, 0.4, 10000, 42) + z <- .h2ParityZ(0.4, 10000, 42) scores <- matrix(as.vector(mcols(ref)$ldScores[, 1]), ncol = 1) uni <- pecotmr:::.sldscFit( z^2, @@ -2581,19 +2703,15 @@ test_that("HDL reports when its fit lands on an optimiser bound", { # optimiser walks the intercept out to its upper bound -- returning a # heritability that reflects the bound rather than the data. It used to do # that silently. - data(ldEigenExample, ldScoreExample) - M <- length(ldScoreExample) - z <- .sldscUpstreamZ(ldScoreExample, 0.4, 1e5, 2) + z <- .h2ParityZ(0.4, 1e5, 2) - small <- ldEigenExample - small@nSamples <- 1000L + small <- .h2ParityRef(nSamples = 1000L)$eigen expect_warning( est <- pecotmr:::hdlUnivariate(z, 1e5, small)$h2, "sits at the top of its range" ) - big <- ldEigenExample - big@nSamples <- 20000L + big <- .h2ParityRef(nSamples = 20000L)$eigen expect_no_warning( ok <- pecotmr:::hdlUnivariate(z, 1e5, big)$h2, message = "sits at the top of its range" @@ -2606,18 +2724,12 @@ test_that("HDL reports when its fit lands on an optimiser bound", { }) test_that("HDL recovers a known h2 given an adequate reference", { - data(ldEigenExample, ldScoreExample) - ref <- ldEigenExample - ref@nSamples <- 20000L + ref <- .h2ParityRef(nSamples = 20000L)$eigen ests <- map_dbl( 1:5, function(seed) { suppressWarnings( - pecotmr:::hdlUnivariate( - .sldscUpstreamZ(ldScoreExample, 0.4, 1e5, seed), - 1e5, - ref - )$h2 + pecotmr:::hdlUnivariate(.h2ParityZ(0.4, 1e5, seed), 1e5, ref)$h2 ) } ) @@ -2626,10 +2738,10 @@ test_that("HDL recovers a known h2 given an adequate reference", { # ============================================================================= -# Numerical agreement with the other three upstreams +# Numerical agreement with the other three original implementations # # Values reproduce the reference implementations run on the data these tests -# regenerate: +# rebuild: # HDL github.com/zhenin/HDL (HDL/R/llfun.R, optimised the same way) # LDER github.com/shuangsong0110/LDER (R/get.res.R two-stage + ldscore.R) # gLDSC github.com/xzw20046/gldsc (R/middle_fun.R gls.left.right + @@ -2637,63 +2749,61 @@ test_that("HDL recovers a known h2 given an adequate reference", { # # Measured agreement when this was pinned: HDL exact (0e+00), LDER machine # precision (~1e-16), gLDSC ~3e-8 -- the last from the small ridge on the GLS -# solve, which upstream has no equivalent of. +# solve, which the original has no equivalent of. # -# Two deliberate departures, both no-ops wherever upstream is defined: -# * LDER clamps negative eigenvalues before forming weights. Upstream does -# not, and dies with "NA/NaN/Inf in 'x'" on a rank-deficient reference -- -# verified by running it on this same data. +# Two deliberate departures, both no-ops wherever the originals are defined: +# * LDER clamps negative eigenvalues before forming weights. The original +# does not, and dies with "NA/NaN/Inf in 'x'" on a rank-deficient +# reference -- verified by running it on this same data. # * gLDSC and S-LDSC carry a 1e-8 ridge so an exactly singular design # returns a value rather than NA. # ============================================================================= -test_that("HDL reproduces upstream HDL", { - data(ldEigenExample, ldScoreExample) +test_that("HDL reproduces the original HDL", { reference <- list( list(h2 = 0.4, n = 1e5, seed = 2, nRef = 20000L, want = 0.405111844), list(h2 = 0.3, n = 1e4, seed = 5, nRef = 20000L, want = 0.286758612), list(h2 = 0.6, n = 5e4, seed = 9, nRef = 50000L, want = 0.646809004) ) for (g in reference) { - ref <- ldEigenExample - ref@nSamples <- g$nRef - z <- .sldscUpstreamZ(ldScoreExample, g$h2, g$n, g$seed) + ref <- .h2ParityRef(nSamples = g$nRef)$eigen + z <- .h2ParityZ(g$h2, g$n, g$seed) est <- suppressWarnings(pecotmr:::hdlUnivariate(z, g$n, ref)$h2) expect_equal(est, g$want, tolerance = 1e-6) } }) -test_that("the HDL variance floor matches upstream's exp(-10)", { - # Upstream llfun floors the modelled per-direction variance at exp(-10). - # On a real reference the floor is active for a large share of the - # eigen-directions, and the bstar^2/lamh2 term it feeds dominates the +test_that("the HDL variance floor matches the original's exp(-10)", { + # The original llfun floors the modelled per-direction variance at + # exp(-10). On a real reference the floor is active for a large share of + # the eigen-directions, and the bstar^2/lamh2 term it feeds dominates the # likelihood -- a different floor silently moves the optimum. expect_equal(formals(pecotmr:::.hdlNll)$lim, quote(exp(-10))) }) -test_that("LDER reproduces upstream LDER", { - data(ldEigenExample, ldScoreExample) +test_that("LDER reproduces the original LDER", { + ref <- .h2ParityRef()$eigen reference <- list( list(h2 = 0.4, n = 1e5, seed = 2, want = 0.416906429), list(h2 = 0.3, n = 1e4, seed = 5, want = 0.289677426), list(h2 = 0.6, n = 5e4, seed = 9, want = 0.626712459) ) for (g in reference) { - z <- .sldscUpstreamZ(ldScoreExample, g$h2, g$n, g$seed) - est <- pecotmr:::lderUnivariate(z, g$n, ldEigenExample)$h2 + z <- .h2ParityZ(g$h2, g$n, g$seed) + est <- pecotmr:::lderUnivariate(z, g$n, ref)$h2 expect_equal(est, g$want, tolerance = 1e-6) } }) -test_that("gLDSC reproduces upstream gldsc", { - data(ldScoreExample) +test_that("gLDSC reproduces the original gldsc", { + ref <- .h2ParityRef()$score reference <- list( list(h2 = 0.4, n = 5e4, seed = 3, want = 0.407716183), list(h2 = 0.3, n = 1e4, seed = 5, want = 0.290373743) ) for (g in reference) { - z <- .sldscUpstreamZ(ldScoreExample, g$h2, g$n, g$seed) - est <- pecotmr:::gldscUnivariate(z, g$n, ldScoreExample)$h2 + z <- .h2ParityZ(g$h2, g$n, g$seed) + est <- pecotmr:::gldscUnivariate(z, g$n, ref)$h2 expect_equal(est, g$want, tolerance = 1e-6) } }) @@ -2729,7 +2839,7 @@ test_that("the genome check skips an unlabelled build and refuses a mixture", { }) test_that("the chi2 filter is abandoned when too few variants survive it", { - # Upstream drops chi2 >= 30, but with fewer than 4 survivors the + # The original ldsc drops chi2 >= 30, but with fewer than 4 survivors the # regression has nothing to fit, so the filter is dropped rather than # returning an estimate from 3 points. A <- matrix(1, 6L, 1L) diff --git a/tests/testthat/test_jointEngine.R b/tests/testthat/test_jointEngine.R index 84a1e201f..cd1216f7f 100644 --- a/tests/testthat/test_jointEngine.R +++ b/tests/testthat/test_jointEngine.R @@ -80,7 +80,11 @@ test_that(".runJointCell: cross-context FM expands to per-context rows", { "FmJointPipeline", config = list( coverage = 0.95, - crossValidationArgs = list(folds = 0, threads = 1, maxVariants = -1) + crossValidationParam = list( + folds = 0, + threads = 1, + maxVariants = -1 + ) ) ) local_mocked_bindings( @@ -122,7 +126,7 @@ test_that(".runJointCell (mvsusie): fullFit config threads to postprocess", { includeAllCs = TRUE, perCsColumns = "full" ), - crossValidationArgs = list( + crossValidationParam = list( folds = 0, threads = 1, maxVariants = -1 @@ -189,7 +193,11 @@ test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", "FmJointPipeline", config = list( coverage = 0.95, - crossValidationArgs = list(folds = 2, threads = 1, maxVariants = -1) + crossValidationParam = list( + folds = 2, + threads = 1, + maxVariants = -1 + ) ) ) @@ -368,7 +376,11 @@ test_that(".runJointCell: cross-context twas expands to per-context weight vecto pipe <- new( "TwasJointPipeline", config = list( - crossValidationArgs = list(folds = 0, threads = 1, maxVariants = -1) + crossValidationParam = list( + folds = 0, + threads = 1, + maxVariants = -1 + ) ) ) local_mocked_bindings( @@ -402,7 +414,11 @@ test_that(".runJointCell: cross-context twas attaches per-condition CV slices", pipe <- new( "TwasJointPipeline", config = list( - crossValidationArgs = list(folds = 2, threads = 1, maxVariants = -1) + crossValidationParam = list( + folds = 2, + threads = 1, + maxVariants = -1 + ) ) ) local_mocked_bindings( @@ -434,12 +450,12 @@ test_that(".runJointCell: cross-context twas CV-only rows (fitFullData=FALSE)", pipe <- new( "TwasJointPipeline", config = list( - crossValidationArgs = list( + crossValidationParam = list( folds = 2, threads = 1, - maxVariants = -1 - ), - fitFullData = FALSE + maxVariants = -1, + fitFullData = FALSE + ) ) ) local_mocked_bindings(twasWeightsCv = .je_mockTwasCv, .package = "pecotmr") @@ -480,8 +496,8 @@ test_that(".runJointCell: cross-context twas CV-only rows (fitFullData=FALSE)", ), Z = Z, # The group carries the LD REFERENCE now; tests that fit mock - # .ldFromSketch to supply the matrix (see .je_mockSsLd). - ldSketch = NULL, + # .ldFromRef to supply the matrix (see .je_mockSsLd). + ldReference = NULL, N = c(100, 120) ) } @@ -506,7 +522,7 @@ test_that(".runJointCell: cross-context twas CV-only rows (fitFullData=FALSE)", test_that(".runJointCell: cross-context FM sumstats (mvsusie_rss) -> per-context", { # The group carries the LD reference; supply the matrix it derives. local_mocked_bindings( - .ldFromSketch = .je_mockSsLd, + .ldFromRef = .je_mockSsLd, .package = "pecotmr" ) set.seed(6) @@ -543,19 +559,20 @@ test_that(".runJointCell: cross-context FM sumstats (mvsusie_rss) -> per-context test_that(".runJointCell: cross-context twas sumstats (mr.mash.rss) -> per-context", { # The group carries the LD reference; supply the matrix it derives. local_mocked_bindings( - .ldFromSketch = .je_mockSsLd, + .ldFromRef = .je_mockSsLd, .package = "pecotmr" ) set.seed(7) cell <- .je_ssCell(list(.je_mkSsGroup("G1"))) pipe <- new("TwasJointPipeline", config = list()) local_mocked_bindings( - mrmashRssWeights = function(stat, LD, fitRetention) { + mrmashRssWeights = function(stat, ldReference, fitRetention) { + ids <- stat$variantNames W <- matrix( 0.2, - nrow(LD), + length(ids), ncol(stat$z), - dimnames = list(rownames(LD), colnames(stat$z)) + dimnames = list(ids, colnames(stat$z)) ) attr(W, "fit") <- .je_fakeMrmashFit() W @@ -579,11 +596,6 @@ test_that(".runJointCell: cross-context twas sumstats (mr.mash.rss) -> per-conte }) test_that("fitJointGroup(SumStats, Twas): real mr.mash-rss keys stat$n (regression)", { - # The group carries the LD reference; supply the matrix it derives. - local_mocked_bindings( - .ldFromSketch = .je_mockSsLd, - .package = "pecotmr" - ) skip_if_not_installed("mr.mashr") # The sibling tests above mock mrmashRssWeights, so the real reader # (.mrmashRssStats, which keys on stat$n) was never exercised. The method @@ -611,13 +623,13 @@ test_that("fitJointGroup(SumStats, Twas): real mr.mash-rss keys stat$n (regressi stringsAsFactors = FALSE ), Z = Z, - ldSketch = NULL, + ldReference = LdMatrix(R), N = rep(nObs, K) ) pipe <- new( "TwasJointPipeline", config = list( - crossValidationArgs = list( + crossValidationParam = list( folds = 0L, threads = 1, maxVariants = -1 @@ -659,7 +671,7 @@ test_that(".lookupJointCell: present cells resolve, absent cells error", { test_that(".runJointCell: cross-study (twas sumstats) -> per-study rows + jointStudies", { # The group carries the LD reference; supply the matrix it derives. local_mocked_bindings( - .ldFromSketch = .je_mockSsLd, + .ldFromRef = .je_mockSsLd, .package = "pecotmr" ) set.seed(10) @@ -683,7 +695,7 @@ test_that(".runJointCell: cross-study (twas sumstats) -> per-study rows + jointS stringsAsFactors = FALSE ), Z = Z, - ldSketch = NULL, + ldReference = NULL, N = c(100, 120) ) cell <- new( @@ -695,12 +707,13 @@ test_that(".runJointCell: cross-study (twas sumstats) -> per-study rows + jointS ) pipe <- new("TwasJointPipeline", config = list()) local_mocked_bindings( - mrmashRssWeights = function(stat, LD, fitRetention) { + mrmashRssWeights = function(stat, ldReference, fitRetention) { + ids <- stat$variantNames W <- matrix( 0.2, - nrow(LD), + length(ids), ncol(stat$z), - dimnames = list(rownames(LD), colnames(stat$z)) + dimnames = list(ids, colnames(stat$z)) ) attr(W, "fit") <- .je_fakeMrmashFit() W @@ -761,7 +774,11 @@ test_that(".runJointCell: composed (context + trait vary) -> per-tuple rows", { "FmJointPipeline", config = list( coverage = 0.95, - crossValidationArgs = list(folds = 0, threads = 1, maxVariants = -1) + crossValidationParam = list( + folds = 0, + threads = 1, + maxVariants = -1 + ) ) ) local_mocked_bindings( @@ -839,7 +856,11 @@ test_that(".runJointCell: cross-trait FM -> per-trait rows (context fixed)", { "FmJointPipeline", config = list( coverage = 0.95, - crossValidationArgs = list(folds = 0, threads = 1, maxVariants = -1) + crossValidationParam = list( + folds = 0, + threads = 1, + maxVariants = -1 + ) ) ) local_mocked_bindings( @@ -872,7 +893,11 @@ test_that(".runJointCell: cross-trait twas -> per-trait weight vectors", { pipe <- new( "TwasJointPipeline", config = list( - crossValidationArgs = list(folds = 0, threads = 1, maxVariants = -1) + crossValidationParam = list( + folds = 0, + threads = 1, + maxVariants = -1 + ) ) ) local_mocked_bindings( @@ -979,7 +1004,7 @@ test_that("fitJointGroup(Individual, Fm): fsusie without pos errors; unknown tok test_that(".runJointCell: composed/sumstats (context+trait vary) -> per-tuple rows", { # The group carries the LD reference; supply the matrix it derives. local_mocked_bindings( - .ldFromSketch = .je_mockSsLd, + .ldFromRef = .je_mockSsLd, .package = "pecotmr" ) set.seed(13) @@ -1007,7 +1032,7 @@ test_that(".runJointCell: composed/sumstats (context+trait vary) -> per-tuple ro "SumStatsJointGroup", conditions = conds, Z = Z, - ldSketch = NULL, + ldReference = NULL, N = c(100, 100, 120) ) cell <- new( @@ -1019,12 +1044,13 @@ test_that(".runJointCell: composed/sumstats (context+trait vary) -> per-tuple ro ) pipe <- new("TwasJointPipeline", config = list()) local_mocked_bindings( - mrmashRssWeights = function(stat, LD, fitRetention) { + mrmashRssWeights = function(stat, ldReference, fitRetention) { + ids <- stat$variantNames W <- matrix( 0.2, - nrow(LD), + length(ids), ncol(stat$z), - dimnames = list(rownames(LD), colnames(stat$z)) + dimnames = list(ids, colnames(stat$z)) ) attr(W, "fit") <- .je_fakeMrmashFit() W @@ -1117,7 +1143,7 @@ test_that(".twasEnsembleLayer: >= 2 methods passing -> per-condition ensemble en g, pte, list( - ensembleArgs = list( + ensembleParam = list( enabled = TRUE, r2Threshold = 0.01, solver = "quadprog", @@ -1145,7 +1171,7 @@ test_that(".twasEnsembleLayer: < 2 methods pass the R^2 cutoff -> NULL (skip)", g, pte, list( - ensembleArgs = list( + ensembleParam = list( enabled = TRUE, r2Threshold = 0.999, solver = "quadprog", @@ -1165,12 +1191,12 @@ test_that("fitJointGroup(twas): leakage warning when a full-data mr.mash prior i pipe <- new( "TwasJointPipeline", config = list( - crossValidationArgs = list( + crossValidationParam = list( folds = 2L, threads = 1, maxVariants = -1 ), - ensembleArgs = list(enabled = FALSE) + ensembleParam = list(enabled = FALSE) ) ) local_mocked_bindings( @@ -1222,12 +1248,12 @@ test_that("fitJointGroup(twas): spike-and-slab pi is estimated from an internal pipe <- new( "TwasJointPipeline", config = list( - crossValidationArgs = list( + crossValidationParam = list( folds = 0L, threads = 1, maxVariants = -1 ), - ensembleArgs = list(enabled = FALSE), + ensembleParam = list(enabled = FALSE), estimatePi = TRUE ) ) @@ -1260,12 +1286,12 @@ test_that("fitJointGroup(twas): FM-derived method reuses fine-mapping's CV (hand pipe <- new( "TwasJointPipeline", config = list( - crossValidationArgs = list( + crossValidationParam = list( folds = 2L, threads = 1, maxVariants = -1 ), - ensembleArgs = list(enabled = FALSE) + ensembleParam = list(enabled = FALSE) ) ) samp <- rownames(.jgX(g)) @@ -1353,7 +1379,7 @@ test_that("fitJointGroup(twas): FM-derived method reuses fine-mapping's CV (hand tupleRows, colLabels, errorLabel, - ldSketch = NULL, + ldReference = NULL, cutoffs = NULL ) { p <- 3L @@ -1475,9 +1501,9 @@ test_that(".enumCrossContextSumstats: groups per (study, trait) with >= 2 contex traits = list(S = "t1") ) local_mocked_bindings( - ldSketch = function(x) NULL, + ldReference = function(x) NULL, .buildJointSumstatZMatrix = .je_mockJointZ, - .ldFromSketch = .je_mockLd, + .ldFromRef = .je_mockLd, .package = "pecotmr" ) g <- pecotmr:::.enumCrossContextSumstats(df, scope) @@ -1488,9 +1514,9 @@ test_that(".enumCrossContextSumstats: groups per (study, trait) with >= 2 contex test_that(".enumCrossContextSumstats: < 2 contexts and < 2 tuple rows skip", { local_mocked_bindings( - ldSketch = function(x) NULL, + ldReference = function(x) NULL, .buildJointSumstatZMatrix = .je_mockJointZ, - .ldFromSketch = .je_mockLd, + .ldFromRef = .je_mockLd, .package = "pecotmr" ) # study scoped to two contexts but only one row present -> < 2 tupleRows skip @@ -1578,9 +1604,9 @@ test_that(".enumCrossTraitSumstats: groups per (study, context) with >= 2 traits traits = list(S = c("t1", "t2")) ) local_mocked_bindings( - ldSketch = function(x) NULL, + ldReference = function(x) NULL, .buildJointSumstatZMatrix = .je_mockJointZ, - .ldFromSketch = .je_mockLd, + .ldFromRef = .je_mockLd, .package = "pecotmr" ) g <- pecotmr:::.enumCrossTraitSumstats(df, scope) @@ -1599,9 +1625,9 @@ test_that(".enumCrossStudySumstats: group per (context, trait) in >= 2 studies", traits = list(S1 = "t1", S2 = "t1") ) local_mocked_bindings( - ldSketch = function(x) NULL, + ldReference = function(x) NULL, .buildJointSumstatZMatrix = .je_mockJointZ, - .ldFromSketch = .je_mockLd, + .ldFromRef = .je_mockLd, .package = "pecotmr" ) g <- pecotmr:::.enumCrossStudySumstats(df, scope) @@ -1791,7 +1817,7 @@ test_that(".enumComposedSumstats: one group per fixed-axis row block", { traits = list(S = "t1") ) local_mocked_bindings( - ldSketch = function(x) NULL, + ldReference = function(x) NULL, .enumerateComposedSumstatGroups = function(spec, data, scope) { list( groups = list(c(1L, 2L)), @@ -1801,7 +1827,7 @@ test_that(".enumComposedSumstats: one group per fixed-axis row block", { ) }, .buildJointSumstatZMatrix = .je_mockJointZ, - .ldFromSketch = .je_mockLd, + .ldFromRef = .je_mockLd, .package = "pecotmr" ) g <- pecotmr:::.enumComposedSumstats( @@ -1815,7 +1841,7 @@ test_that(".enumComposedSumstats: one group per fixed-axis row block", { test_that(".enumComposedSumstats: NULL group index and singleton blocks skip", { local_mocked_bindings( - ldSketch = function(x) NULL, + ldReference = function(x) NULL, .enumerateComposedSumstatGroups = function(spec, data, scope) NULL, .package = "pecotmr" ) @@ -1827,7 +1853,7 @@ test_that(".enumComposedSumstats: NULL group index and singleton blocks skip", { 0L ) # gi NULL (646) local_mocked_bindings( - ldSketch = function(x) NULL, + ldReference = function(x) NULL, .enumerateComposedSumstatGroups = function(spec, data, scope) { list( groups = list(1L), @@ -1837,7 +1863,7 @@ test_that(".enumComposedSumstats: NULL group index and singleton blocks skip", { ) }, .buildJointSumstatZMatrix = .je_mockJointZ, - .ldFromSketch = .je_mockLd, + .ldFromRef = .je_mockLd, .package = "pecotmr" ) expect_length( @@ -1888,7 +1914,11 @@ test_that("fitJointGroup(Individual, Fm): fsusie honest per-fold CV is attached" "FmJointPipeline", config = list( coverage = 0.95, - crossValidationArgs = list(folds = 3, threads = 1, maxVariants = -1) + crossValidationParam = list( + folds = 3, + threads = 1, + maxVariants = -1 + ) ) ) cvCalled <- FALSE @@ -1990,7 +2020,7 @@ test_that("fitJointGroup(SumStats, Fm): fsusie and unknown tokens error", { test_that("fitJointGroup(SumStats, Fm): a reweighted-prior residual variance is threaded", { # The group carries the LD reference; supply the matrix it derives. local_mocked_bindings( - .ldFromSketch = .je_mockSsLd, + .ldFromRef = .je_mockSsLd, .package = "pecotmr" ) grp <- .je_mkSsGroup("G1") @@ -2046,12 +2076,12 @@ test_that("fitJointGroup(twas): spike-and-slab pi feeds bayes_b probIn", { pipe <- new( "TwasJointPipeline", config = list( - crossValidationArgs = list( + crossValidationParam = list( folds = 0L, threads = 1, maxVariants = -1 ), - ensembleArgs = list(enabled = FALSE), + ensembleParam = list(enabled = FALSE), estimatePi = TRUE ) ) @@ -2080,15 +2110,15 @@ test_that("fitJointGroup(twas): spike-and-slab pi feeds bayes_b probIn", { test_that("fitJointGroup(SumStats, twas): a vector weight without rownames falls back to Z rows", { # The group carries the LD reference; supply the matrix it derives. local_mocked_bindings( - .ldFromSketch = .je_mockSsLd, + .ldFromRef = .je_mockSsLd, .package = "pecotmr" ) grp <- .je_mkSsGroup("G1", p = 3L, k = 2L) pipe <- new("TwasJointPipeline", config = list()) local_mocked_bindings( - mrmashRssWeights = function(stat, LD, fitRetention) { + mrmashRssWeights = function(stat, ldReference, fitRetention) { # Return a bare numeric vector (one column collapsed) with no names. - w <- as.numeric(rep(0.2, nrow(LD) * ncol(stat$z))) + w <- as.numeric(rep(0.2, length(stat$variantNames) * ncol(stat$z))) attr(w, "fit") <- .je_fakeMrmashFit() w }, @@ -2147,12 +2177,12 @@ test_that(".runJointCell: twas ensemble layer adds 'ensemble' rows on top of >= pipe <- new( "TwasJointPipeline", config = list( - crossValidationArgs = list( + crossValidationParam = list( folds = 2L, threads = 1, maxVariants = -1 ), - ensembleArgs = list( + ensembleParam = list( enabled = TRUE, r2Threshold = 0.01, solver = "quadprog", @@ -2193,7 +2223,7 @@ test_that(".twasEnsembleLayer: entries lacking CV predictions are skipped", { g, list(a = good, b = noCv, c = NULL), list( - ensembleArgs = list( + ensembleParam = list( enabled = TRUE, r2Threshold = 0.01, solver = "quadprog", @@ -2220,7 +2250,7 @@ test_that(".twasEnsembleLayer: ensembleWeights returning NULL -> NULL entry", { g, pte, list( - ensembleArgs = list( + ensembleParam = list( enabled = TRUE, r2Threshold = 0.01, solver = "quadprog", @@ -2260,7 +2290,7 @@ test_that(".twasEnsembleLayer: unnamed ensemble weights fall back to a method's g, pte, list( - ensembleArgs = list( + ensembleParam = list( enabled = TRUE, r2Threshold = 0.01, solver = "quadprog", @@ -2326,7 +2356,7 @@ test_that("construct: empty records -> NULL for both pipelines", { }) test_that(".runJointSpecs: no methods or no specs -> NULL", { - pipe <- new("FmJointPipeline", config = list(ldSketch = NULL)) + pipe <- new("FmJointPipeline", config = list(ldReference = NULL)) expect_null(pecotmr:::.runJointSpecs( list(), NULL, @@ -2357,7 +2387,7 @@ test_that(".twasGroupArgs: takes the CV partition from the fine-mapping CV when pipe <- new( "TwasJointPipeline", config = list( - crossValidationArgs = list( + crossValidationParam = list( folds = 2L, threads = 1, maxVariants = -1 @@ -2396,7 +2426,7 @@ test_that(".runJointCell: a token whose fitter returns NULL is skipped", { }) test_that(".runJointSpecs: region mode without traitId restricts scoped traits to the locus", { - pipe <- new("FmJointPipeline", config = list(ldSketch = NULL)) + pipe <- new("FmJointPipeline", config = list(ldReference = NULL)) region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 100)) captured <- NULL local_mocked_bindings( @@ -2679,12 +2709,14 @@ test_that("rbinding an empty collection leaves the other unchanged", { test_that(".runJointSpecs row-binds TWAS results across specs", { calls <- 0L local_mocked_bindings( - .jpConfig = function(pipeline) list(ldSketch = NULL), + .jpConfig = function(pipeline) list(ldReference = NULL), .runOneJointSpec = function(...) { calls <<- calls + 1L str_c("R", calls) }, - .rbindTwasWeights = function(out, res, ldSketch) str_c(out, "+", res), + .rbindTwasWeights = function(out, res, ldReference) { + str_c(out, "+", res) + }, .package = "pecotmr" ) out <- pecotmr:::.runJointSpecs( @@ -2704,12 +2736,12 @@ test_that(".runJointSpecs row-binds TWAS results across specs", { test_that(".runJointSpecs row-binds fine-mapping results across specs", { calls <- 0L local_mocked_bindings( - .jpConfig = function(pipeline) list(ldSketch = NULL), + .jpConfig = function(pipeline) list(ldReference = NULL), .runOneJointSpec = function(...) { calls <<- calls + 1L str_c("F", calls) }, - .rbindFineMappingResult = function(out, res, ldSketch) { + .rbindFineMappingResult = function(out, res, ldReference) { str_c(out, "&", res) }, .package = "pecotmr" @@ -2730,11 +2762,13 @@ test_that(".runJointSpecs row-binds fine-mapping results across specs", { test_that(".runJointSpecs skips a spec that produced nothing", { local_mocked_bindings( - .jpConfig = function(pipeline) list(ldSketch = NULL), + .jpConfig = function(pipeline) list(ldReference = NULL), .runOneJointSpec = function(spec, ...) { if (spec == "s1") NULL else "KEPT" }, - .rbindTwasWeights = function(out, res, ldSketch) str_c(out, "+", res), + .rbindTwasWeights = function(out, res, ldReference) { + str_c(out, "+", res) + }, .package = "pecotmr" ) # A NULL spec must not seed `out`, or the bind would carry a NULL. @@ -2787,7 +2821,7 @@ test_that(".twasEnsembleLayer falls back to its documented config defaults", { "grp", list(), list( - ensembleArgs = list( + ensembleParam = list( enabled = TRUE, r2Threshold = 0.2, solver = "nnls", @@ -2828,7 +2862,7 @@ test_that(".jointTwasCv prefers per-call CV settings over the config", { dataDrivenPriorMatricesCv = NULL ) cfg <- list( - crossValidationArgs = list( + crossValidationParam = list( folds = 5L, samplePartition = "CFG_SP", maxVariants = 77L, @@ -2854,7 +2888,7 @@ test_that(".jointTwasCv prefers per-call CV settings over the config", { argsBare <- args argsBare$samplePartition <- NULL cfgUncapped <- cfg - cfgUncapped$crossValidationArgs$maxVariants <- 0 + cfgUncapped$crossValidationParam$maxVariants <- 0 pecotmr:::.jointTwasCv( NULL, NULL, @@ -2960,7 +2994,7 @@ test_that(".jointTwasCvRequested accepts tokens and method keys alike", { test_that(".jointTwasCv skips a method excluded by cvWeightMethods", { cfg <- list( - crossValidationArgs = list( + crossValidationParam = list( folds = 5L, threads = 1, maxVariants = -1, @@ -2982,7 +3016,7 @@ test_that(".jointTwasCv skips a method excluded by cvWeightMethods", { test_that(".jointTwasCv warns when a method is all-zero, not silently", { cfg <- list( - crossValidationArgs = list( + crossValidationParam = list( folds = 5L, threads = 1, maxVariants = -1, @@ -3006,10 +3040,10 @@ test_that(".jointTwasCv warns when a method is all-zero, not silently", { }) test_that(".jointTwasCv refuses a fine-mapping method with no per-fold fits", { - # Without a CV handoff from the FineMappingResult there is no fold fit, + # Without a CV handoff from the fine-mapping result there is no fold fit, # and this layer never fine-maps -- so it refuses rather than re-fitting. cfg <- list( - crossValidationArgs = list( + crossValidationParam = list( folds = 5L, threads = 1, maxVariants = -1, @@ -3142,3 +3176,190 @@ test_that(".jointAfForGroup resolves allele frequencies for an individual group" # A SumStats group has no design matrix to take frequencies from. expect_null(.jointAfForGroup(qtlDatasetExample, "not a group")) }) + +test_that(".jointMrmashRssWeights passes the caller's mr.mash options", { + # The summary-statistics joint fit called mrmashRssWeights() with the data + # alone, so options given for mr.mash never reached an explicit joint fit. + # They are split exactly as the per-tuple path splits them: the wrapper's + # own formals by name, the engine's arguments into `methodArgs`. + Z <- matrix( + c(1.2, -0.4, 0.3, 0.8, 0.1, -1.1), + nrow = 3, + dimnames = list( + sprintf("chr1:%d:A:G", c(100L, 200L, 300L)), + c("c1", "c2") + ) + ) + group <- new( + "SumStatsJointGroup", + conditions = data.frame( + study = "s1", + context = c("c1", "c2"), + trait = "t1", + stringsAsFactors = FALSE + ), + Z = Z, + ldReference = NULL, + N = c(100, 100) + ) + seen <- NULL + # The split reads the fitter's formals, so the stand-in keeps them. + fitter <- function() NULL + formals(fitter) <- formals(pecotmr::mrmashRssWeights) + body(fitter) <- quote({ + seen <<- list( + fitRetention = fitRetention, + canonicalPriorMatrices = canonicalPriorMatrices, + methodArgs = methodArgs + ) + NULL + }) + local_mocked_bindings( + mrmashRssWeights = fitter, + .package = "pecotmr" + ) + pecotmr:::.jointMrmashRssWeights( + group, + list(fitRetention = "full"), + list( + methodArgs = list( + mrmash = list(max_iter = 5, canonicalPriorMatrices = FALSE) + ) + ) + ) + expect_equal(seen$fitRetention, "full") + expect_false(seen$canonicalPriorMatrices) + expect_equal(seen$methodArgs$max_iter, 5) +}) + + +# ---- cross-validation-only joint fits --------------------------------------- + +.je_cvOnlyPipe <- function() { + new( + "FmJointPipeline", + config = list( + coverage = 0.95, + crossValidationParam = list( + folds = 2, + numThreads = 1, + fitFullData = FALSE + ) + ) + ) +} + +# A .fmWeightsCv() stand-in returning one prediction column and one +# performance row per condition, in the shape the per-condition slicer reads. +.je_cannedCv <- function(token, nCond) { + force(token) + force(nCond) + function(X, Y, tokens, ...) { + list( + samplePartition = data.frame( + Sample = rownames(X), + Fold = rep(1:2, length.out = nrow(X)) + ), + prediction = set_names( + list(matrix(0, nrow(X), nCond)), + str_c(token, "_predicted") + ), + performance = set_names( + list(matrix(0, nCond, 2L)), + str_c(token, "_performance") + ), + foldFits = NULL + ) + } +} + +.je_isCvOnly <- function(e) { + length(pecotmr:::.fmrPartsVariantIds(e)) == 0L && + is.null(pecotmr:::.fmrPartsSusieFit(e)) && + !is.null(cvResult(e)) +} + +test_that("fitJointGroup(Individual, Fm): CV-only mvsusie fits no full data", { + set.seed(30) + local_mocked_bindings( + create_mixture_prior = function(...) "PRIOR", + .package = "mvsusieR" + ) + local_mocked_bindings( + fitMvsusie = function(...) stop("the full-data fit ran"), + .fmPostprocessOne = function(...) stop("the full-data fit ran"), + .fmWeightsCv = .je_cannedCv("mvsusie", 2L), + .package = "pecotmr" + ) + entries <- pecotmr:::fitJointGroup( + .je_mkGroup("G1"), + .je_cvOnlyPipe(), + "mvsusie", + list() + ) + expect_length(entries, 2L) + expect_true(all(map_lgl(entries, .je_isCvOnly))) +}) + +test_that("fitJointGroup(Individual, Fm): CV-only fsusie fits no full data", { + set.seed(31) + n <- 8L + grp <- new( + "IndividualJointGroup", + conditions = data.frame( + study = "S", + context = "brain", + trait = c("G1", "G2"), + stringsAsFactors = FALSE + ), + X = matrix( + rnorm(n * 2), + n, + 2, + dimnames = list( + paste0("s", seq_len(n)), + c("chr1:100:A:G", "chr1:200:A:G") + ) + ), + Y = matrix( + rnorm(n * 2), + n, + 2, + dimnames = list(paste0("s", seq_len(n)), c("G1", "G2")) + ), + traitPos = c(100, 200) + ) + local_mocked_bindings( + fitFsusie = function(...) stop("the full-data fit ran"), + .fmPostprocessOne = function(...) stop("the full-data fit ran"), + .fmWeightsCv = .je_cannedCv("fsusie", 1L), + .package = "pecotmr" + ) + entries <- pecotmr:::fitJointGroup(grp, .je_cvOnlyPipe(), "fsusie", list()) + expect_length(entries, 1L) + # Without a fit there is no trait-position record to hang on it either. + expect_true(.je_isCvOnly(entries[[1L]])) +}) + +test_that(".jointGroupSelect drops pairs a per-context traitId leaves out", { + cond <- data.frame(study = "A", context = c("brain", "liver"), trait = "g1") + X <- matrix(0, 4, 1, dimnames = list(paste0("s", 1:4), "chr1:100:A:G")) + Y <- matrix(0, 4, 2, dimnames = list(paste0("s", 1:4), NULL)) + g <- new("IndividualJointGroup", conditions = cond, X = X, Y = Y) + # g1 is chosen for brain; liver is named too, with another trait. + kept <- pecotmr:::.jointGroupSelect( + g, + list(A = list(brain = "g1", liver = "g2")) + ) + expect_equal(pecotmr:::.jgConditions(kept)$context, "brain") + # A context the selection does not name keeps all of its traits. + expect_identical( + pecotmr:::.jointGroupSelect(g, list(A = list(brain = "g1"))), + g + ) + expect_identical(pecotmr:::.jointGroupSelect(g, NULL), g) + expect_null(pecotmr:::.jointGroupSelect( + g, + list(A = list(brain = "g2", liver = "g2")) + )) +}) diff --git a/tests/testthat/test_jointSpecification.R b/tests/testthat/test_jointSpecification.R index 86d36a77f..e8886dd23 100644 --- a/tests/testthat/test_jointSpecification.R +++ b/tests/testthat/test_jointSpecification.R @@ -8,8 +8,8 @@ .js_makeGenotypeHandle <- function(snp_n = 5L) { new( "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", + path = "/tmp/test", + format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), CHR = rep("1", snp_n), @@ -101,7 +101,7 @@ trait = rows$trait, entry = entries, genome = "hg19", - ldSketch = .js_makeGenotypeHandle() + ldReference = .js_makeGenotypeHandle() ) } @@ -329,208 +329,13 @@ test_that("parseTraitIds: doubly-nested study->context validates per context", { ) }) -# ----------------------------------------------------------------------------- -# parseMethods -# ----------------------------------------------------------------------------- - -test_that("parseMethods: methods XOR (sumStats + qtlDataset)", { - qd <- .js_makeQtlDataset() - expect_error( - pecotmr:::parseMethods( - methods = "susie", - sumStatsMethods = "susieInf", - qtlDatasetMethods = "susie", - data = qd, - caps = pecotmr:::.fineMappingMethodCapabilities, - multivariateMethods = c("mvsusie", "fsusie") - ), - "Use either" - ) - expect_error( - pecotmr:::parseMethods( - methods = NULL, - sumStatsMethods = "susie", - qtlDatasetMethods = NULL, - data = qd, - caps = pecotmr:::.fineMappingMethodCapabilities, - multivariateMethods = c("mvsusie", "fsusie") - ), - "must be given together" - ) - expect_error( - pecotmr:::parseMethods( - methods = NULL, - sumStatsMethods = NULL, - qtlDatasetMethods = NULL, - data = qd, - caps = pecotmr:::.fineMappingMethodCapabilities, - multivariateMethods = c("mvsusie", "fsusie") - ), - "Specify" - ) -}) - -test_that("parseMethods: rejects unknown tokens", { - qd <- .js_makeQtlDataset() - expect_error( - pecotmr:::parseMethods( - methods = "bogus", - data = qd, - caps = pecotmr:::.fineMappingMethodCapabilities, - multivariateMethods = c("mvsusie", "fsusie") - ), - "unknown method token" - ) -}) - -test_that("parseMethods: rejects multi-axis methods at per-context level", { - qd <- .js_makeQtlDataset(studyName = "A", contexts = c("brain", "liver")) - expect_error( - pecotmr:::parseMethods( - methods = list(A = list(brain = c("susie", "mvsusie"))), - data = qd, - caps = pecotmr:::.fineMappingMethodCapabilities, - multivariateMethods = c("mvsusie", "fsusie") - ), - "per-context" - ) -}) - -test_that("parseMethods: rejects multi-axis methods at per-trait level", { - qd <- .js_makeQtlDataset( - studyName = "A", - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) - expect_error( - pecotmr:::parseMethods( - methods = list( - A = list(brain = list(ENSG_A = c("susie", "mvsusie"))) - ), - data = qd, - caps = pecotmr:::.fineMappingMethodCapabilities, - multivariateMethods = c("mvsusie", "fsusie") - ), - "per-trait" - ) -}) - -test_that("parseMethods: a TWAS-only token (mrmash) is unknown to the fine-mapping grammar", { - # mr.mash is not in the fine-mapping capability table (it is TWAS-only), so it - # is rejected as an unknown fine-mapping token. - qd <- .js_makeQtlDataset() - expect_error( - pecotmr:::parseMethods( - methods = "mrmash", - data = qd, - caps = pecotmr:::.fineMappingMethodCapabilities, - multivariateMethods = c("mvsusie", "fsusie") - ), - "unknown method token" - ) -}) - -test_that("parseMethods: rejectedAtUser tokens are refused", { - qd <- .js_makeQtlDataset() - expect_error( - pecotmr:::parseMethods( - methods = "mvsusie", - data = qd, - caps = pecotmr:::.fineMappingMethodCapabilities, - multivariateMethods = c("mvsusie", "fsusie"), - rejectedAtUser = "mvsusie" - ), - "cannot be user-requested" - ) -}) - -test_that("parseMethods: accepts per-context univariate methods", { - qd <- .js_makeQtlDataset(studyName = "A", contexts = c("brain", "liver")) - out <- pecotmr:::parseMethods( - methods = list(A = list(brain = "susie", liver = "susieInf")), - data = qd, - caps = pecotmr:::.fineMappingMethodCapabilities, - multivariateMethods = c("mvsusie", "fsusie") - ) - expect_equal(out$shape, "primary") -}) - -test_that("parseMethods: validates per-(study, context, trait) leaf paths", { - qd <- .js_makeQtlDataset( - studyName = "A", - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) - expect_error( - pecotmr:::parseMethods( - methods = list(A = list(brain = list(BOGUS = "susie"))), - data = qd, - caps = pecotmr:::.fineMappingMethodCapabilities, - multivariateMethods = c("mvsusie", "fsusie") - ), - "unknown trait" - ) -}) - -# ----------------------------------------------------------------------------- -# validateMethodsVsJointSpec -# ----------------------------------------------------------------------------- - -test_that("validateMethodsVsJointSpec: per-study methods + jointCrossStudy errors", { - qd1 <- .js_makeQtlDataset(studyName = "A") - qd2 <- .js_makeQtlDataset(studyName = "B") - ss <- .js_makeQtlSumStats(studies = "C") - mt <- MultiStudyQtlDataset( - qtlDatasets = list(A = qd1, B = qd2), - sumStats = ss - ) - parsed <- pecotmr:::parseMethods( - methods = list(A = "susie", B = "susieInf"), - data = mt, - caps = pecotmr:::.fineMappingMethodCapabilities, - multivariateMethods = c("mvsusie", "fsusie") - ) - joints <- pecotmr:::parseJointSpecification("study", mt) - expect_error( - pecotmr:::validateMethodsVsJointSpec(parsed, joints), - "per-study" - ) -}) - -test_that("validateMethodsVsJointSpec: per-context methods + jointCrossContext errors", { - qd <- .js_makeQtlDataset(studyName = "A", contexts = c("brain", "liver")) - parsed <- pecotmr:::parseMethods( - methods = list(A = list(brain = "susie", liver = "susie")), - data = qd, - caps = pecotmr:::.fineMappingMethodCapabilities, - multivariateMethods = c("mvsusie", "fsusie") - ) - joints <- pecotmr:::parseJointSpecification("context", qd) - expect_error( - pecotmr:::validateMethodsVsJointSpec(parsed, joints), - "per-context" - ) -}) - -test_that("validateMethodsVsJointSpec: vector methods + any joint flag OK", { - qd <- .js_makeQtlDataset(studyName = "A", contexts = c("brain", "liver")) - parsed <- pecotmr:::parseMethods( - methods = c("susie", "mvsusie"), - data = qd, - caps = pecotmr:::.fineMappingMethodCapabilities, - multivariateMethods = c("mvsusie", "fsusie") - ) - joints <- pecotmr:::parseJointSpecification("context", qd) - expect_silent(pecotmr:::validateMethodsVsJointSpec(parsed, joints)) -}) - # ----------------------------------------------------------------------------- # Pipeline-level wiring: jointSpecification accepted on all three methods # ----------------------------------------------------------------------------- test_that("fineMappingPipeline(QtlDataset): trait-axis joint dispatcher is wired", { # Cross-trait dispatcher is now wired; calling it on a fake genotype - # handle errors when the genotype extractor tries to load the GDS file. + # handle errors when the genotype extractor tries to open its .pgen file. # The point of this test is to verify the dispatcher is invoked (not # the stub error), so we check that the error comes from the genotype # I/O layer rather than the jointSpec wiring. @@ -546,7 +351,7 @@ test_that("fineMappingPipeline(QtlDataset): trait-axis joint dispatcher is wired cisWindow = 1000L, jointSpecification = "trait" ), - "Can not open file|No such file" + "File does not exist" ) }) @@ -567,7 +372,7 @@ test_that("fineMappingPipeline(QtlDataset): composed joint dispatcher is wired", cisWindow = 1000L, jointSpecification = list(c("context", "trait")) ), - "Can not open file|No such file" + "File does not exist" ) }) @@ -606,7 +411,11 @@ test_that("fineMappingPipeline(QtlDataset): study-axis on individual data errors }) test_that("fineMappingPipeline(QtlDataset): NULL jointSpec is the default", { - qd <- .js_makeQtlDataset(studyName = "A", contexts = "brain", traits = "ENSG_A") + qd <- .js_makeQtlDataset( + studyName = "A", + contexts = "brain", + traits = "ENSG_A" + ) expect_silent( pecotmr:::parseJointSpecification(NULL, qd) ) @@ -638,7 +447,7 @@ test_that("twasWeightsPipeline(QtlDataset): cross-trait joint dispatcher is wire cisWindow = 1000L, jointSpecification = "trait" ), - "Can not open file|No such file" + "File does not exist" ) }) @@ -680,20 +489,6 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): method exists", { expect_true(existsMethod("twasWeightsPipeline", "MultiStudyQtlDataset")) }) -test_that("validateMethodsVsJointSpec: split-form methods skipped", { - qd <- .js_makeQtlDataset() - parsed <- pecotmr:::parseMethods( - methods = NULL, - sumStatsMethods = "susieInf", - qtlDatasetMethods = "susie", - data = qd, - caps = pecotmr:::.fineMappingMethodCapabilities, - multivariateMethods = c("mvsusie", "fsusie") - ) - joints <- pecotmr:::parseJointSpecification("context", qd) - expect_silent(pecotmr:::validateMethodsVsJointSpec(parsed, joints)) -}) - # ============================================================================ # Joint dispatchers (merged from former tests/testthat/test_jointDispatchers.R) # ============================================================================ @@ -715,8 +510,8 @@ context("joint dispatchers (fineMappingDispatcher / twasDispatcher)") .jd_makeHandle <- function(snp_n = 5L, n_samples = 30L) { new( "GenotypeHandle", - path = "/tmp/jd.gds", - format = "gds", + path = "/tmp/jd", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), @@ -805,7 +600,7 @@ context("joint dispatchers (fineMappingDispatcher / twasDispatcher)") trait = rows$trait, entry = map(seq_len(nrow(rows)), function(.) makeGr()), genome = "hg19", - ldSketch = .jd_makeHandle(), + ldReference = .jd_makeHandle(), qcInfo = list(step1 = "ok") ) } @@ -1408,7 +1203,10 @@ test_that(".sp* helpers: MultiStudy per-study context/trait routing", { expect_setequal(pecotmr:::.spListContexts(mt), c("brain", "DLPFC")) # all expect_equal(pecotmr:::.spListContexts(mt, "nope"), character(0)) expect_setequal(pecotmr:::.spListTraits(mt, studyName = "ssC"), "g3") # ss branch - expect_setequal(pecotmr:::.spListTraits(mt, studyName = "indA"), c("g1", "g2")) + expect_setequal( + pecotmr:::.spListTraits(mt, studyName = "indA"), + c("g1", "g2") + ) expect_equal(pecotmr:::.spListTraits(mt, studyName = "nope"), character(0)) # study = NULL aggregates ALL traits across individual + sumstats components # (regression guard: a present sumStats slot must not shadow the QtlDatasets). @@ -1421,7 +1219,11 @@ test_that(".spListTraits: study=NULL on a sumstats-free MultiStudy aggregates tr contexts = "brain", traits = c("g1", "g2") ) - qdB <- .js_makeQtlDataset(studyName = "indB", contexts = "liver", traits = "g3") + qdB <- .js_makeQtlDataset( + studyName = "indB", + contexts = "liver", + traits = "g3" + ) mt <- MultiStudyQtlDataset(qtlDatasets = list(indA = qdA, indB = qdB)) expect_setequal(pecotmr:::.spListTraits(mt), c("g1", "g2", "g3")) # aggregate }) @@ -1483,13 +1285,14 @@ test_that("parseContexts: malformed inputs error", { expect_error(pecotmr:::parseContexts(42, qd), "must be NULL") }) -test_that("parseContexts: vector form warns on contexts missing from a study", { +test_that("parseContexts: vector form refuses a context no study has", { + # With one study a missing context can only be a mistake, and across + # studies one that none of them has is the same: an error, not a warning. qd <- .js_makeQtlDataset(studyName = "S1", contexts = c("brain", "liver")) - expect_warning( - out <- pecotmr:::parseContexts(c("brain", "absent"), qd), - "missing requested context" + expect_error( + pecotmr:::parseContexts(c("brain", "absent"), qd), + "no study has: absent" ) - expect_equal(out$S1, "brain") }) test_that("parseTraitIds: malformed inputs error", { @@ -1529,108 +1332,6 @@ test_that("parseTraitIds: malformed inputs error", { # (The doubly-nested study->context success path is covered by the existing # "parseTraitIds: doubly-nested study->context validates per context" test.) -# ----------------------------------------------------------------------------- -# .spWalkMethods / parseMethods / validateMethodsVsJointSpec error branches -# ----------------------------------------------------------------------------- - -test_that(".spWalkMethods: structural errors via parseMethods", { - qd <- .js_makeQtlDataset(studyName = "S1", contexts = "brain", traits = "ENSG1") - caps <- list(lasso = list(multivariate = FALSE)) - walk <- function(m) { - pecotmr:::parseMethods( - m, - data = qd, - caps = caps, - multivariateMethods = character(0) - ) - } - expect_error(walk(list(S1 = 42)), "character vector or a named list") - expect_error( - walk(list(S1 = list(brain = list(ENSG1 = list(x = "lasso"))))), - "cannot nest below the trait level" - ) - expect_error(walk(list("lasso")), "non-empty names") # unnamed list node - expect_error(walk(list(S1 = list())), "non-empty names") # inner empty node - # A named-but-empty list reaches the dedicated "empty named list" guard. - expect_error( - pecotmr:::.spWalkMethods(setNames(list(), character(0))), - "empty named list" - ) -}) - -test_that("parseMethods: split-form and leaf validation errors", { - qd <- .js_makeQtlDataset(studyName = "S1", contexts = "brain", traits = "ENSG1") - caps <- list( - lasso = list(multivariate = FALSE), - mrmash = list(multivariate = TRUE) - ) - expect_error( - pecotmr:::parseMethods( - methods = NULL, - sumStatsMethods = character(0), - qtlDatasetMethods = "lasso", - data = qd, - caps = caps, - multivariateMethods = "mrmash" - ), - "Must have length >= 1" - ) - expect_error( - pecotmr:::parseMethods( - methods = NULL, - sumStatsMethods = "lasso", - qtlDatasetMethods = character(0), - data = qd, - caps = caps, - multivariateMethods = "mrmash" - ), - "Must have length >= 1" - ) - expect_error( - pecotmr:::parseMethods( - list(S1 = character(0)), - data = qd, - caps = caps, - multivariateMethods = "mrmash" - ), - "non-empty character vector" - ) - expect_error( - pecotmr:::parseMethods( - list(nope = "lasso"), - data = qd, - caps = caps, - multivariateMethods = "mrmash" - ), - "unknown study" - ) - expect_error( - pecotmr:::parseMethods( - list(S1 = list(absent = "lasso")), - data = qd, - caps = caps, - multivariateMethods = "mrmash" - ), - "unknown context" - ) -}) - -test_that("validateMethodsVsJointSpec: empty spec is a no-op; per-trait nesting + trait axis errors", { - expect_null(pecotmr:::validateMethodsVsJointSpec( - list(shape = "primary", methods = "lasso"), - list() - )) - parsed <- list(list(axes = "trait")) - methodsParsed <- list( - shape = "primary", - methods = list(S1 = list(brain = list(ENSG1 = "lasso"))) - ) - expect_error( - pecotmr:::validateMethodsVsJointSpec(methodsParsed, parsed), - "nests per-trait" - ) -}) - # ----------------------------------------------------------------------------- # .fmResolveSpecScope: scope$study / scope$context / scope$trait + filters # ----------------------------------------------------------------------------- @@ -1657,6 +1358,97 @@ test_that(".fmResolveSpecScope: scope + contexts + traitIds filters intersect", expect_equal(out2$traits$S1, "ENSG2") }) +test_that(".fmResolveSpecScope: a per-context traitId gives the union", { + qd <- .js_makeQtlDataset( + studyName = "S1", + contexts = c("brain", "liver"), + traits = c("ENSG1", "ENSG2") + ) + nested <- list(S1 = list(brain = "ENSG1", liver = "ENSG2")) + out <- pecotmr:::.fmResolveSpecScope( + list(scope = NULL), + qd, + traitIds = nested + ) + # A joint fit spans the study's contexts: it takes every trait selected + # in any of them, and the cell runner drops the pairs left out. + expect_setequal(out$traits$S1, c("ENSG1", "ENSG2")) + expect_identical(out$traitSelection, nested) + plain <- pecotmr:::.fmResolveSpecScope( + list(scope = NULL), + qd, + traitIds = list(S1 = "ENSG1") + ) + expect_null(plain$traitSelection) +}) + +test_that("a parsed selection is read per study and context", { + nested <- list(A = list(brain = "g1"), B = "g2") + expect_equal(pecotmr:::.selectedTraits(nested, "A", "brain"), "g1") + # Unnamed contexts and studies keep everything. + expect_null(pecotmr:::.selectedTraits(nested, "A", "liver")) + expect_null(pecotmr:::.selectedTraits(nested, "C", "brain")) + expect_equal(pecotmr:::.selectedTraits(nested, "B", "liver"), "g2") + expect_equal(pecotmr:::.selectedTraits("g3", "A", "brain"), "g3") + expect_true(pecotmr:::.traitSelectedAt("g9", NULL, "A", "brain")) + expect_false(pecotmr:::.traitSelectedAt("g2", nested, "A", "brain")) + # A study's traits across its contexts: the union, unless a context in + # play is not named, which keeps everything. + both <- list(A = list(brain = "g1", liver = c("g2", "g1"))) + expect_setequal( + pecotmr:::.selectedStudyTraits(both, "A", c("brain", "liver")), + c("g1", "g2") + ) + expect_null(pecotmr:::.selectedStudyTraits( + nested, + "A", + c("brain", "liver") + )) + expect_equal(pecotmr:::.selectedStudyTraits(nested, "A", "brain"), "g1") + expect_true(pecotmr:::.hasNestedTraitSelection(nested)) + expect_false(pecotmr:::.hasNestedTraitSelection(list(A = "g1"))) + expect_false(pecotmr:::.hasNestedTraitSelection("g1")) +}) + +test_that("each study's share of traitId parses back to the same selection", { + nested <- list(A = list(brain = "g1"), B = "g2") + expect_equal( + pecotmr:::.studyTraitIdArg(nested, "A"), + list(A = list(brain = "g1")) + ) + expect_equal(pecotmr:::.studyTraitIdArg(nested, "B"), "g2") + expect_null(pecotmr:::.studyTraitIdArg(nested, "C")) + expect_equal(pecotmr:::.studyTraitIdArg("g3", "A"), "g3") +}) + +test_that(".sumStatsRowsSelected applies study and per-context selections", { + rows <- data.frame( + study = c("A", "A", "B", "B"), + context = c("brain", "liver", "brain", "brain"), + trait = c("g1", "g1", "g1", "g2") + ) + expect_equal( + pecotmr:::.sumStatsRowsSelected( + rows, + list(A = "liver", B = "brain"), + NULL + ), + c(FALSE, TRUE, TRUE, TRUE) + ) + expect_equal( + pecotmr:::.sumStatsRowsSelected(rows, NULL, list(B = "g2")), + c(TRUE, TRUE, FALSE, TRUE) + ) + expect_equal( + pecotmr:::.sumStatsRowsSelected( + rows, + NULL, + list(A = list(liver = "g2")) + ), + c(TRUE, FALSE, TRUE, TRUE) + ) +}) + # ----------------------------------------------------------------------------- # .buildJointSumstatZMatrix: SNP-order mismatch error # ----------------------------------------------------------------------------- @@ -2056,21 +1848,16 @@ test_that(".twasDispatchJointSpecsQtlDataset: two region blocks are merged by ke ) } local_mocked_bindings( - .twasDispatchJointSpecsQtlDatasetOneRegion = function(...) { - mkRegionRes() - }, + .twasJointSpecRegion = function(...) mkRegionRes(), .package = "pecotmr" ) res <- pecotmr:::.twasDispatchJointSpecsQtlDataset( parsed, - data = NULL, - methods = "mrmash", + "mrmash", + marker = NULL, + ctx = list(xRegions = list(r1, r2)), contexts = NULL, - traitIds = NULL, - cisWindow = NULL, - weightsDataType = NULL, - verbose = 0, - xRegions = list(r1, r2) + traitIds = NULL ) expect_s4_class(res, "TwasWeights") expect_equal(nrow(res), 2L) # per-context, merged regions @@ -2106,7 +1893,7 @@ test_that(".fmDispatchJointSpecsMultiStudy: routes non-study specs to components trait = "t1", method = "mvsusie", entry = list(.js_fmEntry()), - ldSketch = .js_makeGenotypeHandle() + ldReference = .js_makeGenotypeHandle() ) local_mocked_bindings( .fmDispatchJointSpecsQtlDataset = function(...) qdRes, @@ -2115,17 +1902,19 @@ test_that(".fmDispatchJointSpecsMultiStudy: routes non-study specs to components ) out <- suppressMessages(pecotmr:::.fmDispatchJointSpecsMultiStudy( parsed, - mt, - methods = "mvsusie", - contexts = NULL, - traitIds = NULL, - cisWindow = NULL, - verbose = 1, - credibleSetParam = CredibleSetParam( - coverage = 0.95, - secondaryCoverage = 0.5, - signalCutoff = 0.1, - minAbsCorr = 0.5 + "mvsusie", + list(), + list( + data = mt, + verbose = 1, + xRegions = list(NULL), + genotypeFilterParam = GenotypeFilterParam(), + credibleSetParam = CredibleSetParam( + coverage = 0.95, + secondaryCoverage = 0.5, + signalCutoff = 0.1, + minAbsCorr = 0.5 + ) ) )) expect_s4_class(out, "QtlFineMappingResult") @@ -2148,18 +1937,9 @@ test_that(".fmDispatchJointSpecsMultiStudy: study spec with no sumStats slot mes expect_message( out <- pecotmr:::.fmDispatchJointSpecsMultiStudy( parsed, - mt, - methods = "mvsusie", - contexts = NULL, - traitIds = NULL, - cisWindow = NULL, - verbose = 1, - credibleSetParam = CredibleSetParam( - coverage = 0.95, - secondaryCoverage = 0.5, - signalCutoff = 0.1, - minAbsCorr = 0.5 - ) + "mvsusie", + list(), + list(data = mt, verbose = 1, xRegions = list(NULL)) ), "no sumStats slot" ) @@ -2197,22 +1977,18 @@ test_that(".twasDispatchJointSpecsMultiStudy: routes components + sumstats and r variantIds = "chr1:100:A:G", weights = 0.5 )), - ldSketch = .jd_makeHandle() + ldReference = .jd_makeHandle() ) local_mocked_bindings( - .twasDispatchJointSpecsQtlDataset = function(...) qdRes, + .twasStudyJointResult = function(...) qdRes, .twasDispatchJointSpecsQtlSumStats = function(...) ssRes, .package = "pecotmr" ) out <- suppressMessages(pecotmr:::.twasDispatchJointSpecsMultiStudy( parsed, - mt, - methods = "mrmash", - contexts = NULL, - traitIds = NULL, - cisWindow = NULL, - weightsDataType = NULL, - verbose = 1 + "mrmash", + "mrmash", + list(data = mt, verbose = 1) )) expect_s4_class(out, "TwasWeights") expect_equal(nrow(out), 2L) @@ -2234,13 +2010,9 @@ test_that(".twasDispatchJointSpecsMultiStudy: study spec, no sumStats -> message expect_message( out <- pecotmr:::.twasDispatchJointSpecsMultiStudy( parsed, - mt, - methods = "mrmash", - contexts = NULL, - traitIds = NULL, - cisWindow = NULL, - weightsDataType = NULL, - verbose = 1 + "mrmash", + "mrmash", + list(data = mt, verbose = 1) ), "no sumStats slot" ) @@ -2263,14 +2035,6 @@ test_that(".sp* QtlDataset: mismatched study / absent context return empty", { expect_equal(pecotmr:::.spListTraits(qd, context = "nope"), character(0)) # 98 }) -test_that("validateMethodsVsJointSpec: per-study methods with a context joint passes", { - mp <- list(shape = "primary", methods = list(S1 = "lasso")) # depth 1 - expect_null(pecotmr:::validateMethodsVsJointSpec( - mp, - list(list(axes = "context")) - )) # 542 -}) - test_that(".buildIndividualCrossTraitXy: disjoint X/Y samples skip the context", { se <- .js_makeSe(traits = c("g1", "g2"), samples = paste0("s", 1:6)) local_mocked_bindings( @@ -2483,25 +2247,15 @@ test_that(".fmDispatchJointSpecsQtlDataset: two region blocks are merged", { ) } local_mocked_bindings( - .fmDispatchJointSpecsQtlDatasetOneRegion = function(...) mkRes(), + .fmDispatchJointSpecRegion = function(...) mkRes(), .fmMergeEntries = function(entries) entries[[1L]], .package = "pecotmr" ) res <- pecotmr:::.fmDispatchJointSpecsQtlDataset( list(list(axes = "context", scope = NULL)), - qd, - methods = "mvsusie", - contexts = NULL, - traitIds = NULL, - cisWindow = NULL, - verbose = 0, - xRegions = list(r1, r2), - credibleSetParam = CredibleSetParam( - coverage = 0.95, - secondaryCoverage = 0.5, - signalCutoff = 0.1, - minAbsCorr = 0.5 - ) + "mvsusie", + list(), + list(data = qd, verbose = 0, xRegions = list(r1, r2)) ) expect_s4_class(res, "QtlFineMappingResult") expect_equal(nrow(res), 2L) # 907-910 @@ -2521,43 +2275,25 @@ test_that(".fmDispatchJointSpecsQtlDataset: a single region returns directly; al entry = list(.js_fmEntry("chr1:100:A:G")) ) local_mocked_bindings( - .fmDispatchJointSpecsQtlDatasetOneRegion = function(...) res1, + .fmDispatchJointSpecRegion = function(...) res1, .package = "pecotmr" ) out <- pecotmr:::.fmDispatchJointSpecsQtlDataset( list(list(axes = "context", scope = NULL)), - qd, - methods = "mvsusie", - contexts = NULL, - traitIds = NULL, - cisWindow = 1000L, - verbose = 0, - credibleSetParam = CredibleSetParam( - coverage = 0.95, - secondaryCoverage = 0.5, - signalCutoff = 0.1, - minAbsCorr = 0.5 - ) + "mvsusie", + list(), + list(data = qd, verbose = 0, cisWindow = 1000L, xRegions = list(NULL)) ) expect_identical(out, res1) # length-1 short-circuit (909) local_mocked_bindings( - .fmDispatchJointSpecsQtlDatasetOneRegion = function(...) NULL, + .fmDispatchJointSpecRegion = function(...) NULL, .package = "pecotmr" ) expect_null(pecotmr:::.fmDispatchJointSpecsQtlDataset( list(list(axes = "context", scope = NULL)), - qd, - methods = "mvsusie", - contexts = NULL, - traitIds = NULL, - cisWindow = 1000L, - verbose = 0, - credibleSetParam = CredibleSetParam( - coverage = 0.95, - secondaryCoverage = 0.5, - signalCutoff = 0.1, - minAbsCorr = 0.5 - ) + "mvsusie", + list(), + list(data = qd, verbose = 0, cisWindow = 1000L, xRegions = list(NULL)) )) # all-NULL (908) }) @@ -2586,6 +2322,31 @@ test_that(".twasMergeResultsByKey: a key absent from a later region contributes expect_equal(nrow(out), 2L) # 1063 else-branch }) +test_that(".twasMergedEntryAt concatenates one key's entry across regions", { + data(twasWeightsExample) + tw <- twasWeightsExample + keys <- pecotmr:::.mergeResultKeyOf(tw) + m <- pecotmr:::.twasMergedEntryAt(1L, list(tw, tw), keys, c("rA", "rB")) + expect_s4_class(m, "TwasWeightsRow") + expect_equal(names(methodFits(m)), c("rA", "rB")) + # Same table twice: the merged entry carries both regions' variants. + one <- pecotmr:::.twasMergedEntryAt(1L, list(tw), keys, "rA") + expect_equal( + length(pecotmr:::.twrPartsVariantIds(m)), + 2L * length(pecotmr:::.twrPartsVariantIds(one)) + ) +}) + +test_that(".mergeEntryForKey gives NULL for a region lacking the tuple", { + # NULL, not an empty row: a region that never fitted the tuple must not + # dilute the merged weights with zeros. + data(twasWeightsExample) + tw <- twasWeightsExample + key <- pecotmr:::.mergeResultKeyOf(tw)[[1L]] + expect_s4_class(pecotmr:::.mergeEntryForKey(tw, key), "TwasWeightsRow") + expect_null(pecotmr:::.mergeEntryForKey(tw, "nope\rx\ry\rz")) +}) + # --------------------------------------------------------------------------- # .buildJointSumstatZMatrix: LD-panel cutoffs on the joint RSS path. @@ -2610,7 +2371,7 @@ test_that(".twasMergeResultsByKey: a key absent from a later region contributes seq_len(nrow(ss)), as.character(ss$context), "probe", - ldSketch = ldSketch(ss), + ldReference = ldReference(ss), cutoffs = .panelCutoffs(PanelFilterParam(...)) )) } @@ -2640,7 +2401,7 @@ test_that(".buildJointSumstatZMatrix agrees with .panelVariantFilter", { expect_equal( length(.bjz_build(ss, mafCutoff = cut)$variantIds), length(.panelVariantFilter( - ldSketch(ss), + ldReference(ss), ids, PanelFilterParam(mafCutoff = cut) )), @@ -2671,7 +2432,7 @@ test_that(".buildJointSumstatZMatrix honours a missingness cutoff", { }) test_that(".fmScopeUserLimit answers NULL for an absent limit", { - expect_null(pecotmr:::.fmScopeUserLimit(NULL, "s1", TRUE)) + expect_null(pecotmr:::.fmScopeUserLimit(NULL, "s1")) }) test_that(".msFoldStudyResults answers NULL when every fold is empty", { diff --git a/tests/testthat/test_ld.R b/tests/testthat/test_ld.R index 898c44c21..1ab2469e5 100644 --- a/tests/testthat/test_ld.R +++ b/tests/testthat/test_ld.R @@ -105,454 +105,8 @@ generateMultiBlockData <- function() { gr } - -test_that("Check that we correctly retrieve the names from the matrix", { - data <- generateDummyData() - region <- data$region - LD_meta_file_path <- gsub( - "//", - "/", - tempfile(pattern = "ld_meta_file", tmpdir = tempdir(), fileext = ".RDS") - ) - write_delim(data$meta, LD_meta_file_path, delim = "\t") - res <- loadLdMatrix(LD_meta_file_path, region) - variants <- unlist( - c( - "chr1:1000:A:G", - "chr1:1040:A:G", - "chr1:1080:A:G", - "chr1:1120:A:G", - "chr1:1160:A:G" - ) - ) - expect_equal( - unlist(variantIds(res)), - variants - ) - file.remove(LD_meta_file_path) -}) - -test_that("Check that the LD block contains the correct information", { - data <- generateDummyData() - region <- data$region - LD_meta_file_path <- gsub( - "//", - "/", - tempfile(pattern = "ld_meta_file", tmpdir = tempdir(), fileext = ".RDS") - ) - write_delim(data$meta, LD_meta_file_path, delim = "\t") - res <- loadLdMatrix(LD_meta_file_path, region) - # Variant names - variants <- unlist( - c( - "chr1:1000:A:G", - "chr1:1040:A:G", - "chr1:1080:A:G", - "chr1:1120:A:G", - "chr1:1160:A:G" - ) - ) - # Check LD Block 1 - ld_block_one <- ldMatrix(res) - ld_block_one_original <- as.matrix( - read_delim( - "test_data/LD_block_1.chr1_1000_1200.float16.txt.xz", - delim = " ", - col_names = F - ) - ) - rownames(ld_block_one_original) <- colnames( - ld_block_one_original - ) <- variants - expect_equal(ld_block_one, ld_block_one_original) - file.remove(LD_meta_file_path) -}) - # ---- partitionLdMatrix ---- -test_that("partitionLdMatrix correctly partitions a single block", { - data <- generateDummyData() - region <- data$region - LD_meta_file_path <- gsub( - "//", - "/", - tempfile(pattern = "ld_meta_file", tmpdir = tempdir(), fileext = ".RDS") - ) - write_delim(data$meta, LD_meta_file_path, delim = "\t") - - # Load the LD matrix first - ld_data <- loadLdMatrix(LD_meta_file_path, region) - - # Now partition the matrix - partitioned <- partitionLdMatrix(ld_data) - - # Expectations for single block case - expect_equal(length(partitioned$ldMatrices), 1) - expect_equal( - nrow(partitioned$variantIndices), - length(variantIds(ld_data)) - ) - expect_equal(unique(partitioned$variantIndices$blockId), 1) - expect_identical( - rownames(partitioned$ldMatrices[[1]]), - variantIds(ld_data) - ) - expect_identical( - colnames(partitioned$ldMatrices[[1]]), - variantIds(ld_data) - ) - - file.remove(LD_meta_file_path) -}) - -test_that("partitionLdMatrix correctly partitions multiple blocks", { - data <- generateMultiBlockData() - region <- data$region - LD_meta_file_path <- gsub( - "//", - "/", - tempfile(pattern = "ld_meta_file", tmpdir = tempdir(), fileext = ".RDS") - ) - write_delim(data$meta, LD_meta_file_path, delim = "\t") - - # Load the LD matrix that spans multiple blocks - ld_data <- loadLdMatrix(LD_meta_file_path, region) - - # Now partition the matrix without merging blocks - partitioned <- partitionLdMatrix(ld_data, mergeSmallBlocks = FALSE) - - # Check if we have the correct number of blocks - # Should have block 1 (1000-1200), block 2 (1200-1400), and block 3 (1400-1600) - expected_block_count <- 3 - expect_equal(length(partitioned$ldMatrices), expected_block_count) - - # Check if all variants are assigned to blocks - expect_equal( - nrow(partitioned$variantIndices), - length(variantIds(ld_data)) - ) - - # Check if block IDs are correct - expect_setequal( - unique(partitioned$variantIndices$blockId), - seq_len(expected_block_count) - ) - - file.remove(LD_meta_file_path) -}) - -test_that("partitionLdMatrix properly merges small blocks", { - data <- generateMultiBlockData() - region <- data$region - LD_meta_file_path <- gsub( - "//", - "/", - tempfile(pattern = "ld_meta_file", tmpdir = tempdir(), fileext = ".RDS") - ) - write_delim(data$meta, LD_meta_file_path, delim = "\t") - - # Load the LD matrix that spans multiple blocks - ld_data <- loadLdMatrix(LD_meta_file_path, region) - - # Set min_merged_block_size high enough to force merging - # Each test block likely has 5 variants (based on the existing test) - min_block_size <- 10 - - # Now partition the matrix with block merging - partitioned <- partitionLdMatrix( - ld_data, - mergeSmallBlocks = TRUE, - minMergedBlockSize = min_block_size - ) - - # We expect fewer blocks after merging - expect_lt(length(partitioned$ldMatrices), 3) - - # Check if all variants are still assigned to blocks - expect_equal( - nrow(partitioned$variantIndices), - length(variantIds(ld_data)) - ) - - # Check if merged blocks are larger than min_block_size - block_sizes <- map_int(partitioned$ldMatrices, nrow) - expect_true(all( - block_sizes >= min_block_size | - block_sizes == length(variantIds(ld_data)) - )) - - file.remove(LD_meta_file_path) -}) - -test_that("partitionLdMatrix respects max_merged_block_size", { - data <- generateMultiBlockData() - region <- data$region - LD_meta_file_path <- gsub( - "//", - "/", - tempfile(pattern = "ld_meta_file", tmpdir = tempdir(), fileext = ".RDS") - ) - write_delim(data$meta, LD_meta_file_path, delim = "\t") - - # Load the LD matrix that spans multiple blocks - ld_data <- loadLdMatrix(LD_meta_file_path, region) - - # Set max_merged_block_size to a small value to prevent merging all blocks - # Each test block likely has 5 variants (based on the existing test) - max_block_size <- 8 - - # Now partition the matrix with restricted block size - partitioned <- partitionLdMatrix( - ld_data, - mergeSmallBlocks = TRUE, - minMergedBlockSize = 2, - maxMergedBlockSize = max_block_size - ) - - # Check if no block exceeds max_block_size - block_sizes <- map_int(partitioned$ldMatrices, nrow) - expect_true(all(block_sizes <= max_block_size)) - - file.remove(LD_meta_file_path) -}) - -test_that("partitionLdMatrix handles empty matrix gracefully", { - # A plain list (legacy format) is no longer accepted; the S4 check fires first. - empty_ld_data <- list( - ldMatrix = matrix(0, 0, 0), - ldVariants = character(0), - blockMetadata = data.frame( - blockId = integer(0), - chrom = character(0), - size = integer(0), - startIdx = integer(0), - endIdx = integer(0) - ) - ) - - # Expect the S4 type-check error - expect_error( - partitionLdMatrix(empty_ld_data), - "Assertion on 'ldData'.*Must inherit from class 'LdData'" - ) -}) - -test_that("partitionLdMatrix validates block structure properly", { - data <- generateMultiBlockData() - region <- data$region - LD_meta_file_path <- gsub( - "//", - "/", - tempfile(pattern = "ld_meta_file", tmpdir = tempdir(), fileext = ".RDS") - ) - write_delim(data$meta, LD_meta_file_path, delim = "\t") - - # Load the LD matrix that spans multiple blocks - ld_data <- loadLdMatrix(LD_meta_file_path, region) - - # Create an invalid block structure by modifying blockMetadata - bm <- blockMetadata(ld_data) - vids <- variantIds(ld_data) - ldmat <- ldMatrix(ld_data) - - # Assuming we have at least 2 blocks: - if (length(bm) >= 2) { - # Create overlapping blocks with invalid start/end indices - bm$startIdx[2] <- bm$startIdx[1] - bm$endIdx[1] <- bm$endIdx[2] - - # Introduce non-zero elements between blocks to trigger validation error - if (length(vids) >= 2) { - idx1 <- bm$startIdx[1] - idx2 <- bm$startIdx[2] + 1 - if (idx1 <= length(vids) && idx2 <= length(vids)) { - var1 <- vids[idx1] - var2 <- vids[idx2] - ldmat[var1, var2] <- 0.5 - } - } - - # Rebuild LdData with modified matrix and block metadata - invalid_ld_data <- new( - "LdData", - variantInfo(ld_data), - correlation = ldmat, - genotypeHandle = NULL, - snpIdx = snpIdx(ld_data), - blockMetadata = bm - ) - - # Expect an error for invalid block structure - expect_error( - partitionLdMatrix(invalid_ld_data), - "Matrix lacks expected block structure" - ) - } - - file.remove(LD_meta_file_path) -}) - -test_that("partitionLdMatrix properly maps variants to blocks", { - data <- generateMultiBlockData() - region <- data$region - LD_meta_file_path <- gsub( - "//", - "/", - tempfile(pattern = "ld_meta_file", tmpdir = tempdir(), fileext = ".RDS") - ) - write_delim(data$meta, LD_meta_file_path, delim = "\t") - - # Load the LD matrix - ld_data <- loadLdMatrix(LD_meta_file_path, region) - - # Partition without merging - partitioned <- partitionLdMatrix(ld_data, mergeSmallBlocks = FALSE) - - # Check that each variant is mapped to the correct block - for (i in seq_along(partitioned$ldMatrices)) { - # Get variants in this block matrix - block_variants <- rownames(partitioned$ldMatrices[[i]]) - - # Find these variants in the variantIndices dataframe - variant_block_ids <- partitioned$variantIndices$blockId[ - match(block_variants, partitioned$variantIndices$variant_id) - ] - - # All variants should be mapped to this block - expect_true(all(variant_block_ids == i)) - } - - file.remove(LD_meta_file_path) -}) - -test_that("partitionLdMatrix handles row/column name mismatches", { - data <- generateDummyData() - region <- data$region - LD_meta_file_path <- gsub( - "//", - "/", - tempfile(pattern = "ld_meta_file", tmpdir = tempdir(), fileext = ".RDS") - ) - write_delim(data$meta, LD_meta_file_path, delim = "\t") - - # Load the LD matrix - ld_data <- loadLdMatrix(LD_meta_file_path, region) - - # Create an LdData with mismatched rownames and colnames on the correlation matrix - ldmat <- ldMatrix(ld_data) - vids <- variantIds(ld_data) - rownames(ldmat) <- NULL - colnames(ldmat) <- NULL - mismatched_ld_data <- LdData( - correlation = ldmat, - variants = variantInfo(ld_data), - blockMetadata = blockMetadata(ld_data) - ) - - # Should not error and should fix the names - partitioned <- partitionLdMatrix(mismatched_ld_data) - - # Check if names are fixed - expect_identical( - rownames(partitioned$ldMatrices[[1]]), - variantIds(ld_data) - ) - expect_identical( - colnames(partitioned$ldMatrices[[1]]), - variantIds(ld_data) - ) - - file.remove(LD_meta_file_path) -}) - -test_that("partitionLdMatrix correctly extracts blocks based on metadata", { - data <- generateMultiBlockData() - region <- data$region - LD_meta_file_path <- gsub( - "//", - "/", - tempfile(pattern = "ld_meta_file", tmpdir = tempdir(), fileext = ".RDS") - ) - write_delim(data$meta, LD_meta_file_path, delim = "\t") - - # Load the LD matrix - ld_data <- loadLdMatrix(LD_meta_file_path, region) - - # Partition without merging - partitioned <- partitionLdMatrix(ld_data, mergeSmallBlocks = FALSE) - - # For each block, check if the extracted matrix matches the expected submatrix - ld_variants <- variantIds(ld_data) - ld_matrix <- ldMatrix(ld_data) - for (i in seq_along(partitioned$ldMatrices)) { - block_info <- partitioned$blockMetadata[i, ] - startIdx <- block_info$startIdx - endIdx <- block_info$endIdx - - # Skip if indices are invalid - if ( - startIdx > length(ld_variants) || - endIdx > length(ld_variants) || - endIdx < startIdx - ) { - next - } - - # Get variants for this block - block_variants <- ld_variants[startIdx:endIdx] - - # Extract expected submatrix - expected_submatrix <- ld_matrix[ - block_variants, - block_variants, - drop = FALSE - ] - - # Compare with actual block matrix - expect_equal(partitioned$ldMatrices[[i]], expected_submatrix) - } - - file.remove(LD_meta_file_path) -}) - -test_that("partitionLdMatrix partitions correctly with synthetic data", { - mat <- matrix(0, 6, 6) - mat[1:3, 1:3] <- 0.5 - mat[4:6, 4:6] <- 0.5 - diag(mat) <- 1 - variant_ids <- c( - "chr1:100:A:G", - "chr1:200:C:T", - "chr1:300:G:A", - "chr1:400:T:C", - "chr1:500:A:G", - "chr1:600:C:T" - ) - rownames(mat) <- colnames(mat) <- variant_ids - - bm <- data.frame( - blockId = c(1L, 2L), - chrom = c("1", "1"), - blockStart = c(100L, 400L), - blockEnd = c(300L, 600L), - size = c(3L, 3L), - startIdx = c(1L, 4L), - endIdx = c(3L, 6L), - stringsAsFactors = FALSE - ) - - ld_data <- makeTestLdData(variant_ids, R = mat, blockMetadata = bm) - - result <- pecotmr:::partitionLdMatrix(ld_data, mergeSmallBlocks = FALSE) - - expect_type(result, "list") - expect_true("ldMatrices" %in% names(result)) - expect_true("variantIndices" %in% names(result)) - expect_length(result$ldMatrices, 2) - expect_equal(nrow(result$ldMatrices[[1]]), 3) - expect_equal(nrow(result$ldMatrices[[2]]), 3) -}) - # ---- orderDedupRegions ---- test_that("orderDedupRegions removes duplicate regions", { @@ -695,493 +249,16 @@ test_that("extractFilePaths errors on missing column", { # ---- partitionLdMatrix: different chromosomes ---- -test_that("partitionLdMatrix handles blocks with different chromosomes", { - # Create test data with blocks on different chromosomes - test_matrix <- matrix(0, 4, 4) - diag(test_matrix) <- 1 # Set diagonal to 1 - variant_ids <- c( - "chr1:100:A:G", - "chr1:200:C:T", - "chr2:100:G:A", - "chr2:200:T:C" - ) - rownames(test_matrix) <- colnames(test_matrix) <- variant_ids - - blockMetadata <- data.frame( - blockId = c(1L, 2L), - chrom = c("1", "2"), - blockStart = c(100L, 100L), - blockEnd = c(200L, 200L), - size = c(2L, 2L), - startIdx = c(1L, 3L), - endIdx = c(2L, 4L), - stringsAsFactors = FALSE - ) - - test_ld_data <- makeTestLdData( - variant_ids, - R = test_matrix, - blockMetadata = blockMetadata - ) - - # Partition the matrix - partitioned <- partitionLdMatrix(test_ld_data) - - # Should not merge blocks from different chromosomes - expect_equal(length(partitioned$ldMatrices), 2) - - # Each block should have the correct variants - expect_equal( - rownames(partitioned$ldMatrices[[1]]), - c("chr1:100:A:G", "chr1:200:C:T") - ) - expect_equal( - rownames(partitioned$ldMatrices[[2]]), - c("chr2:100:G:A", "chr2:200:T:C") - ) -}) - -test_that("partitionLdMatrix works with edge case block structures", { - # Test case: One large block and several tiny blocks that need merging - large_block_size <- 15 - small_block_size <- 2 - - # Create a matrix with blocks of varying sizes - n_variants <- large_block_size + small_block_size * 3 - test_matrix <- matrix(0, n_variants, n_variants) - # Set diagonal to 1 - diag(test_matrix) <- 1 - - # Generate variant names in chr:pos:A2:A1 format - variantNames <- paste0("chr1:", 100:(100 + n_variants - 1), ":A:G") - rownames(test_matrix) <- colnames(test_matrix) <- variantNames - - # Create block metadata - blockMetadata <- data.frame( - blockId = 1:4, - chrom = rep("1", 4), - blockStart = c( - 100L, - as.integer(100 + large_block_size), - as.integer(100 + large_block_size + small_block_size), - as.integer(100 + large_block_size + small_block_size * 2) - ), - blockEnd = c( - as.integer(100 + large_block_size - 1), - as.integer(100 + large_block_size + small_block_size - 1), - as.integer(100 + large_block_size + small_block_size * 2 - 1), - as.integer(100 + n_variants - 1) - ), - size = c( - large_block_size, - small_block_size, - small_block_size, - small_block_size - ), - startIdx = c( - 1L, - as.integer(large_block_size + 1), - as.integer(large_block_size + small_block_size + 1), - as.integer(large_block_size + small_block_size * 2 + 1) - ), - endIdx = c( - as.integer(large_block_size), - as.integer(large_block_size + small_block_size), - as.integer(large_block_size + small_block_size * 2), - as.integer(n_variants) - ), - stringsAsFactors = FALSE - ) - - test_ld_data <- makeTestLdData( - variantNames, - R = test_matrix, - blockMetadata = blockMetadata - ) - - # Set minimum block size to force merging of small blocks - min_merged_size <- small_block_size + 1 - - # Partition with merging - partitioned <- partitionLdMatrix( - test_ld_data, - mergeSmallBlocks = TRUE, - minMergedBlockSize = min_merged_size - ) - - # Should merge the small blocks but leave the large block alone - expect_lt(length(partitioned$ldMatrices), 4) - expect_gt(length(partitioned$ldMatrices), 1) - - # First block should still be large_block_size - expect_equal(nrow(partitioned$ldMatrices[[1]]), large_block_size) -}) - # ---- extractLdForRegion ---- -test_that("extractLdForRegion extracts correct region", { - # Create mock LD matrix and variants - ld_variants <- data.frame( - chrom = c(1, 1, 1, 1), - variants = c("1:100:A:G", "1:200:C:T", "1:300:G:A", "1:400:T:C"), - GD = NA, - pos = c(100, 200, 300, 400), - A1 = c("A", "C", "G", "T"), - A2 = c("G", "T", "A", "C") - ) - - ld_matrix <- matrix(0, 4, 4) - diag(ld_matrix) <- 1 - rownames(ld_matrix) <- colnames(ld_matrix) <- ld_variants$variants - - # Define a region that should include the middle two variants - region <- data.frame( - chrom = 1, - start = 180, - end = 320 - ) - - result <- extractLdForRegion(ld_matrix, ld_variants, region, NULL) - - # Should have extracted only the relevant variants - expect_equal(nrow(result$extractedLdVariants), 2) - expect_equal( - result$extractedLdVariants$variants, - c("1:200:C:T", "1:300:G:A") - ) - - # Matrix should be 2x2 with the correct row/column names - expect_equal(dim(result$extractedLdMatrix), c(2, 2)) - expect_equal( - rownames(result$extractedLdMatrix), - c("1:200:C:T", "1:300:G:A") - ) -}) - -test_that("extractLdForRegion works with extract_coordinates", { - # Create mock LD matrix and variants - ld_variants <- data.frame( - chrom = c(1, 1, 1, 1), - variants = c("1:100:A:G", "1:200:C:T", "1:300:G:A", "1:400:T:C"), - GD = NA, - pos = c(100, 200, 300, 400), - A1 = c("A", "C", "G", "T"), - A2 = c("G", "T", "A", "C") - ) - - ld_matrix <- matrix(0, 4, 4) - diag(ld_matrix) <- 1 - rownames(ld_matrix) <- colnames(ld_matrix) <- ld_variants$variants - - # Define a region that should include all variants - region <- data.frame( - chrom = 1, - start = 50, - end = 450 - ) - - # Define specific coordinates to extract - extract_coordinates <- data.frame( - chrom = c(1, 1), - pos = c(100, 300) - ) - - result <- extractLdForRegion( - ld_matrix, - ld_variants, - region, - extract_coordinates - ) - - # Should have extracted only the specified coordinates - expect_equal(nrow(result$extractedLdVariants), 2) - expect_equal( - result$extractedLdVariants$variants, - c("1:100:A:G", "1:300:G:A") - ) - - # Matrix should be 2x2 with the correct row/column names - expect_equal(dim(result$extractedLdMatrix), c(2, 2)) - expect_equal( - rownames(result$extractedLdMatrix), - c("1:100:A:G", "1:300:G:A") - ) -}) - # ---- createLdMatrix ---- -test_that("createLdMatrix correctly combines matrices with overlapping variants", { - # Create two simple LD matrices with some overlapping variants - matrix1 <- matrix(c(1, 0.5, 0.5, 1), 2, 2) - rownames(matrix1) <- colnames(matrix1) <- c("1:100:A:G", "1:200:C:T") - - matrix2 <- matrix(c(1, 0.3, 0.3, 1), 2, 2) - rownames(matrix2) <- colnames(matrix2) <- c("1:200:C:T", "1:300:G:A") - - # Create variants lists - variants1 <- data.frame(variants = c("1:100:A:G", "1:200:C:T")) - variants2 <- data.frame(variants = c("1:200:C:T", "1:300:G:A")) - - # Combine matrices - combined <- createLdMatrix( - ldMatrices = list(matrix1, matrix2), - variants = list(variants1, variants2) - ) - - # Should have created a 3x3 matrix with all unique variants - expect_equal(dim(combined), c(3, 3)) - expect_equal(rownames(combined), c("1:100:A:G", "1:200:C:T", "1:300:G:A")) - - # Check that values from original matrices are preserved - expect_equal(combined["1:100:A:G", "1:200:C:T"], 0.5) - expect_equal(combined["1:200:C:T", "1:300:G:A"], 0.3) - - # Check diagonal values are 1 - expect_equal(combined[1, 1], 1) - expect_equal(combined[2, 2], 1) - expect_equal(combined[3, 3], 1) -}) - -test_that("createLdMatrix merges non-overlapping blocks", { - m1 <- matrix( - c(1, 0.5, 0.5, 1), - 2, - 2, - dimnames = list( - c("chr1:100:A:G", "chr1:200:A:G"), - c("chr1:100:A:G", "chr1:200:A:G") - ) - ) - m2 <- matrix( - c(1, 0.3, 0.3, 1), - 2, - 2, - dimnames = list( - c("chr1:300:A:G", "chr1:400:A:G"), - c("chr1:300:A:G", "chr1:400:A:G") - ) - ) - - variants <- list( - data.frame(variants = c("chr1:100:A:G", "chr1:200:A:G")), - data.frame(variants = c("chr1:300:A:G", "chr1:400:A:G")) - ) - result <- pecotmr:::createLdMatrix(list(m1, m2), variants) - - expect_equal(nrow(result), 4) - expect_equal(ncol(result), 4) - expect_equal(result["chr1:100:A:G", "chr1:200:A:G"], 0.5) - expect_equal(result["chr1:300:A:G", "chr1:400:A:G"], 0.3) - # Cross-block should be 0 - expect_equal(result["chr1:100:A:G", "chr1:300:A:G"], 0) -}) - -test_that("createLdMatrix handles overlapping boundary variant", { - m1 <- matrix( - c(1, 0.5, 0.5, 1), - 2, - 2, - dimnames = list( - c("chr1:100:A:G", "chr1:200:A:G"), - c("chr1:100:A:G", "chr1:200:A:G") - ) - ) - m2 <- matrix( - c(1, 0.3, 0.3, 1), - 2, - 2, - dimnames = list( - c("chr1:200:A:G", "chr1:300:A:G"), - c("chr1:200:A:G", "chr1:300:A:G") - ) - ) - - variants <- list( - data.frame(variants = c("chr1:100:A:G", "chr1:200:A:G")), - data.frame(variants = c("chr1:200:A:G", "chr1:300:A:G")) - ) - result <- pecotmr:::createLdMatrix(list(m1, m2), variants) - - # v2 is shared, so total should be 3 variants - expect_equal(nrow(result), 3) - expect_equal(ncol(result), 3) -}) - # ---- validateBlockStructure ---- -test_that("validateBlockStructure passes for proper block structure", { - mat <- matrix(0, 6, 6) - mat[1:3, 1:3] <- 0.5 - mat[4:6, 4:6] <- 0.5 - diag(mat) <- 1 - - variant_ids <- sprintf("chr1:%d:A:G", 100L * (1:6)) - rownames(mat) <- colnames(mat) <- variant_ids - - block_meta <- data.frame( - blockId = c(1, 2), - chrom = c("1", "1"), - size = c(3, 3), - startIdx = c(1, 4), - endIdx = c(3, 6) - ) - - expect_silent(pecotmr:::validateBlockStructure( - mat, - .ld_bmGr(block_meta), - variant_ids - )) -}) - -test_that("validateBlockStructure errors on non-block structure", { - mat <- matrix(0.5, 4, 4) - diag(mat) <- 1 - - variant_ids <- sprintf("chr1:%d:A:G", 100L * (1:4)) - rownames(mat) <- colnames(mat) <- variant_ids - - block_meta <- data.frame( - blockId = c(1, 2), - chrom = c("1", "1"), - size = c(2, 2), - startIdx = c(1, 3), - endIdx = c(2, 4) - ) - - expect_error( - pecotmr:::validateBlockStructure( - mat, - .ld_bmGr(block_meta), - variant_ids - ), - "Matrix lacks expected block structure" - ) -}) - # ---- mergeBlocks ---- -test_that("mergeBlocks properly handles blocks at chromosome boundaries", { - # Create test data with small blocks at chromosome boundaries - test_matrix <- matrix(0, 6, 6) - diag(test_matrix) <- 1 - variantNames <- c( - "chr1:900:A:G", - "chr1:950:C:T", - "chr2:100:G:A", - "chr2:150:T:C", - "chr3:100:A:G", - "chr3:150:C:T" - ) - rownames(test_matrix) <- colnames(test_matrix) <- variantNames - - # Create block metadata with small blocks at chromosome boundaries - blockMetadata <- data.frame( - blockId = c(1L, 2L, 3L), - chrom = c("1", "2", "3"), - blockStart = c(900L, 100L, 100L), - blockEnd = c(950L, 150L, 150L), - size = c(2L, 2L, 2L), - startIdx = c(1L, 3L, 5L), - endIdx = c(2L, 4L, 6L), - stringsAsFactors = FALSE - ) - - test_ld_data <- makeTestLdData( - variantNames, - R = test_matrix, - blockMetadata = blockMetadata - ) - - # Set min block size to force merging attempts - min_block_size <- 3 - - # Partition with merging - partitioned <- partitionLdMatrix( - test_ld_data, - mergeSmallBlocks = TRUE, - minMergedBlockSize = min_block_size - ) - - # Should not merge blocks across chromosome boundaries - expect_equal(length(partitioned$ldMatrices), 3) - - # Each block should match its chromosome - for (i in 1:3) { - block_variants <- rownames(partitioned$ldMatrices[[i]]) - # Strip "chr" prefix before extracting chromosome number - chrom_from_variants <- unique(as.integer(sub( - "chr([0-9]+):.*", - "\\1", - block_variants - ))) - expect_equal(length(chrom_from_variants), 1) # Should only have one chromosome per block - expect_equal(chrom_from_variants, i) # Should match the expected chromosome - } -}) - -test_that("mergeBlocks merges small adjacent blocks", { - block_meta <- data.frame( - blockId = c(1, 2, 3), - chrom = c("1", "1", "1"), - size = c(50, 50, 100), - startIdx = c(1, 51, 101), - endIdx = c(50, 100, 200) - ) - result <- pecotmr:::mergeBlocks( - .ld_bmGr(block_meta), - minSize = 100, - maxSize = 10000 - ) - expect_true(length(result) < 3) -}) - -test_that("mergeBlocks does not merge cross-chromosome", { - block_meta <- data.frame( - blockId = c(1, 2), - chrom = c("1", "2"), - size = c(10, 10), - startIdx = c(1, 11), - endIdx = c(10, 20) - ) - result <- pecotmr:::mergeBlocks( - .ld_bmGr(block_meta), - minSize = 50, - maxSize = 10000 - ) - expect_equal(length(result), 2) # Cannot merge across chromosomes -}) - -test_that("mergeBlocks returns single block unchanged", { - block_meta <- data.frame( - blockId = 1, - chrom = "1", - size = 10, - startIdx = 1, - endIdx = 10 - ) - result <- pecotmr:::mergeBlocks( - .ld_bmGr(block_meta), - minSize = 100, - maxSize = 10000 - ) - expect_equal(length(result), 1) -}) - # ---- canMerge ---- -test_that("canMerge checks chromosome and size", { - bm <- data.frame( - chrom = c("1", "1", "2"), - size = c(100, 200, 100), - stringsAsFactors = FALSE - ) - # rows 1 and 2: same chrom, combined size 300 - expect_true(pecotmr:::canMerge(.ld_bmGr(bm), 1, 2, maxSize = 500)) - expect_false(pecotmr:::canMerge(.ld_bmGr(bm), 1, 2, maxSize = 200)) - # rows 1 and 3: different chromosome - expect_false(pecotmr:::canMerge(.ld_bmGr(bm), 1, 3, maxSize = 500)) -}) - # =========================================================================== # checkLd (regularize_ld) # =========================================================================== @@ -1260,37 +337,6 @@ test_that("checkLd eigenfix does nothing when matrix is already PD", { expect_equal(result$R, R) }) -# =========================================================================== -# extractBlockMatrices: out-of-range blocks -# =========================================================================== - -test_that("extractBlockMatrices warns and skips out-of-range blocks", { - mat <- diag(4) - vnames <- sprintf("chr1:%d:A:G", 100L * (1:4)) - rownames(mat) <- colnames(mat) <- vnames - blockMetadata <- data.frame( - blockId = c(1, 2), - startIdx = c(1, 10), - endIdx = c(2, 12), - chrom = c("1", "1"), - blockStart = c(100, 500), - blockEnd = c(200, 600), - size = c(2, 3), - stringsAsFactors = FALSE - ) - expect_warning( - result <- pecotmr:::extractBlockMatrices( - mat, - .ld_bmGr(blockMetadata), - vnames - ), - "outside the range" - ) - valid_blocks <- compact(result$ldMatrices) - expect_equal(length(valid_blocks), 1) - expect_equal(nrow(valid_blocks[[1]]), 2) -}) - # =========================================================================== # resolveLdSource: type detection with real fixtures # =========================================================================== @@ -1341,8 +387,20 @@ test_that("resolveLdSource detects GDS from metadata", { expect_equal(result$type, "gds") }) -test_that("resolveLdSource detects precomputed from metadata", { - # Existing LD block metadata with non-zero start/end +test_that("resolveLdSource tells a file's format as readGenotypes does", { + # A .vcf.bgz is a VCF, and an extension's case does not matter. + dir <- withr::local_tempdir() + files <- file.path(dir, c("x.vcf.bgz", "x.VCF.GZ", "x.GDS", "x.Bgen")) + file.create(files) + expect_equal( + purrr::map_chr(files, function(f) pecotmr:::resolveLdSource(f)$type), + c("vcf", "vcf", "gds", "bgen") + ) +}) + +test_that("resolveLdSource refuses a row pointing at pre-computed LD", { + # pecotmr reads LD only from genotypes, so a row naming a .cor.xz matrix + # is an error rather than a source type. meta_file <- file.path(geno_test_data_dir, "ld_meta_resolve_pre_tmp.tsv") on.exit(unlink(meta_file), add = TRUE) writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) @@ -1358,8 +416,24 @@ test_that("resolveLdSource detects precomputed from metadata", { file = meta_file, append = TRUE ) - result <- pecotmr:::resolveLdSource(meta_file) - expect_equal(result$type, "precomputed") + expect_error( + pecotmr:::resolveLdSource(meta_file), + "does not resolve to genotype files" + ) +}) + +test_that("resolveLdSource takes a genotype source given directly", { + # A genotype file or PLINK prefix is its own source, with no metadata. + stem <- str_remove( + system.file("extdata", "toy_ref.bed", package = "pecotmr"), + "\\.bed$" + ) + res <- pecotmr:::resolveLdSource(stem) + expect_equal(res$type, "plink1") + expect_equal(res$dataPath, stem) + expect_null(res$metaPath) + vcf <- test_path("test_data", "test_variants.vcf.gz") + expect_equal(pecotmr:::resolveLdSource(vcf)$type, "vcf") }) test_that("resolveLdSource errors on missing file", { @@ -1379,7 +453,10 @@ test_that("resolveLdSource errors on 0:0 sentinel with non-genotype path", { file = meta_file, append = TRUE ) - expect_error(pecotmr:::resolveLdSource(meta_file), "0:0 sentinel") + expect_error( + pecotmr:::resolveLdSource(meta_file), + "does not resolve to genotype files" + ) }) # =========================================================================== @@ -1416,411 +493,23 @@ test_that("resolveGenotypePathForRegion errors on missing chromosome", { ) }) -# =========================================================================== -# loadLdFromGenotype with real fixtures -# =========================================================================== - -test_that("loadLdFromGenotype returns LD matrix with .afreq", { - skip_if_not_installed("pgenlibr") - plink_prefix <- file.path(geno_test_data_dir, "test_variants") - result <- pecotmr:::loadLdFromGenotype(plink_prefix, geno_region_all) - expect_true(is(result, "LdData")) - expect_true(is.matrix(ldMatrix(result))) - expect_equal(nrow(ldMatrix(result)), 349L) - expect_true(isSymmetric(ldMatrix(result))) - expect_false(hasGenotypes(result)) - # ref_panel should have allele_freq from .afreq file - expect_true( - "allele_freq" %in% names(S4Vectors::mcols(variantInfo(result))) - ) - expect_true(all(S4Vectors::mcols(variantInfo(result))$allele_freq > 0)) - expect_true(all(S4Vectors::mcols(variantInfo(result))$allele_freq < 1)) - # blockMetadata - expect_true(is(blockMetadata(result), "GRanges")) - expect_equal(length(blockMetadata(result)), 1L) -}) - -test_that("loadLdFromGenotype returns genotype matrix when requested", { - skip_if_not_installed("pgenlibr") - plink_prefix <- file.path(geno_test_data_dir, "test_variants") - result <- pecotmr:::loadLdFromGenotype( - plink_prefix, - geno_region_all, - returnGenotype = TRUE - ) - expect_true(hasGenotypes(result)) - X <- genotypes(result) - expect_equal(nrow(X), 100L) # samples - expect_equal(ncol(X), 349L) # variants -}) - -test_that("loadLdFromGenotype computes variance with n_sample", { - skip_if_not_installed("pgenlibr") - plink_prefix <- file.path(geno_test_data_dir, "test_variants") - result <- pecotmr:::loadLdFromGenotype( - plink_prefix, - geno_region_all, - nSample = 100L - ) - expect_true("variance" %in% names(S4Vectors::mcols(variantInfo(result)))) - expect_true("n_nomiss" %in% names(S4Vectors::mcols(variantInfo(result)))) - expect_equal(S4Vectors::mcols(variantInfo(result))$n_nomiss[1], 100L) - expect_true(all(S4Vectors::mcols(variantInfo(result))$variance > 0)) -}) - -test_that("loadLdFromGenotype falls back to computed AF without .afreq", { - skip_if_not_installed("VariantAnnotation") - vcf_path <- file.path(geno_test_data_dir, "test_variants.vcf.gz") - result <- suppressWarnings( - pecotmr:::loadLdFromGenotype(vcf_path, geno_region_all) - ) - expect_true(is.matrix(ldMatrix(result))) - expect_equal(nrow(ldMatrix(result)), 349L) - expect_true(isSymmetric(ldMatrix(result))) - # Allele frequencies computed from genotypes - expect_true( - "allele_freq" %in% names(S4Vectors::mcols(variantInfo(result))) - ) - expect_true(all(S4Vectors::mcols(variantInfo(result))$allele_freq > 0)) - expect_true(all(S4Vectors::mcols(variantInfo(result))$allele_freq < 1)) -}) - -test_that("loadLdFromGenotype works with GDS files", { - skip_if_not_installed("SNPRelate") - skip_if_not_installed("gdsfmt") - gds_path <- file.path(geno_test_data_dir, "test_variants.gds") - result <- pecotmr:::loadLdFromGenotype(gds_path, geno_region_all) - expect_true(is.matrix(ldMatrix(result))) - expect_equal(nrow(ldMatrix(result)), 349L) - expect_true(isSymmetric(ldMatrix(result))) -}) - -test_that("loadLdFromGenotype .afreq and computed AF are consistent", { - skip_if_not_installed("pgenlibr") - skip_if_not_installed("SNPRelate") - skip_if_not_installed("gdsfmt") - plink_prefix <- file.path(geno_test_data_dir, "test_variants") - gds_path <- file.path(geno_test_data_dir, "test_variants.gds") - res_afreq <- pecotmr:::loadLdFromGenotype(plink_prefix, geno_region_all) - res_computed <- pecotmr:::loadLdFromGenotype(gds_path, geno_region_all) - # Allele frequencies should be close (same data, different source) - expect_true( - max(abs( - S4Vectors::mcols(variantInfo(res_afreq))$allele_freq - - S4Vectors::mcols(variantInfo(res_computed))$allele_freq - )) < - 0.01 - ) -}) - -# =========================================================================== -# loadLdMatrix with real genotype fixtures via metadata -# =========================================================================== - -test_that("loadLdMatrix dispatches to PLINK2 genotype source", { - skip_if_not_installed("pgenlibr") - meta_file <- file.path(geno_test_data_dir, "ld_meta_ldmat_p2_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste("21", "0", "0", "test_variants", sep = "\t"), - "\n", - file = meta_file, - append = TRUE - ) - result <- loadLdMatrix(meta_file, geno_region_all) - expect_true(is.matrix(ldMatrix(result))) - expect_equal(nrow(ldMatrix(result)), 349L) - expect_false(hasGenotypes(result)) -}) - -test_that("loadLdMatrix dispatches to VCF genotype source", { - skip_if_not_installed("VariantAnnotation") - meta_file <- file.path(geno_test_data_dir, "ld_meta_ldmat_vcf_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste("21", "0", "0", "test_variants.vcf.gz", sep = "\t"), - "\n", - file = meta_file, - append = TRUE - ) - result <- suppressWarnings(loadLdMatrix(meta_file, geno_region_all)) - expect_true(is.matrix(ldMatrix(result))) - expect_equal(nrow(ldMatrix(result)), 349L) -}) - -test_that("loadLdMatrix dispatches to GDS genotype source", { - skip_if_not_installed("SNPRelate") - skip_if_not_installed("gdsfmt") - meta_file <- file.path(geno_test_data_dir, "ld_meta_ldmat_gds_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste("21", "0", "0", "test_variants.gds", sep = "\t"), - "\n", - file = meta_file, - append = TRUE - ) - result <- loadLdMatrix(meta_file, geno_region_all) - expect_true(is.matrix(ldMatrix(result))) - expect_equal(nrow(ldMatrix(result)), 349L) -}) - -test_that("loadLdMatrix return_genotype='auto' returns X for genotype source", { - skip_if_not_installed("pgenlibr") - meta_file <- file.path(geno_test_data_dir, "ld_meta_ldmat_auto_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste("21", "0", "0", "test_variants", sep = "\t"), - "\n", - file = meta_file, - append = TRUE - ) - result <- loadLdMatrix(meta_file, geno_region_all, returnGenotype = "auto") - expect_true(hasGenotypes(result)) - X <- genotypes(result) - expect_equal(nrow(X), 100L) # samples - expect_equal(ncol(X), 349L) # variants -}) - -test_that("loadLdMatrix return_genotype=TRUE errors for precomputed", { - meta_file <- gsub( - "//", - "/", - tempfile(pattern = "ld_meta_file", tmpdir = tempdir(), fileext = ".tsv") - ) - on.exit(unlink(meta_file), add = TRUE) - meta_df <- data.frame( - chrom = "chr1", - start = 1000, - end = 1200, - path = paste0( - "./test_data/LD_block_1.chr1_1000_1200.float16.txt.xz,", - "./test_data/LD_block_1.chr1_1000_1200.float16.bim" - ) - ) - write_delim(meta_df, meta_file, delim = "\t") - region <- data.frame(chrom = "chr1", start = 1000, end = 1190) - expect_error( - loadLdMatrix(meta_file, region, returnGenotype = TRUE), - "genotype files" - ) -}) - -# =========================================================================== -# resolveLdSource: PLINK1 detection -# =========================================================================== - -test_that("resolveLdSource detects PLINK1 from metadata", { - skip_if_not_installed("snpStats") - meta_file <- file.path(geno_test_data_dir, "ld_meta_resolve_p1_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste("22", "0", "0", "protocol_example.genotype", sep = "\t"), - "\n", - file = meta_file, - append = TRUE - ) - result <- pecotmr:::resolveLdSource(meta_file) - expect_equal(result$type, "plink1") -}) - -# =========================================================================== -# loadLdMatrix: precomputed blocks via real .cor.xz fixtures -# =========================================================================== - -test_that("loadLdMatrix loads single precomputed block", { - meta_file <- file.path(geno_test_data_dir, "ld_meta_precomp_single_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste( - "1", - "1000", - "1200", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.bim", - sep = "\t" - ), - "\n", - file = meta_file, - append = TRUE - ) - result <- loadLdMatrix(meta_file, "chr1:1000-1190") - expect_true(is.matrix(ldMatrix(result))) - expect_equal(nrow(ldMatrix(result)), 5L) - expect_true(isSymmetric(ldMatrix(result))) - expect_equal(length(variantIds(result)), 5L) - expect_true(all(grepl("^chr1:", variantIds(result)))) - expect_false(hasGenotypes(result)) - # blockMetadata should have one block - expect_equal(length(blockMetadata(result)), 1L) - # ref_panel (now GRanges) should have variant info via mcols - ref_mcols <- S4Vectors::mcols(variantInfo(result)) - expect_true("variant_id" %in% names(ref_mcols)) -}) - -test_that("loadLdMatrix loads multiple precomputed blocks", { - meta_file <- file.path(geno_test_data_dir, "ld_meta_precomp_multi_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - lines <- c( - paste("chrom", "start", "end", "path", sep = "\t"), - paste( - "1", - "1000", - "1200", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.bim", - sep = "\t" - ), - paste( - "1", - "1200", - "1400", - "LD_block_2.chr1_1200_1400.float16.txt.xz,LD_block_2.chr1_1200_1400.float16.bim", - sep = "\t" - ), - paste( - "1", - "1400", - "1600", - "LD_block_3.chr1_1400_1600.float16.txt.xz,LD_block_3.chr1_1400_1600.float16.bim", - sep = "\t" - ) - ) - writeLines(lines, meta_file) - result <- loadLdMatrix(meta_file, "chr1:1000-1500") - expect_true(is.matrix(ldMatrix(result))) - # Should span blocks 1-3: 5 + 5 + 5 = 15 unique variants (no overlap in variant IDs) - expect_true(nrow(ldMatrix(result)) >= 10) - expect_true(isSymmetric(ldMatrix(result))) - expect_true(length(blockMetadata(result)) >= 2) -}) - -test_that("loadLdMatrix with n_sample for precomputed blocks with freq data", { - # The 9-column bim format includes allele_freq, variance, n_nomiss; - # the 6-column bim does not. With 6-col bim and no allele_freq, - # n_sample cannot compute variance - ref_panel has base columns only. - meta_file <- file.path(geno_test_data_dir, "ld_meta_precomp_nsamp_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste( - "1", - "1000", - "1200", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.bim", - sep = "\t" - ), - "\n", - file = meta_file, - append = TRUE - ) - result <- loadLdMatrix(meta_file, "chr1:1000-1190", nSample = 500L) - # ref_panel (GRanges) should always have basic variant info in mcols - ref_mcols <- S4Vectors::mcols(variantInfo(result)) - expect_true(all(c("A2", "A1", "variant_id") %in% names(ref_mcols))) - # 6-col bim lacks allele_freq so variance computation is skipped - expect_false("variance" %in% names(ref_mcols)) -}) - -# =========================================================================== -# processLdMatrix: real .cor.xz fixtures -# =========================================================================== - -test_that("processLdMatrix reads .cor.xz with explicit bim path", { - ld_file <- file.path( - geno_test_data_dir, - "LD_block_1.chr1_1000_1200.float16.txt.xz" - ) - bim_file <- file.path( - geno_test_data_dir, - "LD_block_1.chr1_1000_1200.float16.bim" - ) - result <- pecotmr:::processLdMatrix(ld_file, bim_file) - expect_true(is.list(result)) - expect_true(is.matrix(result$ldMatrix)) - expect_equal(nrow(result$ldMatrix), 5L) - expect_equal(ncol(result$ldMatrix), 5L) - expect_true(isSymmetric(result$ldMatrix)) - # Diagonal should be 1 - expect_true(all(abs(diag(result$ldMatrix) - 1) < 1e-4)) - # Variant names should be chr:pos:A2:A1 format - expect_true(all(grepl("^chr1:", rownames(result$ldMatrix)))) - # ldVariants data frame - expect_true(is.data.frame(result$ldVariants)) - expect_true("variants" %in% names(result$ldVariants)) - expect_equal(nrow(result$ldVariants), 5L) -}) - -test_that("processLdMatrix reads different blocks consistently", { - bim1 <- file.path( - geno_test_data_dir, - "LD_block_1.chr1_1000_1200.float16.bim" - ) - bim2 <- file.path( - geno_test_data_dir, - "LD_block_2.chr1_1200_1400.float16.bim" - ) - ld1 <- file.path( - geno_test_data_dir, - "LD_block_1.chr1_1000_1200.float16.txt.xz" - ) - ld2 <- file.path( - geno_test_data_dir, - "LD_block_2.chr1_1200_1400.float16.txt.xz" - ) - r1 <- pecotmr:::processLdMatrix(ld1, bim1) - r2 <- pecotmr:::processLdMatrix(ld2, bim2) - # Different blocks should have different variant positions - expect_false(any(rownames(r1$ldMatrix) %in% rownames(r2$ldMatrix))) -}) - -test_that("processLdMatrix reads 9-column bim with allele_freq/variance/n_nomiss", { - ld_file <- file.path( - geno_test_data_dir, - "LD_block_1.chr1_1000_1200.float16.txt.xz" - ) - bim_file <- file.path( - geno_test_data_dir, - "LD_block_1.chr1_1000_1200.float16.9col.bim" - ) - result <- pecotmr:::processLdMatrix(ld_file, bim_file) - expect_equal(nrow(result$ldMatrix), 5L) - expect_true(isSymmetric(result$ldMatrix)) - # 9-column bim should include extra columns - expect_true("allele_freq" %in% names(result$ldVariants)) - expect_true("variance" %in% names(result$ldVariants)) - expect_true("n_nomiss" %in% names(result$ldVariants)) - expect_equal(result$ldVariants$allele_freq, c(0.3, 0.4, 0.2, 0.5, 0.15)) - expect_equal(result$ldVariants$n_nomiss, rep(500, 5)) -}) - -test_that("loadLdMatrix propagates allele_freq/variance/n_nomiss from 9-col bim", { - meta_file <- file.path(geno_test_data_dir, "ld_meta_precomp_9col_tmp.tsv") +# =========================================================================== +# resolveLdSource: PLINK1 detection +# =========================================================================== + +test_that("resolveLdSource detects PLINK1 from metadata", { + skip_if_not_installed("snpStats") + meta_file <- file.path(geno_test_data_dir, "ld_meta_resolve_p1_tmp.tsv") on.exit(unlink(meta_file), add = TRUE) writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) cat( - paste( - "1", - "1000", - "1200", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.9col.bim", - sep = "\t" - ), + paste("22", "0", "0", "protocol_example.genotype", sep = "\t"), "\n", file = meta_file, append = TRUE ) - result <- loadLdMatrix(meta_file, "chr1:1000-1190") - # ref_panel (GRanges) should carry the extra columns from the 9-col bim - ref_mcols <- S4Vectors::mcols(variantInfo(result)) - expect_true("allele_freq" %in% names(ref_mcols)) - expect_true("variance" %in% names(ref_mcols)) - expect_true("n_nomiss" %in% names(ref_mcols)) - expect_equal(ref_mcols$allele_freq, c(0.3, 0.4, 0.2, 0.5, 0.15)) - expect_equal(ref_mcols$n_nomiss, rep(500, 5)) + result <- pecotmr:::resolveLdSource(meta_file) + expect_equal(result$type, "plink1") }) # =========================================================================== @@ -2134,10 +823,8 @@ test_that("loadLdMatrix dedup removes duplicated variants from result", { expect_false(any(duplicated(variants_clean))) }) - test_data_dir <- test_path("test_data") - library(testthat) # =========================================================================== @@ -2179,12 +866,15 @@ test_that("ldPruneByCorrelation preserves colnames for single remaining column", expect_true(!is.null(colnames(result$X.new))) }) -test_that("ldPruneByCorrelation errors on single-column input", { +test_that("ldPruneByCorrelation keeps a single column, with nothing to prune", { + # hclust() could not cluster one object, so this used to error. set.seed(42) n <- 30 X <- matrix(rnorm(n), nrow = n, ncol = 1) colnames(X) <- "chr1:100:A:G" - expect_error(ldPruneByCorrelation(X, corThres = 0.8)) + res <- ldPruneByCorrelation(X, corThres = 0.8) + expect_identical(res$X.new, X) + expect_identical(res$filter.id, 1L) }) test_that("ldPruneByCorrelation strict threshold removes at least as many as lenient", { @@ -2467,42 +1157,6 @@ test_that("ldClumpByScore returns indices on real data", { expect_true(length(keep) < p) }) - -test_that("standardize_genotype_hwe: centers by 2p and scales by sqrt(2p(1-p))", { - set.seed(42) - n <- 30 - p <- 5 - af <- runif(p, 0.1, 0.9) - X <- matrix(rbinom(n * p, 2, rep(af, each = n)), nrow = n, ncol = p) - - X_std <- pecotmr:::standardizeGenotypeHwe(X, af) - - # Manual verification - expected <- sweep(sweep(X, 2, 2 * af), 2, sqrt(2 * af * (1 - af)), "/") - expect_equal(X_std, expected, tolerance = 1e-14) -}) - - -test_that("SVD from raw sketch matches direct computation", { - set.seed(77) - n <- 25 - p <- 8 - af <- runif(p, 0.15, 0.85) - X <- matrix(rbinom(n * p, 2, rep(af, each = n)), nrow = n, ncol = p) - - # Two-step process: standardize then SVD - X_std <- pecotmr:::standardizeGenotypeHwe(X, af) - svd_result <- svd(X_std) - - # Verify this matches manual computation - X_manual <- sweep(sweep(X, 2, 2 * af), 2, sqrt(2 * af * (1 - af)), "/") - svd_manual <- svd(X_manual) - - expect_equal(svd_result$d, svd_manual$d, tolerance = 1e-14) - expect_equal(abs(svd_result$v), abs(svd_manual$v), tolerance = 1e-14) -}) - - # =========================================================================== # Tests migrated from test_misc.R (computeLd + .findValidFilePath*) # =========================================================================== @@ -2525,7 +1179,6 @@ test_that("findValidFilePath returns target when it exists directly", { expect_equal(result, target) }) - test_that("findValidFilePath constructs path from reference directory", { pkg_root <- normalizePath( file.path(test_path(), "..", ".."), @@ -2541,7 +1194,6 @@ test_that("findValidFilePath constructs path from reference directory", { expect_true(grepl("DESCRIPTION$", result)) }) - test_that("findValidFilePath errors when both paths are invalid", { expect_error( pecotmr:::.findValidFilePath( @@ -2552,7 +1204,6 @@ test_that("findValidFilePath errors when both paths are invalid", { ) }) - test_that("findValidFilePath returns reference when target is invalid but reference exists", { pkg_root <- normalizePath( file.path(test_path(), "..", ".."), @@ -2567,7 +1218,6 @@ test_that("findValidFilePath returns reference when target is invalid but refere expect_equal(result, ref) }) - test_that("findValidFilePaths resolves multiple targets", { pkg_root <- normalizePath( file.path(test_path(), "..", ".."), @@ -2581,7 +1231,6 @@ test_that("findValidFilePaths resolves multiple targets", { expect_true(all(file.exists(result))) }) - test_that("findValidFilePaths errors on all-invalid targets", { ref <- "/nonexistent/ref.txt" targets <- c("/bogus/a.txt", "/bogus/b.txt") @@ -2605,7 +1254,6 @@ test_that("computeLd sample method produces valid correlation matrix", { expect_true(all(R >= -1 & R <= 1)) }) - test_that("computeLd population method produces valid matrix", { set.seed(42) X <- matrix(sample(0:2, 200, replace = TRUE), nrow = 50) @@ -2617,7 +1265,6 @@ test_that("computeLd population method produces valid matrix", { expect_true(isSymmetric(R)) }) - test_that("computeLd with a single SNP returns 1x1 identity matrix", { X <- matrix(c(0, 1, 2, 1, 0), ncol = 1) colnames(X) <- "rs1" @@ -2627,7 +1274,6 @@ test_that("computeLd with a single SNP returns 1x1 identity matrix", { expect_equal(colnames(R), "rs1") }) - test_that("computeLd handles column with all NA gracefully", { set.seed(123) X <- matrix(sample(0:2, 100, replace = TRUE), nrow = 20, ncol = 5) @@ -2641,7 +1287,6 @@ test_that("computeLd handles column with all NA gracefully", { expect_equal(R[1, 3], 0) }) - test_that("computeLd population method handles column with all NA", { set.seed(123) X <- matrix(sample(0:2, 100, replace = TRUE), nrow = 20, ncol = 5) @@ -2654,7 +1299,6 @@ test_that("computeLd population method handles column with all NA", { expect_equal(R[2, 4], 0) }) - test_that("computeLd with larger matrix (100 SNPs) is fast and valid", { set.seed(99) X <- matrix(sample(0:2, 5000, replace = TRUE), nrow = 50, ncol = 100) @@ -2667,7 +1311,6 @@ test_that("computeLd with larger matrix (100 SNPs) is fast and valid", { expect_true(all(R >= -1 & R <= 1)) }) - test_that("computeLd population method with larger matrix is valid", { set.seed(99) X <- matrix(sample(0:2, 5000, replace = TRUE), nrow = 50, ncol = 100) @@ -2679,7 +1322,6 @@ test_that("computeLd population method with larger matrix is valid", { expect_true(isSymmetric(R)) }) - test_that("computeLd with perfectly correlated SNPs returns correlation of 1", { set.seed(42) col1 <- sample(0:2, 50, replace = TRUE) @@ -2691,7 +1333,6 @@ test_that("computeLd with perfectly correlated SNPs returns correlation of 1", { expect_equal(R[2, 1], 1.0, tolerance = 1e-10) }) - test_that("computeLd population method with trim_samples trims correctly", { set.seed(42) X <- matrix(sample(0:2, 33, replace = TRUE), nrow = 11, ncol = 3) @@ -2703,7 +1344,6 @@ test_that("computeLd population method with trim_samples trims correctly", { expect_equal(dim(R_full), c(3L, 3L)) }) - test_that("computeLd with two monomorphic SNPs produces 0 off-diagonal", { X <- matrix(c(rep(1, 50), rep(2, 50)), nrow = 50, ncol = 2) colnames(X) <- c("mono1", "mono2") @@ -2714,7 +1354,6 @@ test_that("computeLd with two monomorphic SNPs produces 0 off-diagonal", { expect_equal(unname(diag(R)), c(1, 1)) }) - test_that("computeLd preserves column names", { set.seed(42) X <- matrix(sample(0:2, 60, replace = TRUE), nrow = 20, ncol = 3) @@ -2725,7 +1364,6 @@ test_that("computeLd preserves column names", { expect_equal(rownames(R), c("snp_alpha", "snp_beta", "snp_gamma")) }) - test_that("computeLd with heavy missingness still produces valid matrix", { set.seed(42) X <- matrix(sample(0:2, 200, replace = TRUE), nrow = 40, ncol = 5) @@ -2742,7 +1380,6 @@ test_that("computeLd with heavy missingness still produces valid matrix", { expect_equal(unname(diag(R_pop)), rep(1, 5)) }) - test_that("computeLd with NA genotypes and sample method", { set.seed(42) X <- matrix(sample(0:2, 200, replace = TRUE), nrow = 50) @@ -2755,12 +1392,10 @@ test_that("computeLd with NA genotypes and sample method", { expect_equal(unname(diag(R)), rep(1, 4)) }) - test_that("computeLd errors on NULL input", { expect_error(computeLd(NULL), "X must be provided") }) - test_that("computeLd sample vs population differ but are close", { set.seed(42) X <- matrix(sample(0:2, 500, replace = TRUE), nrow = 100) @@ -2773,7 +1408,6 @@ test_that("computeLd sample vs population differ but are close", { expect_true(max(abs(R_sample - R_pop)) < 0.1) }) - test_that("computeLd gcta method produces valid correlation matrix", { set.seed(42) X <- matrix(sample(0:2, 500, replace = TRUE), nrow = 100) @@ -2786,7 +1420,6 @@ test_that("computeLd gcta method produces valid correlation matrix", { expect_true(all(abs(R) <= 1 + 1e-10)) }) - test_that("computeLd gcta method handles missing data", { set.seed(42) X <- matrix(sample(0:2, 500, replace = TRUE), nrow = 100) @@ -2798,7 +1431,6 @@ test_that("computeLd gcta method handles missing data", { expect_true(all(is.finite(R))) }) - test_that("computeLd gcta agrees with sample method on complete data", { set.seed(42) X <- matrix(sample(0:2, 500, replace = TRUE), nrow = 100) @@ -2811,7 +1443,6 @@ test_that("computeLd gcta agrees with sample method on complete data", { expect_true(max(abs(R_sample - R_gcta)) < 0.05) }) - test_that("computeLd gcta preserves column names", { set.seed(42) X <- matrix(sample(0:2, 300, replace = TRUE), nrow = 100) @@ -2822,7 +1453,6 @@ test_that("computeLd gcta preserves column names", { expect_equal(rownames(R), c("snp_a", "snp_b", "snp_c")) }) - # ============================================================================= # waldTestPval # ============================================================================= @@ -2837,7 +1467,6 @@ test_that("computeLd sample method without Rfast falls back to cor", { expect_true(all(abs(R) <= 1)) }) - test_that("computeLd with gcta method and trim_samples", { set.seed(42) # 21 samples -> trimmed to 20 (multiple of 4) @@ -2848,7 +1477,6 @@ test_that("computeLd with gcta method and trim_samples", { expect_equal(as.numeric(diag(R)), rep(1, 5)) }) - test_that("computeLd population method with trim_samples", { set.seed(42) X <- matrix(sample(0:2, 105, replace = TRUE), nrow = 21, ncol = 5) @@ -2858,7 +1486,6 @@ test_that("computeLd population method with trim_samples", { expect_equal(as.numeric(diag(R)), rep(1, 5)) }) - test_that("computeLd with shrinkage > 0", { set.seed(42) X <- matrix(sample(0:2, 100, replace = TRUE), nrow = 20, ncol = 5) @@ -2873,7 +1500,6 @@ test_that("computeLd with shrinkage > 0", { expect_equal(off_diag_s, 0.9 * off_diag_no) }) - # ============================================================================= # Additional coverage: findIntersectionRows / regionalLdMeta edge cases # ============================================================================= @@ -2934,154 +1560,6 @@ test_that("regionalLdMeta validates complete coverage when required", { expect_true(length(result$intersections$LD_file_paths) >= 1) }) -# ============================================================================= -# Additional coverage: processLdMatrix variant-file auto-detect / pvar / symm -# ============================================================================= - -test_that("processLdMatrix auto-detects companion .bim when snpFilePath is NULL", { - tmp_xz <- tempfile(fileext = ".txt.xz") - on.exit(unlink(c(tmp_xz, paste0(tmp_xz, ".bim"))), add = TRUE) - file.copy( - file.path( - geno_test_data_dir, - "LD_block_1.chr1_1000_1200.float16.txt.xz" - ), - tmp_xz - ) - # Place the companion at ".bim" so the auto-detector finds it - file.copy( - file.path(geno_test_data_dir, "LD_block_1.chr1_1000_1200.float16.bim"), - paste0(tmp_xz, ".bim") - ) - result <- pecotmr:::processLdMatrix(tmp_xz, snpFilePath = NULL) - expect_equal(nrow(result$ldMatrix), 5L) - expect_true(all(grepl("^chr1:", rownames(result$ldMatrix)))) -}) - -test_that("processLdMatrix errors when no companion variant file is found", { - tmp_xz <- tempfile(fileext = ".txt.xz") - on.exit(unlink(tmp_xz), add = TRUE) - file.copy( - file.path( - geno_test_data_dir, - "LD_block_1.chr1_1000_1200.float16.txt.xz" - ), - tmp_xz - ) - expect_error( - pecotmr:::processLdMatrix(tmp_xz, snpFilePath = NULL), - "No variant file found" - ) -}) - -test_that("processLdMatrix reads .pvar metadata and symmetrizes an upper-triangular matrix", { - skip_if_not_installed("pgenlibr") - pvar <- file.path(geno_test_data_dir, "test_harmonize_regions.pvar") # 8 variants - # Build an 8x8 upper-triangular matrix (lower triangle exactly zero) so the - # lower.tri == 0 branch fires (line 183). - set.seed(1) - n <- 8 - U <- diag(n) - U[upper.tri(U)] <- round(runif(sum(upper.tri(U)), -0.4, 0.8), 3) - expect_true(all(U[lower.tri(U)] == 0)) - tmp_xz <- tempfile(fileext = ".txt.xz") - on.exit(unlink(tmp_xz), add = TRUE) - con <- xzfile(tmp_xz, "w") - writeLines(paste(as.vector(t(U)), collapse = " "), con) # row-major order - close(con) - - result <- pecotmr:::processLdMatrix(tmp_xz, pvar) - expect_equal(nrow(result$ldMatrix), n) - expect_true(isSymmetric(result$ldMatrix)) - # .pvar metadata has no gpos column; pos is derived from the variant id - expect_false("gpos" %in% names(result$ldVariants)) - expect_true(all(grepl("^chr21:", rownames(result$ldMatrix)))) -}) - -# ============================================================================= -# Additional coverage: createLdMatrix empty entry / loadLdMatrix dedup -# ============================================================================= - -test_that("createLdMatrix skips empty variant-list entries", { - m1 <- matrix( - c(1, 0.5, 0.5, 1), - 2, - 2, - dimnames = list( - c("chr1:100:A:G", "chr1:200:A:G"), - c("chr1:100:A:G", "chr1:200:A:G") - ) - ) - variants <- list( - data.frame(variants = character(0)), # empty -> next (line 229) - data.frame(variants = c("chr1:100:A:G", "chr1:200:A:G")) - ) - result <- pecotmr:::createLdMatrix(list(matrix(0, 0, 0), m1), variants) - expect_equal(nrow(result), 2L) - expect_equal(rownames(result), c("chr1:100:A:G", "chr1:200:A:G")) - expect_equal(result["chr1:100:A:G", "chr1:200:A:G"], 0.5) -}) - -test_that("loadLdMatrix removes duplicate variants from the backend result", { - meta_file <- file.path(geno_test_data_dir, "ld_meta_dedup_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste( - "1", - "1000", - "1200", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.bim", - sep = "\t" - ), - "\n", - file = meta_file, - append = TRUE - ) - - # Build an LdData whose variant IDs contain a duplicate (index 3 == index 1) - variant_ids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:100:A:G") - ref <- data.frame( - chrom = c(1, 1, 1), - pos = c(100, 200, 100), - A2 = c("A", "C", "A"), - A1 = c("G", "T", "G"), - variant_id = variant_ids, - stringsAsFactors = FALSE - ) - gr <- pecotmr:::.refPanelToGranges(ref) - R <- matrix(c(1, 0.5, 0.9, 0.5, 1, 0.4, 0.9, 0.4, 1), 3, 3) - rownames(R) <- colnames(R) <- variant_ids - bm <- data.frame( - blockId = 1L, - chrom = "1", - blockStart = 100L, - blockEnd = 200L, - size = 3L, - startIdx = 1L, - endIdx = 3L, - stringsAsFactors = FALSE - ) - dup_ld <- LdData(correlation = R, variants = gr, blockMetadata = bm) - - local_mocked_bindings( - loadLdFromBlocks = function( - ldMetaFilePath, - region, - extractCoordinates = NULL, - nSample = NULL - ) { - dup_ld - }, - .package = "pecotmr" - ) - result <- loadLdMatrix(meta_file, "chr1:100-200") - ids <- variantIds(result) - expect_equal(length(ids), 2L) - expect_false(any(duplicated(ids))) - expect_equal(dim(ldMatrix(result)), c(2L, 2L)) -}) - # ============================================================================= # Additional coverage: resolveLdSource column check # ============================================================================= @@ -3100,33 +1578,10 @@ test_that("resolveLdSource errors when metadata has fewer than 4 columns", { }) # ============================================================================= -# Additional coverage: loadLdFromGenotype .afreq mismatch warning -# ============================================================================= - -test_that("loadLdFromGenotype warns when .afreq is missing some variants", { - skip_if_not_installed("pgenlibr") - plink_prefix <- file.path(geno_test_data_dir, "test_variants") - local_mocked_bindings( - readAfreq = function(prefix) { - data.frame( - id = "no_such_variant", - alt_freq = 0.1, - stringsAsFactors = FALSE - ) - }, - .package = "pecotmr" - ) - expect_warning( - pecotmr:::loadLdFromGenotype(plink_prefix, geno_region_all), - "no allele frequency" - ) -}) - -# ============================================================================= -# Additional coverage: .ldFromSketch onMissing="drop" +# Additional coverage: .ldFromRef onMissing="drop" # ============================================================================= -test_that(".ldFromSketch drops variants absent from the panel when onMissing='drop'", { +test_that(".ldFromRef drops variants the panel lacks under onMissing='drop'", { skip_if_not_installed("pgenlibr") h <- readGenotypeHandle( file.path(geno_test_data_dir, "test_variants"), @@ -3134,7 +1589,7 @@ test_that(".ldFromSketch drops variants absent from the panel when onMissing='dr ) si <- snpInfo(h) ids <- c(as.character(si$SNP[1]), "bogus:999:A:G", as.character(si$SNP[3])) - m <- pecotmr:::.ldFromSketch(h, ids, onMissing = "drop") + m <- pecotmr:::.ldFromRef(h, ids, onMissing = "drop") expect_equal(dim(m), c(2L, 2L)) expect_equal( attr(m, "keptVariantIds"), @@ -3144,10 +1599,10 @@ test_that(".ldFromSketch drops variants absent from the panel when onMissing='dr }) # ============================================================================= -# Additional coverage: .ldFromSketch reconciles chr-prefix conventions +# Additional coverage: .ldFromRef reconciles chr-prefix conventions # ============================================================================= -test_that(".ldFromSketch resolves chr-prefixed request ids against a non-prefixed panel", { +test_that(".ldFromRef matches chr-prefixed ids to a non-prefixed panel", { skip_if_not_installed("pgenlibr") h <- readGenotypeHandle( file.path(geno_test_data_dir, "test_variants"), @@ -3155,13 +1610,13 @@ test_that(".ldFromSketch resolves chr-prefixed request ids against a non-prefixe ) pid <- as.character(snpInfo(h)$SNP) # chr-prefixed (chr21_..._C_G) h@snpInfo$SNP <- sub("^chr", "", pid) # panel now lacks the prefix - m <- pecotmr:::.ldFromSketch(h, pid[1:3]) # request keeps the prefix + m <- pecotmr:::.ldFromRef(h, pid[1:3]) # request keeps the prefix expect_equal(dim(m), c(3L, 3L)) expect_equal(rownames(m), pid[1:3]) # caller's labels preserved expect_equal(unname(diag(m)), c(1, 1, 1)) }) -test_that(".ldFromSketch resolves non-prefixed request ids against a chr-prefixed panel", { +test_that(".ldFromRef matches non-prefixed ids to a chr-prefixed panel", { skip_if_not_installed("pgenlibr") h <- readGenotypeHandle( file.path(geno_test_data_dir, "test_variants"), @@ -3169,24 +1624,24 @@ test_that(".ldFromSketch resolves non-prefixed request ids against a chr-prefixe ) pid <- as.character(snpInfo(h)$SNP) req <- sub("^chr", "", pid[1:3]) # request drops the prefix - m <- pecotmr:::.ldFromSketch(h, req) + m <- pecotmr:::.ldFromRef(h, req) expect_equal(dim(m), c(3L, 3L)) expect_equal(rownames(m), req) # caller's labels preserved }) -test_that(".ldFromSketch is unchanged when request and panel share a convention", { +test_that(".ldFromRef is unchanged when request and panel share a convention", { skip_if_not_installed("pgenlibr") h <- readGenotypeHandle( file.path(geno_test_data_dir, "test_variants"), format = "plink2" ) pid <- as.character(snpInfo(h)$SNP) - m <- pecotmr:::.ldFromSketch(h, pid[1:3]) + m <- pecotmr:::.ldFromRef(h, pid[1:3]) expect_equal(dim(m), c(3L, 3L)) expect_equal(rownames(m), pid[1:3]) }) -test_that(".ldFromSketch still errors on a genuinely-absent variant after reconciliation", { +test_that(".ldFromRef still errors on a variant absent after reconciling", { skip_if_not_installed("pgenlibr") h <- readGenotypeHandle( file.path(geno_test_data_dir, "test_variants"), @@ -3196,29 +1651,29 @@ test_that(".ldFromSketch still errors on a genuinely-absent variant after reconc # request the prefix-stripped form (forces reconciliation) plus one truly-absent variant req <- c(sub("^chr", "", pid[1]), "21_99999999_A_G") expect_error( - pecotmr:::.ldFromSketch(h, req), - "not present in the LD sketch panel" + pecotmr:::.ldFromRef(h, req), + "not present in the LD reference" ) }) -test_that(".ldFromSketch rejects an ldSketch that is not a genotype panel", { +test_that(".ldFromRef rejects an ldReference that is not a genotype panel", { expect_error( - pecotmr:::.ldFromSketch( + pecotmr:::.ldFromRef( "not_a_handle", c("chr1:100:A:G", "chr1:200:A:G") ), - "ldSketch must be a genotype panel" + "ldReference must be a genotype panel" ) }) -# A synthetic panel + dosage extractor, so the shape of what .ldFromSketch +# A synthetic panel + dosage extractor, so the shape of what .ldFromRef # returns is checked without a plink2 fixture (and so without pgenlibr). # @noRd .lds_makeHandle <- function(snpN = 6L, nSamples = 30L) { new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snpN)), CHR = rep("1", snpN), @@ -3272,21 +1727,21 @@ test_that(".ldFromSketch rejects an ldSketch that is not a genotype panel", { } } -test_that(".ldFromSketch returns a symmetric unit-diagonal LD matrix", { +test_that(".ldFromRef returns a symmetric unit-diagonal LD matrix", { h <- .lds_makeHandle() local_mocked_bindings( extractBlockGenotypes = .lds_mockExtractor(), .package = "pecotmr" ) ids <- c("chr1:200:A:G", "chr1:400:A:G", "chr1:500:A:G") - R <- pecotmr:::.ldFromSketch(h, ids) + R <- pecotmr:::.ldFromRef(h, ids) expect_true(is.matrix(R)) expect_equal(dimnames(R), list(ids, ids)) expect_equal(unname(diag(R)), rep(1, 3), tolerance = 1e-12) expect_equal(R, t(R), tolerance = 1e-12) }) -test_that(".ldFromSketch negates LD for a variant the panel spells flipped", { +test_that(".ldFromRef negates LD for a variant the panel spells flipped", { # The panel carries A/G; asking for the same variant as G/A is the same # variant read off the other allele, so every correlation it takes part in # changes sign while the diagonal stays 1. Before the sign was applied the @@ -3299,8 +1754,8 @@ test_that(".ldFromSketch negates LD for a variant the panel spells flipped", { ) same <- c("chr1:200:A:G", "chr1:400:A:G", "chr1:500:A:G") flipped <- c("chr1:200:G:A", "chr1:400:A:G", "chr1:500:A:G") - rSame <- pecotmr:::.ldFromSketch(h, same) - rFlip <- pecotmr:::.ldFromSketch(h, flipped) + rSame <- pecotmr:::.ldFromRef(h, same) + rFlip <- pecotmr:::.ldFromRef(h, flipped) sgn <- c(-1, 1, 1) expect_equal( unname(rFlip), @@ -3311,7 +1766,7 @@ test_that(".ldFromSketch negates LD for a variant the panel spells flipped", { expect_equal(dimnames(rFlip), list(flipped, flipped)) }) -test_that(".ldFromSketch leaves LD untouched when every allele agrees", { +test_that(".ldFromRef leaves LD untouched when every allele agrees", { h <- .lds_makeHandle() local_mocked_bindings( extractBlockGenotypes = .lds_mockExtractor(), @@ -3319,27 +1774,27 @@ test_that(".ldFromSketch leaves LD untouched when every allele agrees", { ) ids <- c("chr1:200:A:G", "chr1:400:A:G") expect_equal( - pecotmr:::.ldFromSketch(h, ids), - pecotmr:::.ldFromSketch(h, ids), + pecotmr:::.ldFromRef(h, ids), + pecotmr:::.ldFromRef(h, ids), tolerance = 1e-12 ) }) -test_that(".ldFromSketch errors on a variant the panel does not carry", { +test_that(".ldFromRef errors on a variant the panel does not carry", { h <- .lds_makeHandle() expect_error( - pecotmr:::.ldFromSketch(h, c("chr1:100:A:G", "ghost")), - "variant id.*not present in the LD sketch" + pecotmr:::.ldFromRef(h, c("chr1:100:A:G", "ghost")), + "variant id.*not present in the LD reference" ) }) # ============================================================================= -# Additional coverage: .requireMatchingLdSketches error paths +# Additional coverage: .requireMatchingLdRefs error paths # ============================================================================= -test_that(".requireMatchingLdSketches errors when slots are not GenotypeHandle", { +test_that(".requireMatchingLdRefs errors when slots are not GenotypeHandle", { expect_error( - pecotmr:::.requireMatchingLdSketches( + pecotmr:::.requireMatchingLdRefs( list(a = 1), list(b = 2), "testPipeline" @@ -3348,7 +1803,7 @@ test_that(".requireMatchingLdSketches errors when slots are not GenotypeHandle", ) }) -test_that(".requireMatchingLdSketches errors on swapped alleles", { +test_that(".requireMatchingLdRefs errors on swapped alleles", { skip_if_not_installed("pgenlibr") h <- readGenotypeHandle( file.path(geno_test_data_dir, "test_variants"), @@ -3369,12 +1824,12 @@ test_that(".requireMatchingLdSketches errors on swapped alleles", { chromPaths = character(0) ) expect_error( - pecotmr:::.requireMatchingLdSketches(h, h2, "testPipeline"), + pecotmr:::.requireMatchingLdRefs(h, h2, "testPipeline"), "swapped A1/A2" ) }) -test_that(".requireMatchingLdSketches accepts panels trimmed differently", { +test_that(".requireMatchingLdRefs accepts panels trimmed differently", { # The reported bug: one LD sketch shared by a QtlSumStats and a # GwasSumStats, each trimmed by its own summaryStatsQc to a different # surviving variant set. The panels overlap but are not identical. @@ -3390,7 +1845,7 @@ test_that(".requireMatchingLdSketches accepts panels trimmed differently", { new( "GenotypeHandle", path = "/tmp/x", - format = "gds", + format = "plink2", snpInfo = si[rows, , drop = FALSE], nSamples = 3L, sampleIds = str_c("s", 1:3), @@ -3400,7 +1855,7 @@ test_that(".requireMatchingLdSketches accepts panels trimmed differently", { } expect_warning( expect_null( - pecotmr:::.requireMatchingLdSketches( + pecotmr:::.requireMatchingLdRefs( mk(1:3), mk(2:4), "trimPipelineA" @@ -3410,7 +1865,7 @@ test_that(".requireMatchingLdSketches accepts panels trimmed differently", { ) }) -test_that(".requireMatchingLdSketches errors when panels share no variant", { +test_that(".requireMatchingLdRefs errors when panels share no variant", { mkSi <- function(bp) { data.frame( SNP = str_c("1:", bp, ":A:G"), @@ -3425,7 +1880,7 @@ test_that(".requireMatchingLdSketches errors when panels share no variant", { new( "GenotypeHandle", path = "/tmp/x", - format = "gds", + format = "plink2", snpInfo = mkSi(bp), nSamples = 3L, sampleIds = str_c("s", 1:3), @@ -3434,7 +1889,7 @@ test_that(".requireMatchingLdSketches errors when panels share no variant", { ) } expect_error( - pecotmr:::.requireMatchingLdSketches( + pecotmr:::.requireMatchingLdRefs( mk(c(100, 200)), mk(c(900, 950)), "disjointPipeline" @@ -3443,7 +1898,7 @@ test_that(".requireMatchingLdSketches errors when panels share no variant", { ) }) -test_that(".requireMatchingLdSketches errors on a different sample set", { +test_that(".requireMatchingLdRefs errors on a different sample set", { si <- data.frame( SNP = "1:100:A:G", CHR = "1", @@ -3456,7 +1911,7 @@ test_that(".requireMatchingLdSketches errors on a different sample set", { new( "GenotypeHandle", path = "/tmp/x", - format = "gds", + format = "plink2", snpInfo = si, nSamples = length(ids), sampleIds = ids, @@ -3465,7 +1920,7 @@ test_that(".requireMatchingLdSketches errors on a different sample set", { ) } expect_error( - pecotmr:::.requireMatchingLdSketches( + pecotmr:::.requireMatchingLdRefs( mk(str_c("s", 1:3)), mk(str_c("t", 1:3)), "samplePipeline" @@ -3474,7 +1929,7 @@ test_that(".requireMatchingLdSketches errors on a different sample set", { ) }) -test_that(".requireMatchingLdSketches tolerates a chr-prefix-only difference", { +test_that(".requireMatchingLdRefs tolerates a chr-prefix-only difference", { si1 <- data.frame( SNP = c("1:100:A:G", "1:200:C:T"), CHR = c("1", "1"), @@ -3490,7 +1945,7 @@ test_that(".requireMatchingLdSketches tolerates a chr-prefix-only difference", { new( "GenotypeHandle", path = "/tmp/x", - format = "gds", + format = "plink2", snpInfo = si, nSamples = 3L, sampleIds = paste0("s", 1:3), @@ -3499,103 +1954,8 @@ test_that(".requireMatchingLdSketches tolerates a chr-prefix-only difference", { ) } expect_null( - pecotmr:::.requireMatchingLdSketches(mk(si1), mk(si2), "testPipeline") - ) -}) - - -# ============================================================================= -# Additional coverage: loadLdFromBlocks empty-block handling -# ============================================================================= - -test_that("loadLdFromBlocks drops empty blocks and keeps non-empty ones", { - meta_file <- file.path(geno_test_data_dir, "ld_meta_emptyblock_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - lines <- c( - paste("chrom", "start", "end", "path", sep = "\t"), - paste( - "1", - "1000", - "1200", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.bim", - sep = "\t" - ), - paste( - "1", - "1200", - "1400", - "LD_block_2.chr1_1200_1400.float16.txt.xz,LD_block_2.chr1_1200_1400.float16.bim", - sep = "\t" - ) - ) - writeLines(lines, meta_file) - # Region 1180-1260: block 1 (variants 1000..1160) is empty; block 2 keeps 1200,1240 - expect_message( - result <- pecotmr:::loadLdFromBlocks(meta_file, "chr1:1180-1260"), - "Removing 1 empty LD block" - ) - ids <- variantIds(result) - expect_true(length(ids) >= 1) - expect_true(all(grepl("^chr1:12", ids))) -}) - -test_that("loadLdFromBlocks errors when no block has variants in the region", { - meta_file <- file.path(geno_test_data_dir, "ld_meta_noblockvar_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - lines <- c( - paste("chrom", "start", "end", "path", sep = "\t"), - paste( - "1", - "1000", - "1200", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.bim", - sep = "\t" - ) - ) - writeLines(lines, meta_file) - # Region 1165-1175 falls between block-1 variants 1160 and the next block - expect_error( - pecotmr:::loadLdFromBlocks(meta_file, "chr1:1165-1175"), - "No variants found in any LD block" - ) -}) - -test_that("loadLdFromBlocks derives variance from allele_freq + nSample when variance is NA", { - # 9-column bim with NA variance but a present allele_freq column. - bim_file <- file.path(geno_test_data_dir, "LD_block_1_navar_tmp.bim") - meta_file <- file.path(geno_test_data_dir, "ld_meta_navar_tmp.tsv") - on.exit(unlink(c(bim_file, meta_file)), add = TRUE) - bim_lines <- c( - "1\tchr1:1000_A_G\t0\t1000\tA\tG\tNA\t0.3\t500", - "1\tchr1:1040_A_G\t0\t1040\tA\tG\tNA\t0.4\t500", - "1\tchr1:1080_A_G\t0\t1080\tA\tG\tNA\t0.2\t500", - "1\tchr1:1120_A_G\t0\t1120\tA\tG\tNA\t0.5\t500", - "1\tchr1:1160_A_G\t0\t1160\tA\tG\tNA\t0.15\t500" - ) - writeLines(bim_lines, bim_file) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste( - "1", - "1000", - "1200", - paste0( - "LD_block_1.chr1_1000_1200.float16.txt.xz,", - basename(bim_file) - ), - sep = "\t" - ), - "\n", - file = meta_file, - append = TRUE + pecotmr:::.requireMatchingLdRefs(mk(si1), mk(si2), "testPipeline") ) - - result <- loadLdMatrix(meta_file, "chr1:1000-1190", nSample = 500L) - ref_mcols <- S4Vectors::mcols(variantInfo(result)) - expect_true("variance" %in% names(ref_mcols)) - expect_true(all(!is.na(ref_mcols$variance))) - expect_true(all(ref_mcols$variance > 0)) - expect_equal(ref_mcols$n_nomiss, rep(500, length(ref_mcols$variance))) }) # ============================================================================= @@ -3605,160 +1965,50 @@ test_that("loadLdFromBlocks derives variance from allele_freq + nSample when var test_that("filterVariantsByLdReference with keepIndel=FALSE drops indels", { meta_file <- file.path(geno_test_data_dir, "ld_meta_filtind_tmp.tsv") on.exit(unlink(meta_file), add = TRUE) - lines <- c( - paste("chrom", "start", "end", "path", sep = "\t"), - paste( - "1", - "1000", - "1200", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.bim", - sep = "\t" - ) + writeLines( + c( + paste("chrom", "start", "end", "path", sep = "\t"), + paste("21", "0", "0", "test_variants", sep = "\t") + ), + meta_file + ) + # All three are on the reference panel, but the middle one is an indel. + variant_ids <- c( + "chr21:17513228:C:G", + "chr21:17592874:G:GACTTT", + "chr21:17513580:C:T" ) - writeLines(lines, meta_file) - # All three positions are on the reference panel, but the middle one is an indel. - variant_ids <- c("chr1:1000:A:G", "chr1:1040:AT:A", "chr1:1080:A:G") result <- suppressMessages( filterVariantsByLdReference(variant_ids, meta_file, keepIndel = FALSE) ) - expect_false("chr1:1040:AT:A" %in% result$data) - expect_true("chr1:1000:A:G" %in% result$data) - expect_true("chr1:1080:A:G" %in% result$data) -}) - -# ============================================================================= -# Additional coverage: partitionLdMatrix / validateBlockStructure / extractBlockMatrices -# ============================================================================= - -test_that("partitionLdMatrix accepts LdBlocks blockMetadata", { - variant_ids <- paste0("chr1:", c(100, 200, 300, 400), ":A:G") - R <- diag(4) - rownames(R) <- colnames(R) <- variant_ids - gr_blocks <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(start = c(100, 300), end = c(200, 400)) - ) - S4Vectors::mcols(gr_blocks) <- S4Vectors::DataFrame( - blockId = c(1L, 2L), - chrom = c("1", "1"), - size = c(2L, 2L), - startIdx = c(1L, 3L), - endIdx = c(2L, 4L), - blockStart = c(100L, 300L), - blockEnd = c(200L, 400L) - ) - ldb <- gr_blocks - ref <- pecotmr:::parseVariantId(variant_ids) - ref$variant_id <- variant_ids - gr_vars <- pecotmr:::.refPanelToGranges(ref) - ld <- LdData(correlation = R, variants = gr_vars, blockMetadata = ldb) - result <- pecotmr:::partitionLdMatrix(ld, mergeSmallBlocks = FALSE) - expect_length(result$ldMatrices, 2) - expect_equal(nrow(result$ldMatrices[[1]]), 2L) -}) - -test_that("partitionLdMatrix errors on an empty correlation matrix", { - variant_ids <- "chr1:100:A:G" - ref <- pecotmr:::parseVariantId(variant_ids) - ref$variant_id <- variant_ids - gr <- pecotmr:::.refPanelToGranges(ref) - empty_R <- matrix(numeric(0), 0, 0) - bm <- data.frame( - blockId = 1L, - chrom = "1", - blockStart = 100L, - blockEnd = 100L, - size = 1L, - startIdx = 1L, - endIdx = 1L, - stringsAsFactors = FALSE - ) - ld <- LdData(correlation = empty_R, variants = gr, blockMetadata = bm) - expect_error(pecotmr:::partitionLdMatrix(ld), "Empty or NULL LD matrix") -}) - -test_that("partitionLdMatrix errors when all blocks have invalid indices", { - variant_ids <- paste0("chr1:", c(100, 200, 300), ":A:G") - R <- diag(3) - rownames(R) <- colnames(R) <- variant_ids - ref <- pecotmr:::parseVariantId(variant_ids) - ref$variant_id <- variant_ids - gr <- pecotmr:::.refPanelToGranges(ref) - bm <- data.frame( - blockId = 1L, - chrom = "1", - blockStart = 100L, - blockEnd = 300L, - size = 3L, - startIdx = 10L, - endIdx = 20L, - stringsAsFactors = FALSE - ) - ld <- LdData(correlation = R, variants = gr, blockMetadata = bm) - expect_error(pecotmr:::partitionLdMatrix(ld), "No valid LD blocks found") -}) - -test_that("partitionLdMatrix removes blocks with invalid indices and reindexes", { - variant_ids <- paste0("chr1:", seq(100, 600, by = 100), ":A:G") # 6 variants - R <- diag(6) - rownames(R) <- colnames(R) <- variant_ids - ref <- pecotmr:::parseVariantId(variant_ids) - ref$variant_id <- variant_ids - gr <- pecotmr:::.refPanelToGranges(ref) - bm <- data.frame( - blockId = c(1L, 2L), - chrom = c("1", "1"), - blockStart = c(100L, 400L), - blockEnd = c(300L, 600L), - size = c(3L, 3L), - startIdx = c(1L, 50L), - endIdx = c(3L, 60L), - stringsAsFactors = FALSE - ) - ld <- LdData(correlation = R, variants = gr, blockMetadata = bm) - expect_message( - result <- pecotmr:::partitionLdMatrix(ld, mergeSmallBlocks = FALSE), - "Removing 1 LD block" - ) - expect_length(result$ldMatrices, 1) - expect_equal(nrow(result$ldMatrices[[1]]), 3L) -}) - -test_that("validateBlockStructure flags out-of-range block indices", { - mat <- diag(4) - vnames <- sprintf("chr1:%d:A:G", 100L * (1:4)) - rownames(mat) <- colnames(mat) <- vnames - bm <- data.frame( - blockId = c(1L, 2L), - chrom = c("1", "1"), - size = c(2L, 2L), - startIdx = c(1L, 10L), - endIdx = c(2L, 12L) - ) - expect_error( - pecotmr:::validateBlockStructure(mat, .ld_bmGr(bm), vnames), - "Block indices out of range" - ) -}) - -test_that("extractBlockMatrices skips blocks where endIdx < startIdx", { - mat <- diag(4) - vnames <- sprintf("chr1:%d:A:G", 100L * (1:4)) - rownames(mat) <- colnames(mat) <- vnames - bm <- data.frame( - blockId = c(1L, 2L), - startIdx = c(1L, 3L), - endIdx = c(2L, 2L), - chrom = c("1", "1"), - blockStart = c(1L, 3L), - blockEnd = c(2L, 4L), - size = c(2L, 1L), - stringsAsFactors = FALSE - ) - result <- pecotmr:::extractBlockMatrices(mat, .ld_bmGr(bm), vnames) - valid <- compact(result$ldMatrices) - expect_length(valid, 1) - expect_equal(nrow(valid[[1]]), 2L) + expect_false("chr21:17592874:G:GACTTT" %in% result$data) + expect_true("chr21:17513228:C:G" %in% result$data) + expect_true("chr21:17513580:C:T" %in% result$data) +}) + +test_that("hclust pruning keeps what single-linkage clustering keeps", { + # The groups are found as threshold-graph components a stripe of the + # correlation matrix at a time; 600 columns span three stripes, and the + # AR chains carry LD across their boundaries. + set.seed(9) + n <- 60 + p <- 600 + X <- matrix(0, n, p) + X[, 1] <- rnorm(n) + for (j in 2:p) { + X[, j] <- 0.93 * X[, j - 1] + rnorm(n, sd = 0.4) + } + X[, 400] <- X[, 3] + X[, 401] <- 0 + for (thr in c(0.5, 0.8, 0.95)) { + r <- suppressWarnings(cor(X)) + r[is.na(r)] <- 0 + tree <- hclust(as.dist(1 - abs(r)), method = "single") + want <- which(!duplicated(cutree(tree, h = 1 - thr))) + got <- ldPruneByCorrelation(X, corThres = thr) + expect_equal(got$filter.id, want, label = str_c("corThres ", thr)) + expect_equal(got$X.new, X[, want, drop = FALSE]) + } }) # ============================================================================= @@ -3954,40 +2204,6 @@ test_that("ldClumpByScore accepts a pre-built FBM and reports retained count (ve expect_false(2L %in% keep) }) -# ============================================================================= -# Additional coverage: extractLdMatrix -# ============================================================================= - -test_that("extractLdMatrix errors on non-LdData input", { - expect_error( - pecotmr:::extractLdMatrix(list()), - "Must inherit from class 'LdData'" - ) -}) - -test_that("extractLdMatrix returns the genotype matrix when wantGenotype=TRUE", { - variant_ids <- paste0("chr1:", c(100, 200, 300), ":A:G") - X <- matrix(rnorm(15), 5, 3) - colnames(X) <- variant_ids - ref <- pecotmr:::parseVariantId(variant_ids) - ref$variant_id <- variant_ids - gr <- pecotmr:::.refPanelToGranges(ref) - bm <- data.frame( - blockId = 1L, - chrom = "1", - blockStart = 100L, - blockEnd = 300L, - size = 3L, - startIdx = 1L, - endIdx = 3L, - stringsAsFactors = FALSE - ) - ld <- LdData(genotypeHandle = X, variants = gr, blockMetadata = bm) - result <- pecotmr:::extractLdMatrix(ld, wantGenotype = TRUE) - expect_equal(result, X) -}) - - # ============================================================================= # Additional coverage: computeLd alternative backends + guard rails # ============================================================================= @@ -4020,6 +2236,43 @@ test_that("computeLd snpstats backend returns a valid correlation matrix", { expect_true(all(is.finite(R))) }) +test_that("the genotype-code backends refuse dosages rather than round them", { + # GDS and SnpMatrix hold 2-bit codes: a fractional dosage would be + # rounded and its LD changed, and a 3 would read as missing. + set.seed(1) + X <- matrix(rbinom(100 * 4, 2, 0.3), 100, 4) + dosage <- replace(X, 5L, 0.7) + outOfRange <- replace(X, 7L, 3) + expect_error( + pecotmr:::.ldRequireIntegerGenotypes(dosage, "snpstats", "internal"), + "1 value\\(s\\) here are not one of them" + ) + expect_error( + pecotmr:::.ldRequireIntegerGenotypes(outOfRange, "snpstats", "x"), + "not one of them" + ) + expect_true(pecotmr:::.ldRequireIntegerGenotypes( + replace(X, 3L, NA), + "snpstats", + "internal" + )) + skip_if_not_installed("snpStats") + expect_error( + computeLd(dosage, backend = "snpstats"), + "Use backend = \"internal\"" + ) + skip_if_not_installed("SNPRelate") + skip_if_not_installed("gdsfmt") + expect_error( + computeLd(dosage, backend = "snprelate"), + "backend = \"snprelate\" stores genotypes" + ) + expect_error( + ldPruneByCorrelation(dosage, backend = "snprelate"), + "Use backend = \"hclust\"" + ) +}) + test_that("computeLd errors when a non-internal backend is paired with non-sample method", { set.seed(1) X <- matrix(rbinom(100 * 3, 2, 0.3), 100, 3) @@ -4122,23 +2375,22 @@ test_that(".panelVariantStats reports NA MAF for an all-missing variant", { test_that(".panelVariantFilter is a no-op at its defaults", { data(qtlDatasetExample) - gh <- genotypes(qtlDatasetExample) - handle <- genotypeHandle(qtlDatasetExample) - ids <- normalizeVariantId(snpInfo(handle)$SNP) - expect_identical(.panelVariantFilter(handle, ids), ids) + panel <- pecotmr:::.qtlGenotypeSe(qtlDatasetExample) + ids <- rownames(panel) + expect_identical(.panelVariantFilter(panel, ids), ids) }) test_that(".panelVariantFilter drops panel-rare variants", { data(qtlDatasetExample) - handle <- genotypeHandle(qtlDatasetExample) - ids <- normalizeVariantId(snpInfo(handle)$SNP) + panel <- pecotmr:::.qtlGenotypeSe(qtlDatasetExample) + ids <- rownames(panel) loose <- .panelVariantFilter( - handle, + panel, ids, PanelFilterParam(mafCutoff = 0.05) ) tight <- .panelVariantFilter( - handle, + panel, ids, PanelFilterParam(mafCutoff = 0.2) ) @@ -4151,17 +2403,17 @@ test_that(".panelVariantFilter drops panel-rare variants", { test_that(".panelVariantFilter treats MAC as a MAF equivalent", { data(qtlDatasetExample) - handle <- genotypeHandle(qtlDatasetExample) - ids <- normalizeVariantId(snpInfo(handle)$SNP) - nSamp <- nSamples(handle) + panel <- pecotmr:::.qtlGenotypeSe(qtlDatasetExample) + ids <- rownames(panel) + nSamp <- ncol(panel) # macCutoff / (2 * nSamples) is the same threshold as mafCutoff. byMac <- .panelVariantFilter( - handle, + panel, ids, PanelFilterParam(macCutoff = 0.1 * 2 * nSamp) ) byMaf <- .panelVariantFilter( - handle, + panel, ids, PanelFilterParam(mafCutoff = 0.1) ) @@ -4169,43 +2421,43 @@ test_that(".panelVariantFilter treats MAC as a MAF equivalent", { # The stricter of the two wins. expect_identical( .panelVariantFilter( - handle, + panel, ids, PanelFilterParam(mafCutoff = 0.2, macCutoff = 2) ), - .panelVariantFilter(handle, ids, PanelFilterParam(mafCutoff = 0.2)) + .panelVariantFilter(panel, ids, PanelFilterParam(mafCutoff = 0.2)) ) }) test_that(".panelVariantFilter drops high-missingness variants", { data(qtlDatasetExample) - handle <- genotypeHandle(qtlDatasetExample) - ids <- normalizeVariantId(snpInfo(handle)$SNP) + panel <- pecotmr:::.qtlGenotypeSe(qtlDatasetExample) + ids <- rownames(panel) strict <- .panelVariantFilter( - handle, + panel, ids, PanelFilterParam(imissCutoff = 0) ) expect_lt(length(strict), length(ids)) # A cutoff above the panel's worst variant keeps everything. expect_identical( - .panelVariantFilter(handle, ids, PanelFilterParam(imissCutoff = 1)), + .panelVariantFilter(panel, ids, PanelFilterParam(imissCutoff = 1)), ids ) }) test_that(".panelVariantFilter passes through ids absent from the panel", { # Whether a missing variant is an error or is dropped belongs to - # .ldFromSketch's `onMissing`; deciding it here too would let the two + # .ldFromRef's `onMissing`; deciding it here too would let the two # disagree about the same variant. data(qtlDatasetExample) - handle <- genotypeHandle(qtlDatasetExample) - ids <- normalizeVariantId(snpInfo(handle)$SNP)[1:3] + panel <- pecotmr:::.qtlGenotypeSe(qtlDatasetExample) + ids <- rownames(panel)[1:3] withGhost <- c("chr9:999:A:G", ids) expect_true(is_in( "chr9:999:A:G", .panelVariantFilter( - handle, + panel, withGhost, PanelFilterParam(mafCutoff = 0.001) ) @@ -4214,10 +2466,10 @@ test_that(".panelVariantFilter passes through ids absent from the panel", { test_that(".panelVariantFilter handles empty and NULL input", { data(qtlDatasetExample) - handle <- genotypeHandle(qtlDatasetExample) + panel <- pecotmr:::.qtlGenotypeSe(qtlDatasetExample) expect_length( .panelVariantFilter( - handle, + panel, character(0), PanelFilterParam(mafCutoff = 0.1) ), @@ -4233,7 +2485,6 @@ test_that(".panelVariantFilter handles empty and NULL input", { ) }) - test_that(".panelCutoffs short-circuits when no cutoff is set", { # NULL means the panel is never touched, which is what keeps the default # path free of an extra dosage read. @@ -4253,7 +2504,6 @@ test_that(".panelCutoffs short-circuits when no cutoff is set", { ) }) - # --------------------------------------------------------------------------- # .panelVariantFilter: the .afreq fast path # @@ -4268,29 +2518,41 @@ test_that(".panelCutoffs short-circuits when no cutoff is set", { readGenotypeHandle(test_path("test_data/test_variants"), format = "plink2") } +# .panelAfreqMaf() for an LD reference -- a panel or a bare handle: its +# genotype source and chromosomes. +# @noRd +.pvfAfreqMaf <- function(ref, ids) { + .panelAfreqMaf( + pecotmr:::.ldRefSource(ref), + pecotmr:::.ldRefChrom(ref), + ids + ) +} + test_that(".panelAfreqMaf reads panel MAF from the .afreq sidecar", { skip_if_not_installed("pgenlibr") handle <- .pvfAfreqHandle() ids <- as.character(snpInfo(handle)$SNP) - maf <- .panelAfreqMaf(handle, ids) + maf <- .pvfAfreqMaf(handle, ids) afreq <- readAfreq(test_path("test_data/test_variants")) altFreq <- afreq$alt_freq[match(ids, afreq$id)] expect_equal(maf, pmin(altFreq, 1 - altFreq)) }) -test_that(".panelAfreqMaf refuses a partial or non-plink2 sidecar", { +test_that(".panelAfreqMaf refuses a partial sidecar and reads any format's", { skip_if_not_installed("pgenlibr") handle <- .pvfAfreqHandle() ids <- as.character(snpInfo(handle)$SNP) # One id the sidecar cannot answer for is enough: a partial answer would # disagree with the dosage path about that variant, so NULL sends the # caller down the dosage path for all of them. - expect_null(.panelAfreqMaf(handle, c(ids, "not-a-panel-variant"))) - bed <- readGenotypeHandle( - test_path("test_data/test_variants"), - format = "plink1" - ) - expect_null(.panelAfreqMaf(bed, as.character(snpInfo(bed)$SNP))) + expect_null(.pvfAfreqMaf(handle, c(ids, "not-a-panel-variant"))) + # The sidecar is the file's, not the format's: the PLINK1 fileset beside + # the same .afreq reads the same frequencies. + skip_if_not_installed("PlinkMatrix") + bed <- readGenotypes(plink1Prefix = test_path("test_data/test_variants")) + bedIds <- as.character(SummarizedExperiment::rowRanges(bed)$SNP) + expect_equal(.pvfAfreqMaf(bed, bedIds), .pvfAfreqMaf(handle, bedIds)) }) test_that(".panelVariantFilter: .afreq and dosage agree on what to drop", { @@ -4304,7 +2566,7 @@ test_that(".panelVariantFilter: .afreq and dosage agree on what to drop", { ) # Force the dosage path by hiding the sidecar from the fast path. local_mocked_bindings( - .panelAfreqMaf = function(handle, variantIds) NULL, + .panelAfreqMaf = function(source, chroms, variantIds) NULL, .package = "pecotmr" ) viaDosage <- .panelVariantFilter( @@ -4337,160 +2599,34 @@ test_that(".panelVariantFilter uses dosage whenever missingness is capped", { ) }) -test_that(".panelAfreqPrefixes reads only the chromosomes the panel spans", { +test_that(".afreqPrefixes reads only the chromosomes the panel spans", { handle <- .pvfAfreqHandle() + source <- pecotmr:::.genotypeSourceRecord(handle) # Single-file panel: its own stem, resolved for file access. expect_identical( - .panelAfreqPrefixes(handle), + .afreqPrefixes(source, snpInfo(handle)$CHR), pecotmr:::.genotypeReadPath(handle) ) - # Sharded panel: a manifest chromosome the snpInfo does not span is not + # Sharded panel: a manifest chromosome the panel does not span is not # read -- the cost per-chromosome sketch trimming exists to avoid. - sharded <- handle - sharded@chromPaths <- c( - "22" = path(handle), - "21" = "/nonexistent/chr21" - ) - sharded@snpInfo$CHR <- rep("22", nrow(snpInfo(handle))) - expect_identical(.panelAfreqPrefixes(sharded), path(handle)) -}) - - -# ============================================================================= -# loadLdMatrix: coordinate-free sources and per-block options -# -# These cover what ldLoader() / loadLdBlock() / loadLdSketch() used to do, -# now folded into the single loader. Every source returns an LdData, which is -# the point of the consolidation -- callers no longer branch on what they -# loaded from. -# ============================================================================= - -test_that("loadLdMatrix requires exactly one addressing mode", { - R <- matrix(c(1, 0.5, 0.5, 1), 2, 2) - expect_error(loadLdMatrix(R), "either `region` or `block`") - expect_error( - loadLdMatrix(R, region = "chr1:1-2", block = 1), - "not both" - ) - # A coordinate-free source cannot be addressed by region. - expect_error(loadLdMatrix(R, region = "chr1:1-2"), "addressed with `block`") -}) - -test_that("loadLdMatrix loads an in-memory correlation matrix by block", { - R1 <- matrix(c(1, 0.3, 0.3, 1), 2, 2) - R2 <- matrix(c(1, 0.8, 0.8, 1), 2, 2) - expect_equal(unname(ldMatrix(loadLdMatrix(R1, block = 1))), R1) - expect_equal( - unname(ldMatrix(loadLdMatrix(list(R1, R2), block = 2))), - R2 - ) -}) - -test_that("loadLdMatrix treats a tall matrix as genotypes", { - X <- matrix(rnorm(40), 10, 4) - ld <- loadLdMatrix(X, block = 1) - expect_true(hasGenotypes(ld)) - expect_equal(length(ld), 4L) -}) - -test_that("loadLdMatrix subsamples oversized blocks reproducibly", { - R <- matrix(0.1, 10, 10) - diag(R) <- 1 - small <- loadLdMatrix(R, block = 1, maxVariants = 5, seed = 42) - expect_equal(length(small), 5L) - expect_equal(dim(ldMatrix(small)), c(5L, 5L)) - # Same seed, same draw. - again <- loadLdMatrix(R, block = 1, maxVariants = 5, seed = 42) - expect_equal(variantIds(small), variantIds(again)) - # A cap above the block size is a no-op. - expect_equal(length(loadLdMatrix(R, block = 1, maxVariants = 100)), 10L) -}) - -test_that("loadLdMatrix reads an ldInfo table by block", { - skip_if_not_installed("pgenlibr") - ldInfo <- data.frame( - LD_file = file.path(test_path("test_data"), "test_variants") + sharded <- list_assign( + source, + chromPaths = c("22" = path(handle), "21" = "/nonexistent/chr21") ) - ld <- loadLdMatrix(ldInfo, block = 1) - expect_s4_class(ld, "LdData") - expect_equal(length(ld), 349L) -}) - -test_that("loadLdMatrix validates an ldInfo table", { - expect_error( - loadLdMatrix(data.frame(col1 = "a"), block = 1), - "needs an `LD_file` column" - ) -}) - -test_that("loadLdMatrix takes a vector of regions", { - meta <- system.file( - "extdata", - "ld_reference", - "ld_meta_file.tsv", - package = "pecotmr" - ) - region <- "chr22:10000000-19000000" - many <- loadLdMatrix(meta, region = c(region, region)) - expect_type(many, "list") - expect_length(many, 2L) - expect_s4_class(many[[1]], "LdData") - expect_equal(length(many[[1]]), length(many[[2]])) -}) - -test_that("loadLdMatrix can materialize genotypes onto the object", { - meta <- system.file( - "extdata", - "ld_reference", - "ld_meta_file.tsv", - package = "pecotmr" - ) - region <- "chr22:10000000-19000000" - lazy <- loadLdMatrix(meta, region = region, returnGenotype = TRUE) - eager <- loadLdMatrix( - meta, - region = region, - returnGenotype = TRUE, - materializeGenotypes = TRUE - ) - # Same data; the difference is whether later access re-reads the file. - expect_s4_class(genotypeHandle(lazy), "GenotypeHandle") - expect_true(is.matrix(genotypeHandle(eager))) - expect_equal(genotypes(lazy), genotypes(eager)) -}) - -test_that("loadLdMatrix can drop monomorphic variants", { - meta <- system.file( - "extdata", - "ld_reference", - "ld_meta_file.tsv", - package = "pecotmr" - ) - region <- "chr22:10000000-19000000" - full <- loadLdMatrix(meta, region = region, returnGenotype = TRUE) - kept <- loadLdMatrix( - meta, - region = region, - returnGenotype = TRUE, - dropMonomorphic = TRUE - ) - # This panel has no monomorphic variants, so the filter is a no-op here; - # what matters is that it does not drop polymorphic ones. - expect_lte(length(kept), length(full)) - af <- refPanel(kept)$allele_freq - expect_true(all(af > 0 & af < 1)) + expect_identical(.afreqPrefixes(sharded, "22"), path(handle)) + # A panel held in memory reads no sidecar. + expect_identical(.afreqPrefixes(NULL, "22"), character(0)) }) - # ============================================================================= # One failure mode for a missing or invalid LD sketch # -# Panel access happens through several routes: the shared `.ldFromSketch()`, +# Panel access happens through several routes: the shared `.ldFromRef()`, # ctwas's whole-panel assembler, RAiSS's coordinate window, and the bare # accessors. They used to disagree on what a bad sketch looked like -- the # shared path said so plainly while the others surfaced "unable to find an # inherited method for 'snpInfo'" from whichever accessor touched it -# first. The guard now sits at `.ldSketchRanges()` / `.ldSketchDosage()`, the +# first. The guard now sits at `.ldRefRanges()` / `.ldRefDosage()`, the # two primitives everything funnels through. # ============================================================================= @@ -4502,22 +2638,22 @@ test_that("every panel access route rejects a NULL sketch the same way", { ) routes <- list( shared = function() { - pecotmr:::.ldFromSketch(NULL, "chr22:1:A:G", label = "demo") + pecotmr:::.ldFromRef(NULL, "chr22:1:A:G", label = "demo") }, ctwas = function() pecotmr:::.ctwasPanelFor(NULL), raiss = function() pecotmr:::.qcRaissWindowIdx(df, NULL, 0L), - matchIds = function() pecotmr:::.ldSketchMatchIds(NULL), - dosage = function() pecotmr:::.ldSketchDosage(NULL, 1L), - ranges = function() pecotmr:::.ldSketchRanges(NULL) + matchIds = function() pecotmr:::.ldRefMatchIds(NULL), + dosage = function() pecotmr:::.ldRefDosage(NULL, 1L), + ranges = function() pecotmr:::.ldRefRanges(NULL) ) for (nm in names(routes)) { - expect_error(routes[[nm]](), "carries no ldSketch", info = nm) + expect_error(routes[[nm]](), "carries no ldReference", info = nm) } }) test_that("a non-panel sketch is rejected by every route", { expect_error( - pecotmr:::.ldSketchRanges("not a panel"), + pecotmr:::.ldRefRanges("not a panel"), "must be a genotype panel" ) expect_error( @@ -4525,7 +2661,7 @@ test_that("a non-panel sketch is rejected by every route", { "must be a genotype panel" ) expect_error( - pecotmr:::.ldSketchDosage("not a panel", 1L), + pecotmr:::.ldRefDosage("not a panel", 1L), "must be a genotype panel" ) }) @@ -4533,7 +2669,7 @@ test_that("a non-panel sketch is rejected by every route", { test_that("callers that validate first keep their own label", { # The generic guard must not mask a caller's more specific message. shared <- tryCatch( - pecotmr:::.ldFromSketch(NULL, "x", label = "fineMappingPipeline"), + pecotmr:::.ldFromRef(NULL, "x", label = "fineMappingPipeline"), error = conditionMessage ) expect_match(shared, "^fineMappingPipeline:") @@ -4545,7 +2681,7 @@ test_that("callers that validate first keep their own label", { }) test_that("panel identity uses the allele-repaired ids for comparison", { - # `.ldSketchMatchIds()` repairs an id whose allele fields are tags rather + # `.ldRefMatchIds()` repairs an id whose allele fields are tags rather # than DNA, filling them from the panel's A1/A2 mcols; that repaired form # is what every comparison against sumstats or weights uses. repaired <- pecotmr:::.repairVariantIds( @@ -4559,19 +2695,18 @@ test_that("panel identity uses the allele-repaired ids for comparison", { dna <- c("chr1:100:A:G") expect_equal(pecotmr:::.repairVariantIds(dna, A2 = "C", A1 = "T"), dna) - # And an rsID panel passes through unchanged -- `.ldFromSketchMatch()` + # And an rsID panel passes through unchanged -- `.ldFromRefMatch()` # falls back to exact id matching for those, so rewriting them would # break the match rather than fix it. panel <- readGenotypes( system.file("extdata", "toy_ref.bed", package = "pecotmr") ) expect_equal( - pecotmr:::.ldSketchMatchIds(panel), - pecotmr:::.ldSketchVariantIds(panel) + pecotmr:::.ldRefMatchIds(panel), + pecotmr:::.ldRefVariantIds(panel) ) }) - # =========================================================================== # Sketch accessors and per-variant panel statistics # =========================================================================== @@ -4579,8 +2714,8 @@ test_that("panel identity uses the allele-repaired ids for comparison", { test_that("the sketch accessors are NULL-safe", { # A collection with no LD sketch is a legitimate state (individual-level # inputs), so these answer NULL rather than erroring. - expect_null(pecotmr:::.ldSketchHandle(NULL)) - expect_null(pecotmr:::.ldSketchSubset(NULL, 1L)) + expect_null(pecotmr:::.ldRefHandle(NULL)) + expect_null(pecotmr:::.ldRefSubset(NULL, 1L)) }) test_that("panel statistics report zero missingness for a sample-less panel", { @@ -4598,7 +2733,6 @@ test_that("panel allele frequencies are computed per variant", { expect_equal(st$maf, pmin(st$af, 1 - st$af)) }) - test_that("panel variant filtering is a no-op without a panel or variants", { # Both early exits return the caller's ids unchanged: with no panel there # is nothing to filter against, and with no variants nothing to filter. @@ -4612,7 +2746,6 @@ test_that("panel variant filtering is a no-op without a panel or variants", { ) }) - # =========================================================================== # Empty sketches, the .afreq fast path, and design rank # =========================================================================== @@ -4621,11 +2754,11 @@ test_that("emptying a sketch clears both axes", { # An emptied sketch references no LD, so its sample axis is dead weight; # nSamples must go to 0 alongside sampleIds or the derived dosage # dimnames would disagree with the matrix. - expect_null(pecotmr:::.emptySketch(NULL)) + expect_null(pecotmr:::.emptyLdRef(NULL)) h <- new( "GenotypeHandle", - path = "/tmp/x.gds", - format = "gds", + path = "/tmp/x", + format = "plink2", snpInfo = data.frame( SNP = c("a", "b"), CHR = "1", @@ -4639,7 +2772,7 @@ test_that("emptying a sketch clears both axes", { sampleIds = c("s1", "s2"), pgenPtr = NULL ) - e <- pecotmr:::.emptySketch(h) + e <- pecotmr:::.emptyLdRef(h) expect_equal(nrow(pecotmr:::snpInfo(e)), 0L) expect_equal(length(pecotmr:::sampleIds(e)), 0L) }) @@ -4650,8 +2783,8 @@ test_that("a missing or malformed afreq sidecar degrades to no frequencies", { expect_null(pecotmr:::.panelAfreqTable("/nonexistent/prefix")) h <- new( "GenotypeHandle", - path = "/tmp/x.gds", - format = "gds", + path = "/tmp/x", + format = "plink2", snpInfo = data.frame( SNP = c("a", "b"), CHR = "1", @@ -4665,8 +2798,8 @@ test_that("a missing or malformed afreq sidecar degrades to no frequencies", { sampleIds = c("s1", "s2"), pgenPtr = NULL ) - # The fast path is plink2-only. - expect_null(pecotmr:::.panelAfreqMaf(h, c("a", "b"))) + # No sidecar beside the file: nothing to read, in any format. + expect_null(.pvfAfreqMaf(h, c("a", "b"))) }) test_that("collinear design columns are reported, full-rank ones are not", { @@ -4694,50 +2827,10 @@ test_that("computeLd refuses snpIdx against an already-materialized block", { ) }) - # =========================================================================== # Block-indexed sources and LdData subsetting # =========================================================================== -test_that("a block-indexed source must be addressable by block", { - # `block` only means something for a meta file, an ldInfo frame, a matrix - # or a list of them; anything else is refused rather than silently - # returning the wrong block. - expect_error( - pecotmr:::.loadLdFromIndexed("a string", 1L), - "cannot address a character by block" - ) -}) - -test_that("a matrix and a list of matrices both address by block", { - R <- diag(3) - dimnames(R) <- list(c("v1", "v2", "v3"), c("v1", "v2", "v3")) - expect_s4_class(pecotmr:::.loadLdFromIndexed(R, 1L), "LdData") - # The list form picks the requested element. - both <- pecotmr:::.loadLdFromIndexed(list(R, R), 2L) - expect_s4_class(both, "LdData") - expect_equal(length(both), 3L) -}) - -test_that("materializing genotypes is a no-op without genotypes to read", { - # Both exits return the LdData untouched: not requested, and requested - # but the source is a correlation matrix with nothing to materialize. - R <- diag(3) - dimnames(R) <- list(c("v1", "v2", "v3"), c("v1", "v2", "v3")) - ld <- pecotmr:::.ldDataFromMatrix(R, isGenotype = FALSE) - expect_identical(pecotmr:::.ldApplyMaterialize(ld, FALSE), ld) - expect_identical(pecotmr:::.ldApplyMaterialize(ld, TRUE), ld) -}) - -test_that("subsetting an LdData narrows the correlation on both axes", { - R <- diag(3) - dimnames(R) <- list(c("v1", "v2", "v3"), c("v1", "v2", "v3")) - ld <- pecotmr:::.ldDataFromMatrix(R, isGenotype = FALSE) - out <- pecotmr:::.ldSubsetData(ld, c(1L, 3L)) - expect_equal(length(out), 2L) - expect_equal(dim(ldMatrix(out)), c(2L, 2L)) -}) - # --------------------------------------------------------------------------- # LdData narrowing and materialization: each genotype source shape (matrix, # handle + snpIdx, mixture list) narrows differently, and only the matrix @@ -4769,8 +2862,8 @@ test_that("subsetting an LdData narrows the correlation on both axes", { .ldcov_handle <- function() { new( "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", + path = "/tmp/test", + format = "plink2", snpInfo = data.frame(), nSamples = 0L, sampleIds = character(), @@ -4778,107 +2871,7 @@ test_that("subsetting an LdData narrows the correlation on both axes", { ) } -test_that(".loadLdDedup passes through when there are no variant ids", { - # A GRanges with no variant_id column: variantIds() is NULL, so there - # is nothing to deduplicate against. - bare <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(c(100, 200, 300), width = 1) - ) - ld <- LdData( - correlation = diag(3), - variants = bare, - blockMetadata = .ldcov_bm(3L) - ) - expect_null(variantIds(ld)) - expect_identical(pecotmr:::.loadLdDedup(ld), ld) -}) - -test_that(".ldApplyMonomorphic keeps an all-polymorphic block unchanged", { - v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") - ld <- LdData( - correlation = diag(3), - variants = .ldcov_gr(v, af = c(0.2, 0.3, 0.4)), - blockMetadata = .ldcov_bm(3L) - ) - # Every allele_freq is strictly inside (0, 1), so no subset is taken. - expect_identical(pecotmr:::.ldApplyMonomorphic(ld, TRUE), ld) -}) - -test_that(".ldApplyMonomorphic needs an allele_freq column to act", { - v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") - ld <- LdData( - correlation = diag(3), - variants = .ldcov_gr(v), - blockMetadata = .ldcov_bm(3L) - ) - # No frequencies to judge monomorphism by, so the request is a no-op - # rather than an error -- distinct from the all-polymorphic case. - expect_false(is_in("allele_freq", colnames(refPanel(ld)))) - expect_identical(pecotmr:::.ldApplyMonomorphic(ld, TRUE), ld) -}) - -test_that(".ldApplyMonomorphic drops monomorphic variants", { - v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") - ld <- LdData( - correlation = diag(3), - variants = .ldcov_gr(v, af = c(0.2, 0.0, 0.4)), - blockMetadata = .ldcov_bm(3L) - ) - out <- pecotmr:::.ldApplyMonomorphic(ld, TRUE) - expect_equal(variantIds(out), c("chr1:100:A:G", "chr1:300:G:A")) - expect_equal(dim(ldMatrix(out)), c(2L, 2L)) -}) - -test_that(".ldApplyMaterialize leaves a mixture list alone", { - v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") - m1 <- matrix(0, nrow = 4L, ncol = 3L, dimnames = list(NULL, v)) - m2 <- matrix(1, nrow = 4L, ncol = 3L, dimnames = list(NULL, v)) - ld <- LdData( - correlation = NULL, - genotypeHandle = list(m1, m2), - mixtureWeights = c(0.5, 0.5), - variants = .ldcov_gr(v), - blockMetadata = .ldcov_bm(3L) - ) - # genotypes() on a mixture returns a LIST of dosage matrices; there is - # no single matrix to fold into the object. - expect_false(is.matrix(genotypes(ld))) - expect_identical(pecotmr:::.ldApplyMaterialize(ld, TRUE), ld) -}) - -test_that(".ldSubsetData narrows a dosage matrix by column", { - v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") - m <- matrix(0, nrow = 4L, ncol = 3L, dimnames = list(NULL, v)) - ld <- LdData( - correlation = NULL, - genotypeHandle = m, - snpIdx = NULL, - variants = .ldcov_gr(v), - blockMetadata = .ldcov_bm(3L) - ) - out <- pecotmr:::.ldSubsetData(ld, c(1L, 3L)) - expect_equal(dim(pecotmr:::genotypeHandle(out)), c(4L, 2L)) - expect_equal(variantIds(out), c("chr1:100:A:G", "chr1:300:G:A")) -}) - -test_that(".ldSubsetData narrows a handle through snpIdx", { - v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") - ld <- LdData( - correlation = NULL, - genotypeHandle = .ldcov_handle(), - snpIdx = c(5L, 6L, 7L), - variants = .ldcov_gr(v), - blockMetadata = .ldcov_bm(3L) - ) - out <- pecotmr:::.ldSubsetData(ld, c(1L, 3L)) - # The handle is untouched; snpIdx selects into its full snpInfo, so - # subsetting picks positions 1 and 3 OF THE INDEX, not of the file. - expect_equal(pecotmr:::snpIdx(out), c(5L, 7L)) - expect_equal(variantIds(out), c("chr1:100:A:G", "chr1:300:G:A")) -}) - -test_that(".ldSketchMatchIds returns bare ids when alleles are absent", { +test_that(".ldRefMatchIds returns bare ids when alleles are absent", { gr <- GenomicRanges::GRanges( "chr1", IRanges::IRanges(c(100, 200), width = 1) @@ -4890,7 +2883,7 @@ test_that(".ldSketchMatchIds returns bare ids when alleles are absent", { ) # With no A1/A2 columns there is nothing to repair the ids against. expect_equal( - pecotmr:::.ldSketchMatchIds(se), + pecotmr:::.ldRefMatchIds(se), c("chr1:100:A:G", "chr1:200:C:T") ) }) @@ -4940,22 +2933,22 @@ test_that(".panelVariantFilter is a no-op when nothing matches the panel", { ) }) -test_that(".ldSketchNullGuard names the label in its strict error", { +test_that(".ldRefNullGuard names the label in its strict error", { expect_error( - pecotmr:::.ldSketchNullGuard("Q", NULL, "myPipe", "myLabel", "strict"), - "ldSketch on `myLabel` is non-NULL" + pecotmr:::.ldRefNullGuard("Q", NULL, "myPipe", "myLabel", "strict"), + "ldReference on `myLabel` is non-NULL" ) expect_error( - pecotmr:::.ldSketchNullGuard("Q", NULL, "myPipe", NULL, "strict"), - "qtl ldSketch is non-NULL" + pecotmr:::.ldRefNullGuard("Q", NULL, "myPipe", NULL, "strict"), + "qtl ldReference is non-NULL" ) # lenient tolerates the same input. expect_true( - pecotmr:::.ldSketchNullGuard("Q", NULL, "myPipe", "myLabel", "lenient") + pecotmr:::.ldRefNullGuard("Q", NULL, "myPipe", "myLabel", "lenient") ) }) -test_that(".ldSketchCheckContent rejects panels on different chromosomes", { +test_that(".ldRefCheckContent rejects panels on different chromosomes", { # Disjoint chromosomes leave the two panels with nothing in common, which # is a different LD reference rather than a trimming difference. mkSe <- function(chr, pos) { @@ -4967,7 +2960,7 @@ test_that(".ldSketchCheckContent rejects panels on different chromosomes", { ) } expect_error( - pecotmr:::.ldSketchCheckContent( + pecotmr:::.ldRefCheckContent( mkSe("chr1", c(100, 200)), mkSe("chr2", c(100, 200)), "myPipe", @@ -4977,19 +2970,6 @@ test_that(".ldSketchCheckContent rejects panels on different chromosomes", { ) }) -test_that(".blockPairMessages is silent on a clean block pair", { - v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") - m <- diag(3) - rownames(m) <- colnames(m) <- v - # Cross-block correlation is zero everywhere, which is what a correct - # block structure looks like. - bm <- data.frame(startIdx = c(1L, 2L), endIdx = c(1L, 3L)) - expect_equal( - pecotmr:::.blockPairMessages(1L, 2L, bm, m, v, 3L), - character(0) - ) -}) - test_that(".dropCollinearPickCor is reproducible under a seed", { X <- cbind(a = c(1, 2, 3, 4, 5), b = c(1, 2, 3, 4, 5.0001)) first <- pecotmr:::.dropCollinearPickCor(X, c(1L, 2L), FALSE, seed = 42L) @@ -4999,23 +2979,6 @@ test_that(".dropCollinearPickCor is reproducible under a seed", { expect_true(first %in% c(1L, 2L)) }) -test_that("extractLdMatrix returns the correlation when genotypes are absent", { - v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") - ld <- LdData( - correlation = diag(3), - variants = .ldcov_gr(v), - blockMetadata = .ldcov_bm(3L) - ) - expect_false(hasGenotypes(ld)) - # wantGenotype is honoured only when genotypes exist; otherwise the - # correlation is returned rather than erroring. - expect_equal(dim(pecotmr:::extractLdMatrix(ld)), c(3L, 3L)) - expect_equal( - dim(pecotmr:::extractLdMatrix(ld, wantGenotype = TRUE)), - c(3L, 3L) - ) -}) - # --------------------------------------------------------------------------- # computeLd default index: with snpIdx = NULL every variant in the panel is # used, on both the in-memory and the on-disk route. @@ -5036,22 +2999,55 @@ test_that("computeLd(panel) defaults to the panel's whole variant set", { test_that("computeLd(onDisk) defaults to every variant in the panel", { skip_if_not_installed("SNPRelate") - handle <- readGenotypeHandle( - test_path("test_data", "test_variants.gds"), - format = "gds" + skip_if_not_installed("GDSArray") + panel <- readGenotypes(test_path("test_data", "test_variants.gds")) + R <- computeLd(panel, backend = "snprelate", onDisk = TRUE) + expect_equal(dim(R), c(nrow(panel), nrow(panel))) + expect_identical( + rownames(R), + SummarizedExperiment::rowRanges(panel)$SNP ) - R <- computeLd(handle, backend = "snprelate", onDisk = TRUE) - n <- nrow(pecotmr:::snpInfo(handle)) - expect_equal(dim(R), c(n, n)) - expect_identical(rownames(R), pecotmr:::snpInfo(handle)$SNP) }) -test_that("computeLd(onDisk) applies shrinkage toward the identity", { +test_that("computeLd(onDisk) refuses a SeqArray GDS panel", { + # SNPRelate's on-disk routine reads its own SNP GDS files; a SeqArray + # file is refused by name rather than inside snpgdsOpen(). skip_if_not_installed("SNPRelate") - handle <- readGenotypeHandle( - test_path("test_data", "test_variants.gds"), - format = "gds" + skip_if_not_installed("SeqArray") + skip_if_not_installed("GDSArray") + vcf <- .writeTestVcf(.vcfGtOnly(.vcfOverlapRecords()), c("s1", "s2", "s3")) + panel <- suppressWarnings(readGenotypes(.writeTestSeqArray(vcf))) + expect_error( + computeLd(panel, backend = "snprelate", onDisk = TRUE), + "is a SeqArray GDS file" ) +}) + +test_that("cutting a VCF panel's rows cuts its seed too", { + skip_if_not_installed("VariantAnnotation") + vcf <- .writeTestVcf(.vcfGtOnly(.vcfOverlapRecords()), c("s1", "s2", "s3")) + panel <- suppressWarnings(readGenotypes(vcf)) + dosageSeed <- function(x) { + DelayedArray::seed(SummarizedExperiment::assay(x, "dosage")) + } + dose <- function(x) { + unname(as.matrix(SummarizedExperiment::assay(x, "dosage"))) + } + cut <- pecotmr:::.panelSubsetRows(panel, c(2L, 6L, 7L)) + expect_s4_class(dosageSeed(cut), "GenotypeDosageSeed") + expect_equal(dim(dosageSeed(cut)), c(3L, 3L)) + expect_equal(dose(cut), .vcfOverlapGt()[c(2L, 6L, 7L), ]) + expect_equal(S4Vectors::metadata(cut), S4Vectors::metadata(panel)) + # A cut that reorders rows is taken from the assay, over the whole seed. + reordered <- pecotmr:::.panelSubsetRows(panel, c(6L, 2L)) + expect_equal(dim(dosageSeed(reordered)), c(7L, 3L)) + expect_equal(dose(reordered), .vcfOverlapGt()[c(6L, 2L), ]) +}) + +test_that("computeLd(onDisk) applies shrinkage toward the identity", { + skip_if_not_installed("SNPRelate") + skip_if_not_installed("GDSArray") + handle <- readGenotypes(test_path("test_data", "test_variants.gds")) idx <- 1:6 plain <- computeLd( handle, @@ -5079,102 +3075,6 @@ test_that("computeLd(onDisk) applies shrinkage toward the identity", { # is either named alongside it or auto-detected from the LD path. # --------------------------------------------------------------------------- -test_that(".ldInfoBlock reads a block with an explicit SNP_file", { - ldFile <- file.path( - geno_test_data_dir, - "LD_block_1.chr1_1000_1200.float16.txt.xz" - ) - bimFile <- file.path( - geno_test_data_dir, - "LD_block_1.chr1_1000_1200.float16.bim" - ) - out <- pecotmr:::.ldInfoBlock( - data.frame( - LD_file = ldFile, - SNP_file = bimFile, - stringsAsFactors = FALSE - ), - 1L - ) - # Both ldInfo sources return an LdData, so the post-load chain does not - # have to branch on which kind of LD_file it was given. - expect_s4_class(out, "LdData") - expect_equal(dim(ldMatrix(out)), c(5L, 5L)) - expect_equal( - head(variantIds(out), 3L), - c("chr1:1000:A:G", "chr1:1040:A:G", "chr1:1080:A:G") - ) - # The .bim coordinates are carried through rather than replaced with the - # chrNA:1..n placeholders a bare matrix would get. - refPanel <- refPanel(out) - expect_equal(as.character(refPanel$chrom[[1L]]), "chr1") - expect_equal(as.integer(refPanel$pos[[1L]]), 1000L) -}) - -test_that("loadLdMatrix reads an ldInfo table of precomputed LD", { - info <- data.frame( - LD_file = file.path( - geno_test_data_dir, - "LD_block_1.chr1_1000_1200.float16.txt.xz" - ), - SNP_file = file.path( - geno_test_data_dir, - "LD_block_1.chr1_1000_1200.float16.bim" - ), - stringsAsFactors = FALSE - ) - # End-to-end: the whole post-load chain (dedup, monomorphic, subsample, - # materialize) runs against a precomputed block, not just a genotype one. - out <- loadLdMatrix(info, block = 1L) - expect_s4_class(out, "LdData") - expect_equal(length(variantIds(out)), 5L) - expect_equal(unname(diag(ldMatrix(out))), rep(1, 5L)) -}) - -test_that(".ldInfoBlock auto-detects the variant file beside the matrix", { - # Auto-detection APPENDS the suffix to the LD path, so the companion of - # `block.cor.xz` is `block.cor.xz.bim` -- not a sibling with the LD - # extension swapped out. - dir <- withr::local_tempdir() - ldFile <- file.path(dir, "block.cor.xz") - file.copy( - file.path( - geno_test_data_dir, - "LD_block_1.chr1_1000_1200.float16.txt.xz" - ), - ldFile - ) - file.copy( - file.path( - geno_test_data_dir, - "LD_block_1.chr1_1000_1200.float16.bim" - ), - str_c(ldFile, ".bim") - ) - auto <- pecotmr:::.ldInfoBlock( - data.frame(LD_file = ldFile, stringsAsFactors = FALSE), - 1L - ) - explicit <- pecotmr:::.ldInfoBlock( - data.frame( - LD_file = ldFile, - SNP_file = str_c(ldFile, ".bim"), - stringsAsFactors = FALSE - ), - 1L - ) - expect_identical(auto, explicit) - expect_s4_class(auto, "LdData") - expect_equal(dim(ldMatrix(auto)), c(5L, 5L)) -}) - -test_that(".ldInfoBlock requires an LD_file column", { - expect_error( - pecotmr:::.ldInfoBlock(data.frame(x = 1), 1L), - "needs an `LD_file` column" - ) -}) - test_that(".panelAfreqMaf returns NULL when no sidecar exists at all", { skip_if_not_installed("pgenlibr") # This plink2 fixture ships without an .afreq, so every shard's table is @@ -5184,27 +3084,14 @@ test_that(".panelAfreqMaf returns NULL when no sidecar exists at all", { format = "plink2" ) expect_equal(pecotmr:::genotypeFormat(handle), "plink2") - expect_null( - pecotmr:::.panelAfreqMaf( - handle, - as.character(pecotmr:::snpInfo(handle)$SNP) - ) - ) + expect_null(.pvfAfreqMaf(handle, as.character(snpInfo(handle)$SNP))) }) -test_that(".ldConcatChr answers character(0) for no pieces", { - expect_identical(pecotmr:::.ldConcatChr(list()), character(0)) -}) - -test_that(".ldTrimTrailingNull answers an empty list when nothing is filled", { - expect_identical(pecotmr:::.ldTrimTrailingNull(list(NULL, NULL)), list()) -}) - -test_that("the ldSketch cross-checks are no-ops when a side has no variants", { +test_that("ldReference cross-checks are no-ops when a side has no variants", { # A zero-variant panel -- what an emptied object carries -- contradicts # nothing, so there is nothing to compare and the check returns quietly. - local_mocked_bindings(.ldSketchA1 = function(x) character(0)) - expect_null(pecotmr:::.ldSketchCheckAlleleCoding( + local_mocked_bindings(.ldRefA1 = function(x) character(0)) + expect_null(pecotmr:::.ldRefCheckAlleleCoding( NULL, NULL, integer(0), @@ -5214,10 +3101,10 @@ test_that("the ldSketch cross-checks are no-ops when a side has no variants", { )) }) -test_that(".ldSketchCheckOverlap is a no-op when a side has no variants", { - local_mocked_bindings(.ldSketchVariantKeys = function(x) character(0)) +test_that(".ldRefCheckOverlap is a no-op when a side has no variants", { + local_mocked_bindings(.ldRefVariantKeys = function(x) character(0)) expect_null( - pecotmr:::.ldSketchCheckOverlap(NULL, NULL, "testPipeline", "") + pecotmr:::.ldRefCheckOverlap(NULL, NULL, "testPipeline", "") ) }) @@ -5286,36 +3173,385 @@ test_that(".panelCutoffs answers NULL for a filter that keeps everything", { ) }) -test_that("validateBlockStructure rejects overlapping blocks", { - # The merge logic only considers i - 1 / i + 1, so a block's position in - # the table has to mean its position on the chromosome. As a data.frame - # nothing checked that; as a GRanges isDisjoint() does. - mat <- diag(4) - vnames <- sprintf("chr1:%d:A:G", 100L * (1:4)) - rownames(mat) <- colnames(mat) <- vnames - overlapping <- data.frame( - blockId = c(1L, 2L), - chrom = c("1", "1"), - blockStart = c(100L, 150L), - blockEnd = c(300L, 400L), - size = c(2L, 2L), - startIdx = c(1L, 3L), - endIdx = c(2L, 4L) +test_that("a stochastic sketch's real sample count comes from its .afreq", { + skip_if_not_installed("pgenlibr") + # 100 pseudo-samples, and an .afreq that carries U_MIN / U_MAX (so the + # panel is a stochastic sketch) with OBS_CT 100: 50 real people. A MAC + # cutoff and DENTIST's truncation rank count those, not the columns. + panel <- readGenotypes( + file.path(geno_test_data_dir, "test_harmonize_regions.pgen") + ) + expect_equal(pecotmr:::.ldRefNSamples(panel), 100L) + expect_equal(pecotmr:::.ldRefRealNSamples(panel), 50L) +}) + +# ============================================================================= +# The LD reference dispatch: a genotype panel and an LdMatrix answer alike +# ============================================================================= + +# A panel of real genotypes, and the LdMatrix holding exactly its LD. +.ldrefPair <- function(nSamples = 100L) { + panel <- readGenotypes(file.path(geno_test_data_dir, "test_variants.bed")) + ld <- LdMatrix( + unname(computeLd(panel)), + variants = SummarizedExperiment::rowRanges(panel), + nSamples = nSamples + ) + list(panel = panel, ld = ld) +} + +# The stochastic-sketch fixture: 100 pseudo-samples projected from 50 real +# ones, with an .afreq that carries U_MIN / U_MAX. +.ldrefSketch <- function() { + readGenotypes(file.path(geno_test_data_dir, "test_harmonize_regions.pgen")) +} + +test_that("an LdMatrix gives the same LD as the panel it was built from", { + pr <- .ldrefPair() + ids <- names(SummarizedExperiment::rowRanges(pr$panel))[c(9, 2, 40, 5)] + expect_equal( + pecotmr:::.ldFromRef(pr$ld, ids, label = "t"), + pecotmr:::.ldFromRef(pr$panel, ids, label = "t") + ) + # A request in the opposite allele coding is re-signed the same way. + p <- parseVariantId(ids[[1L]]) + swapped <- replace( + ids, + 1L, + str_c("chr", p$chrom, ":", p$pos, ":", p$A1, ":", p$A2) + ) + flipped <- pecotmr:::.ldFromRef(pr$ld, swapped, label = "t") + expect_equal( + unname(flipped[1, -1]), + -unname(pecotmr:::.ldFromRef(pr$panel, ids, label = "t")[1, -1]) + ) + expect_error( + pecotmr:::.ldFromRef(pr$ld, c(ids, "chr21:1:A:G"), label = "t"), + "not present in the LD reference" + ) +}) + +test_that("a genotype reference's factor reproduces its LD", { + # crossprod(F) / (nrow(F) - 1) is the LD itself, and F's columns have + # zero mean, so an engine that correlates F's rows sees the same LD. + pr <- .ldrefPair() + sketch <- .ldrefSketch() + for (ref in list(pr$panel, sketch)) { + idx <- c(7L, 1L, 8L, 2L, 3L) + f <- pecotmr:::.ldRefFactor(ref, idx) + expect_equal( + unname(crossprod(f)) / (nrow(f) - 1), + unname(pecotmr:::.ldRefLdAt(ref, idx)) + ) + expect_equal(unname(colMeans(f)), rep(0, length(idx))) + } +}) + +test_that("a monomorphic variant's factor column is padded to unit variance", { + # computeLd() treats a monomorphic variant as independent of every other + # with unit variance; its standardized column is zero, so the factor adds + # two rows of +/- sqrt((m - 1) / 2) for it and rescales the rest. + set.seed(5) + X <- matrix(sample(0:2, 60, replace = TRUE), nrow = 15) + X[, 3] <- 1 + X[c(2, 9), 1] <- NA + f <- pecotmr:::.ldFactorFromDosage(X) + expect_equal(nrow(f), 17L) + expect_equal(crossprod(f) / (nrow(f) - 1), unname(computeLd(X))) + expect_equal(colMeans(f), rep(0, 4)) + # Nothing to pad: the factor is the standardized dosages themselves. + plain <- pecotmr:::.ldFactorFromDosage(X[, -3]) + expect_equal(nrow(plain), 15L) + expect_equal(crossprod(plain) / 14, unname(computeLd(X[, -3]))) +}) + +test_that(".ldFactorFromRef aligns the factor as .ldFromRef aligns the LD", { + pr <- .ldrefPair() + ids <- names(SummarizedExperiment::rowRanges(pr$panel))[c(9, 2, 40, 5)] + p <- parseVariantId(ids[[1L]]) + swapped <- replace( + ids, + 1L, + str_c("chr", p$chrom, ":", p$pos, ":", p$A1, ":", p$A2) + ) + f <- pecotmr:::.ldFactorFromRef(pr$panel, swapped, label = "t") + expect_identical(colnames(f), swapped) + expect_equal( + crossprod(f) / (nrow(f) - 1), + pecotmr:::.ldFromRef(pr$panel, swapped, label = "t") + ) + dropped <- pecotmr:::.ldFactorFromRef( + pr$panel, + c(ids, "chr21:1:A:G"), + label = "t", + onMissing = "drop" + ) + expect_identical(attr(dropped, "keptVariantIds"), ids) + expect_null( + pecotmr:::.ldFactorFromRef( + pr$panel, + "chr21:1:A:G", + label = "t", + onMissing = "drop" + ) + ) + expect_error( + pecotmr:::.ldFactorFromRef(pr$ld, ids, label = "t"), + "Only a single genotype panel" + ) +}) + +test_that("an LdMatrix answers the variant-table primitives as a panel does", { + pr <- .ldrefPair() + expect_identical( + pecotmr:::.ldRefMatchIds(pr$ld), + pecotmr:::.ldRefMatchIds(pr$panel) + ) + expect_identical( + pecotmr:::.ldRefChrom(pr$ld), + pecotmr:::.ldRefChrom(pr$panel) + ) + expect_identical( + pecotmr:::.ldRefVariantKeys(pr$ld), + pecotmr:::.ldRefVariantKeys(pr$panel) + ) + expect_null(pecotmr:::.ldRefHandle(pr$ld)) + expect_identical(pecotmr:::.asLdRef(pr$ld), pr$ld) + expect_true(pecotmr:::.ldIsReference(pr$ld)) + expect_false(pecotmr:::.ldIsPanel(pr$ld)) + expect_match(pecotmr:::.ldRefLabel(pr$ld), "LdMatrix of 349 variants") + sub <- pecotmr:::.ldRefSubset(pr$ld, c(TRUE, FALSE, TRUE, rep(FALSE, 346))) + expect_equal(length(sub), 2L) + expect_equal(length(pecotmr:::.emptyLdRef(pr$ld)), 0L) + expect_error(pecotmr:::.asLdRef(1:3), "or an LdMatrix") +}) + +test_that("an LdMatrix's sample size is what it records", { + pr <- .ldrefPair(nSamples = 80L) + expect_identical(pecotmr:::.ldRefNSamples(pr$ld), 80L) + expect_identical(pecotmr:::.ldRefRealNSamples(pr$ld), 80L) + expect_identical(pecotmr:::.ldRefNoiseN(pr$ld), 80L) + unknown <- LdMatrix(ldMatrix(pr$ld)) + expect_true(is.na(pecotmr:::.ldRefRealNSamples(unknown))) + expect_error( + pecotmr:::.ldRefRequireNSamples(unknown, "DENTIST"), + "DENTIST needs the LD reference's sample size" + ) + expect_equal(pecotmr:::.ldRefNoiseN(pr$panel), 100L) +}) + +test_that("a stochastic sketch records its real size and frequencies", { + skip_if_not_installed("pgenlibr") + sketch <- .ldrefSketch() + expect_true(pecotmr:::.ldRefIsProjection(sketch)) + expect_identical(pecotmr:::.ldRefRealNSamples(sketch), 50L) + # 1 / (1/50 + 1/100): the noise of the real samples and of the + # projection's 100 pseudo-samples together. + expect_identical(pecotmr:::.ldRefNoiseN(sketch), 33L) + af <- readAfreq( + file.path(geno_test_data_dir, "test_harmonize_regions") + ) + expect_equal( + S4Vectors::mcols(SummarizedExperiment::rowRanges(sketch))$AF, + af$alt_freq[match(pecotmr:::.ldRefVariantIds(sketch), af$id)] + ) + # Subsetting keeps the record with the variants. + sub <- sketch[3:5, ] + expect_true(pecotmr:::.ldRefIsProjection(sub)) + expect_equal(pecotmr:::.ldRefAf(sub), pecotmr:::.ldRefAf(sketch)[3:5]) + # A panel of real genotypes records nothing. + real <- readGenotypes(file.path(geno_test_data_dir, "test_variants.pgen")) + expect_false(pecotmr:::.ldRefIsProjection(real)) + expect_null(pecotmr:::.ldRefAf(real)) +}) + +test_that("frequencies come from the record, never from projected dosage", { + skip_if_not_installed("pgenlibr") + sketch <- .ldrefSketch() + st <- pecotmr:::.ldRefVariantStats(sketch, 1:3, FALSE, "t") + af <- pecotmr:::.ldRefAf(sketch)[1:3] + expect_equal(st$maf, pmin(af, 1 - af)) + expect_null(st$missRate) + expect_error( + pecotmr:::.ldRefVariantStats(sketch, 1:3, TRUE, "The LD-panel filter"), + "needs genotype missingness.*stochastic sketch" + ) + expect_equal( + pecotmr:::.ldRefVariance(sketch, 1:3), + 2 * af * (1 - af) + ) +}) + +test_that("an LdMatrix answers frequency questions only from its AF", { + pr <- .ldrefPair() + m <- pecotmr:::.ldFromRefMatch( + pr$ld, + pecotmr:::.ldRefMatchIds(pr$ld)[1:5], + "t", + "drop" + ) + cutoffs <- list(mafCutoff = 0.1, macCutoff = 0, imissCutoff = 1) + expect_error( + pecotmr:::.panelDropMask(pr$ld, m, cutoffs), + "needs allele frequencies, and the LD reference records none" + ) + expect_true(all(is.na(pecotmr:::.ldRefVariance(pr$ld, 1:3)))) + expect_error( + pecotmr:::.panelDropMask( + pr$ld, + m, + list(mafCutoff = 0, macCutoff = 0, imissCutoff = 0.1) + ), + "needs genotype missingness.*an LdMatrix" + ) + + gr <- SummarizedExperiment::rowRanges(pr$panel) + S4Vectors::mcols(gr)$AF <- rep(c(0.02, 0.3), length.out = length(gr)) + withAf <- LdMatrix(ldMatrix(pr$ld), variants = gr, nSamples = 100) + expect_equal( + pecotmr:::.panelDropMask(withAf, m, cutoffs), + c(TRUE, FALSE, TRUE, FALSE, TRUE) + ) + # MAC 20 over 100 samples is MAF 0.1. + expect_equal( + pecotmr:::.panelDropMask( + withAf, + m, + list(mafCutoff = 0, macCutoff = 20, imissCutoff = 1) + ), + c(TRUE, FALSE, TRUE, FALSE, TRUE) + ) + mix <- LdMatrix(list(withAf, withAf), mixtureWeights = c(0.5, 0.5)) + expect_error( + pecotmr:::.panelDropMask( + mix, + m, + list(mafCutoff = 0, macCutoff = 20, imissCutoff = 1) + ), + "LdMatrix is a mixture" + ) + expect_equal( + pecotmr:::.ldRefVariance(withAf, 1:2), + 2 * c(0.02, 0.3) * (1 - c(0.02, 0.3)) + ) +}) + +test_that("the same-reference check compares LdMatrix objects by their LD", { + pr <- .ldrefPair() + a <- pr$ld[1:200] + b <- pr$ld[150:349] + expect_no_error( + pecotmr:::.requireMatchingLdRefs(a, b, "pipe") + ) + other <- LdMatrix( + diag(200), + variants = SummarizedExperiment::rowRanges(pr$panel)[150:349] + ) + expect_error( + pecotmr:::.requireMatchingLdRefs(a, other, "pipe"), + "disagree on the LD among the variants they share" ) expect_error( - pecotmr:::validateBlockStructure( - mat, - .ld_bmGr(overlapping), - vnames + pecotmr:::.requireMatchingLdRefs(a, pr$panel, "pipe"), + "one side's ldReference is an LdMatrix and the other's a genotype panel" + ) +}) + +test_that("the LD's eigenvalues come from its factor's thin SVD", { + set.seed(4) + X <- matrix(rbinom(30 * 50, 2, 0.3), 30, 50) + F <- pecotmr:::.ldFactorFromDosage(X) + R <- crossprod(F) / (nrow(F) - 1) + dec <- pecotmr:::.ldFactorEigen(F) + # The SVD lists min(m, p) directions; the rest of R's are exactly zero. + expect_equal(dec$nNull, 50L - nrow(F)) + expect_equal(length(dec$values) + dec$nNull, 50L) + expect_equal(dec$values[1:25], eigen(R, symmetric = TRUE)$values[1:25]) + expect_equal(dec$vectors %*% (dec$values * t(dec$vectors)), R) +}) + +test_that("R o R products read the same from a matrix, factor or eigenpairs", { + set.seed(5) + X <- matrix(rbinom(40 * 600, 2, 0.4), 40, 600) + F <- pecotmr:::.ldFactorFromDosage(X) + R <- crossprod(F) / (nrow(F) - 1) + e <- eigen(R, symmetric = TRUE) + eig <- list(vectors = e$vectors, values = e$values) + A <- cbind(1, runif(600), rbinom(600, 1, 0.3)) + want <- (R^2) %*% A + # 600 variants are read in three stripes, the last one partial. + expect_equal(pecotmr:::.ldSquaredProduct(list(F = F), A), want) + expect_equal(pecotmr:::.ldSquaredProduct(list(R = R), A), want) + expect_equal(pecotmr:::.ldSquaredProduct(eig, A), want) + expect_equal(pecotmr:::.ldSourceRows(list(F = F), 3:5), R[3:5, ]) + expect_equal(pecotmr:::.ldSourceRows(eig, 3:5), R[3:5, ]) + expect_equal(pecotmr:::.ldSourceSize(list(F = F)), 600L) + expect_equal(pecotmr:::.ldSourceSize(eig), 600L) +}) + +test_that("a sketch's .afreq sidecar is read beside a file of any format", { + # The sidecar is named after the file's stem, whatever the format; a + # stochastic one (U_MIN / U_MAX, OBS_CT) records the real sample count + # and A1 frequencies on the panel. + expect_equal( + pecotmr:::.genotypeStem(c( + "a/x.vcf.gz", + "x.VCF.BGZ", + "x.bcf", + "x.gds", + "x.bgen", + "plink/stem" + )), + c("a/x", "x", "x", "x", "x", "plink/stem") + ) + skip_if_not_installed("RSQLite") + fx <- .bgw_fixture(n = 6L, nVar = 5L) + ids <- c("chr1:100:A:G", sprintf("rs%d", 1:4)) + freq <- c(0.1, 0.2, 0.3, 0.4, 0.5) + afreq <- tibble::tibble( + `#CHROM` = "1", + ID = ids, + REF = "A", + ALT = "G", + ALT_FREQS = freq, + OBS_CT = c(200, 200, 198, 200, 200), + U_MIN = -1, + U_MAX = 1 + ) + readr::write_tsv(afreq, str_c(str_remove(fx$path, "\\.bgen$"), ".afreq")) + panel <- readGenotypes(fx$path) + expect_equal(pecotmr:::.ldRefProjection(panel)$nSamples, 100L) + expect_equal(SummarizedExperiment::rowRanges(panel)$AF, freq) + # The same sidecar also answers the panel filter's MAF. + expect_equal( + pecotmr:::.panelAfreqMaf( + pecotmr:::.ldRefSource(panel), + pecotmr:::.ldRefChrom(panel), + ids ), - "each block must cover a span of its own" - ) - # The same blocks, made disjoint, pass. - disjoint <- overlapping - disjoint$blockStart <- c(100L, 301L) - expect_silent(pecotmr:::validateBlockStructure( - mat, - .ld_bmGr(disjoint), - vnames - )) + pmin(freq, 1 - freq) + ) +}) + +test_that("a panel held in memory serves as an LD reference", { + # Any RSE with a dosage assay and SNP / A1 / A2 rowRanges is a panel: it + # reads through no handle and records no file, and every LD route reads + # it as it reads the same genotypes from disk. + disk <- readGenotypes(test_path("test_data", "test_variants.bed"))[1:20, ] + mem <- SummarizedExperiment::SummarizedExperiment( + assays = list( + dosage = as.matrix(SummarizedExperiment::assay(disk, "dosage")) + ), + rowRanges = SummarizedExperiment::rowRanges(disk) + ) + expect_null(pecotmr:::.ldRefHandle(mem)) + expect_null(pecotmr:::.ldRefSource(mem)) + expect_match(pecotmr:::.ldRefLabel(mem), "held in memory") + expect_equal(computeLd(mem), computeLd(disk)) + expect_equal( + pecotmr:::.ldRefFactor(mem, 1:20), + pecotmr:::.ldRefFactor(disk, 1:20) + ) + expect_equal(dim(pecotmr:::.ldRefSubset(mem, 3:7)), c(5L, ncol(mem))) + expect_equal(dim(pecotmr:::.emptyLdRef(mem)), c(0L, 0L)) }) diff --git a/tests/testthat/test_ldData.R b/tests/testthat/test_ldData.R deleted file mode 100644 index d59377d07..000000000 --- a/tests/testthat/test_ldData.R +++ /dev/null @@ -1,1048 +0,0 @@ -context("LdData accessors") - -# =========================================================================== -# Fixture helpers -# =========================================================================== - -.ld_makeHandle <- function(snp_n = 4L, n_samples = 30L, path = "/tmp/h.gds") { - new( - "GenotypeHandle", - path = path, - format = "gds", - snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), - CHR = rep("1", snp_n), - BP = seq(100L, by = 100L, length.out = snp_n), - A1 = rep("A", snp_n), - A2 = rep("G", snp_n), - stringsAsFactors = FALSE - ), - nSamples = n_samples, - sampleIds = paste0("s", seq_len(n_samples)), - pgenPtr = NULL - ) -} - -.ld_makeVariants <- function(snp_n = 4L) { - gr <- GenomicRanges::GRanges( - seqnames = rep("chr1", snp_n), - ranges = IRanges::IRanges( - start = seq(100L, by = 100L, length.out = snp_n), - width = 1L - ) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - A1 = rep("A", snp_n), - A2 = rep("G", snp_n), - variant_id = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)) - ) - gr -} - -# new("LdData", ...) skips the constructor, so those tests have to supply -# the block columns the slot now guarantees. -.ld_makeBlockMetadata <- function(snp_n = 4L) { - # new("LdData", ...) skips the constructor, so these tests supply the - # stored shape directly: a GRanges whose mcols carry the index payload. - gr <- GenomicRanges::GRanges( - seqnames = "chr1", - ranges = IRanges::IRanges(start = 100L, end = 100L * snp_n) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - blockId = 1L, - size = snp_n, - startIdx = 1L, - endIdx = snp_n - ) - gr -} - -.ld_mockExtractor <- function(seed, n_samples = 30L) { - function(handle, snpIdx, meanImpute = TRUE) { - set.seed(seed) - panel <- matrix( - rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), - nrow = n_samples, - ncol = nrow(snpInfo(handle)), - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) - ) - sub <- panel[, snpIdx, drop = FALSE] - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - cd <- S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - dosage <- t(sub) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = cd - ) - } -} - -# =========================================================================== -# ldMatrix -# =========================================================================== - -test_that("ldMatrix: returns the stored correlation matrix when set", { - R <- diag(4) - ld <- LdData( - correlation = R, - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1) - ) - expect_identical(ldMatrix(ld), R) -}) - -test_that("ldMatrix: computes from a single GenotypeHandle via extractBlockGenotypes", { - ld <- LdData( - correlation = NULL, - genotypeHandle = .ld_makeHandle(), - snpIdx = 1:4, - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1) - ) - local_mocked_bindings( - extractBlockGenotypes = .ld_mockExtractor(seed = 7), - .package = "pecotmr" - ) - R <- ldMatrix(ld) - expect_true(is.matrix(R)) - expect_equal(dim(R), c(4L, 4L)) - expect_equal(unname(diag(R)), c(1, 1, 1, 1), tolerance = 1e-12) -}) - -# NB: The "neither correlation nor genotypeHandle" branch in ldMatrix -# is defensive — LdData validity rejects that state at construction time, so -# the only way to hit the runtime stop() is to mutate the slot post-hoc. -# Skipping that test in favor of paths the validity actually permits. - -test_that("ldMatrix: mixture handles produce a weighted-average R", { - gh1 <- .ld_makeHandle(path = "/tmp/h1.gds") - gh2 <- .ld_makeHandle(path = "/tmp/h2.gds") - ld <- LdData( - correlation = NULL, - genotypeHandle = list(gh1, gh2), - snpIdx = 1:4, - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1), - mixtureWeights = c(0.3, 0.7) - ) - # Different seeds per panel so the underlying LD matrices differ. - panelSeed <- list(11, 23) - call_n <- 0 - local_mocked_bindings( - extractBlockGenotypes = function(handle, snpIdx, meanImpute = TRUE) { - call_n <<- call_n + 1L - .ld_mockExtractor(seed = panelSeed[[call_n]])( - handle, - snpIdx, - meanImpute = meanImpute - ) - }, - .package = "pecotmr" - ) - R_mix <- ldMatrix(ld) - expect_equal(dim(R_mix), c(4L, 4L)) - # Recompute per-panel R independently and check weighted-average property. - call_n <- 0 - local_mocked_bindings( - extractBlockGenotypes = function(handle, snpIdx, meanImpute = TRUE) { - call_n <<- call_n + 1L - .ld_mockExtractor(seed = panelSeed[[call_n]])( - handle, - snpIdx, - meanImpute = meanImpute - ) - }, - .package = "pecotmr" - ) - R_each <- map(list(gh1, gh2), function(h) { - geno <- extractBlockGenotypes(h, 1:4) - Xt <- t(SummarizedExperiment::assay(geno, "dosage")) - computeLd(Xt, method = "sample") - }) - expected <- 0.3 * R_each[[1L]] + 0.7 * R_each[[2L]] - expect_equal(R_mix, expected, tolerance = 1e-12) -}) - -test_that("ldMatrix: mixture handles without mixtureWeights errors", { - gh <- .ld_makeHandle() - # Build via new() to skip the constructor's mixtureWeights validity check. - ld <- new( - "LdData", - .ld_makeVariants(), - correlation = NULL, - genotypeHandle = list(gh, gh), - snpIdx = 1:4, - blockMetadata = .ld_makeBlockMetadata(), - nSamples = 0L, - mixtureWeights = NULL - ) - expect_error( - ldMatrix(ld), - "Cannot compute mixture LD: `mixtureWeights` is NULL" - ) -}) - -test_that("ldMatrix: mixture panels of differing dim error", { - gh_small <- .ld_makeHandle(snp_n = 3L) - gh <- .ld_makeHandle(snp_n = 4L) - ld <- new( - "LdData", - .ld_makeVariants(), - correlation = NULL, - genotypeHandle = list(gh_small, gh), - snpIdx = 1:3, - blockMetadata = .ld_makeBlockMetadata(), - nSamples = 0L, - mixtureWeights = c(0.5, 0.5) - ) - # The first call sees snpIdx 1:3 against gh_small (3 variants); the second - # against gh (4 variants in its panel) — but we still pass snpIdx 1:3, so - # both return 3x3. To force a dim mismatch we mock the second call to - # return a 4x4 panel. - call_n <- 0 - local_mocked_bindings( - extractBlockGenotypes = function(handle, snpIdx, meanImpute = TRUE) { - call_n <<- call_n + 1L - idx <- if (call_n == 1L) snpIdx else seq_len(4L) - .ld_mockExtractor(seed = call_n)( - handle, - idx, - meanImpute = meanImpute - ) - }, - .package = "pecotmr" - ) - expect_error( - ldMatrix(ld), - "panels yielded LD matrices of differing dimensions" - ) -}) - -# =========================================================================== -# genotypes -# =========================================================================== - -test_that("genotypes: NULL handle returns NULL", { - ld <- LdData( - correlation = diag(4), - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1) - ) - expect_null(genotypes(ld)) -}) - -test_that("genotypes: matrix handle is returned unchanged", { - X <- matrix( - 0, - nrow = 10, - ncol = 4, - dimnames = list(paste0("s", 1:10), sprintf("chr1:%d:A:G", 100L * (1:4))) - ) - ld <- new( - "LdData", - .ld_makeVariants(), - correlation = NULL, - genotypeHandle = X, - snpIdx = NULL, - blockMetadata = .ld_makeBlockMetadata(), - nSamples = 0L, - mixtureWeights = NULL - ) - expect_identical(genotypes(ld), X) -}) - -test_that("genotypes: single handle returns samples x variants dosage", { - ld <- LdData( - correlation = NULL, - genotypeHandle = .ld_makeHandle(), - snpIdx = 1:4, - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1) - ) - local_mocked_bindings( - extractBlockGenotypes = .ld_mockExtractor(seed = 7), - .package = "pecotmr" - ) - G <- genotypes(ld) - expect_equal(dim(G), c(30L, 4L)) - expect_equal(colnames(G), sprintf("chr1:%d:A:G", 100L * (1:4))) -}) - -test_that("genotypes: list of handles returns a list of dosage matrices", { - gh1 <- .ld_makeHandle(path = "/tmp/h1.gds") - gh2 <- .ld_makeHandle(path = "/tmp/h2.gds") - ld <- LdData( - correlation = NULL, - genotypeHandle = list(gh1, gh2), - snpIdx = 1:4, - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1), - mixtureWeights = c(0.5, 0.5) - ) - call_n <- 0 - local_mocked_bindings( - extractBlockGenotypes = function(handle, snpIdx, meanImpute = TRUE) { - call_n <<- call_n + 1L - .ld_mockExtractor(seed = 10 + call_n)( - handle, - snpIdx, - meanImpute = meanImpute - ) - }, - .package = "pecotmr" - ) - G <- genotypes(ld) - expect_true(is.list(G)) - expect_equal(length(G), 2L) - expect_equal(dim(G[[1L]]), c(30L, 4L)) -}) - -# =========================================================================== -# Other accessors -# =========================================================================== - -test_that("hasGenotypes: TRUE when handle present, FALSE otherwise", { - ld_R <- LdData( - correlation = diag(4), - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1) - ) - expect_false(hasGenotypes(ld_R)) - - ld_gh <- LdData( - correlation = NULL, - genotypeHandle = .ld_makeHandle(), - snpIdx = 1:4, - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1) - ) - expect_true(hasGenotypes(ld_gh)) -}) - -test_that("variantIds returns the variant_id mcol", { - ld <- LdData( - correlation = diag(4), - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1) - ) - expect_equal(variantIds(ld), sprintf("chr1:%d:A:G", 100L * (1:4))) -}) - -test_that("variantInfo returns the variants verbatim", { - vars <- .ld_makeVariants() - bm <- S4Vectors::DataFrame(region = "chr1:100-400") - ld <- LdData(correlation = diag(4), variants = vars, blockMetadata = bm) - expect_identical(variantInfo(ld), vars) - # blockMetadata is NOT verbatim: the constructor normalises it to the - # columns consumers read. A column the caller added is carried through. - got <- blockMetadata(ld) - expect_s4_class(got, "GRanges") - expect_true(all( - c("blockId", "size", "startIdx", "endIdx") %in% - names(S4Vectors::mcols(got)) - )) - expect_equal(got$region, "chr1:100-400") -}) - -test_that("refPanel: assembles the chrom/pos/A1/A2/variant_id data.frame", { - ld <- LdData( - correlation = diag(4), - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1) - ) - rp <- refPanel(ld) - expect_s3_class(rp, "data.frame") - expect_setequal(colnames(rp), c("A1", "A2", "variant_id", "chrom", "pos")) - expect_equal(rp$variant_id, sprintf("chr1:%d:A:G", 100L * (1:4))) - expect_equal(rp$pos, c(100L, 200L, 300L, 400L)) -}) - -# =========================================================================== -# Tests migrated from test_dataStructures.R (LdData class) -# =========================================================================== - -test_that("LdData constructor works with correlation matrix", { - R <- matrix(c(1, 0.5, 0.5, 1), 2, 2) - rownames(R) <- colnames(R) <- c("chr1:100:A:G", "chr1:200:C:T") - gr <- GenomicRanges::GRanges( - seqnames = c("chr1", "chr1"), - ranges = IRanges::IRanges(start = c(100L, 200L), width = 1L) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - variant_id = c("chr1:100:A:G", "chr1:200:C:T"), - A1 = c("G", "T"), - A2 = c("A", "C") - ) - bm <- data.frame( - blockId = 1L, - chrom = "1", - blockStart = 100L, - blockEnd = 200L, - size = 2L, - startIdx = 1L, - endIdx = 2L - ) - - ld <- LdData(correlation = R, variants = gr, blockMetadata = bm) - expect_s4_class(ld, "LdData") - expect_false(hasGenotypes(ld)) - expect_true(is.matrix(ldMatrix(ld))) - expect_equal(variantIds(ld), c("chr1:100:A:G", "chr1:200:C:T")) - expect_equal(length(blockMetadata(ld)), 1L) - expect_null(genotypes(ld)) -}) - - -test_that("LdData validation rejects empty variants", { - R <- diag(2) - gr <- GenomicRanges::GRanges() - expect_error( - LdData(correlation = R, variants = gr, blockMetadata = data.frame()), - "must cover >= 1 variant" - ) -}) - - -test_that("LdData validation rejects NULL correlation and handle", { - gr <- GenomicRanges::GRanges( - seqnames = "chr1", - ranges = IRanges::IRanges(start = 100L, width = 1L) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - variant_id = "chr1:100:A:G", - A1 = "G", - A2 = "A" - ) - expect_error( - LdData( - correlation = NULL, - genotypeHandle = NULL, - variants = gr, - blockMetadata = data.frame() - ), - "At least one" - ) -}) - - -test_that("LdData show method works", { - R <- diag(3) - gr <- GenomicRanges::GRanges( - seqnames = rep("chr1", 3), - ranges = IRanges::IRanges(start = c(100L, 200L, 300L), width = 1L) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - variant_id = sprintf("chr1:%d:A:G", 100L * (1:3)), - A1 = rep("A", 3), - A2 = rep("G", 3) - ) - ld <- LdData(correlation = R, variants = gr, blockMetadata = data.frame()) - expect_output(show(ld), "LdData: 3 variants") -}) - - -test_that("LdData supports block-diagonal correlation", { - R1 <- diag(2) - R2 <- diag(3) - gr <- GenomicRanges::GRanges( - seqnames = rep("chr1", 5), - ranges = IRanges::IRanges(start = seq(100L, 500L, 100L), width = 1L) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - variant_id = sprintf("chr1:%d:A:G", 100L * (1:5)), - A1 = rep("A", 5), - A2 = rep("G", 5) - ) - ld <- LdData( - correlation = list(R1, R2), - variants = gr, - blockMetadata = data.frame() - ) - corr <- ldMatrix(ld) - expect_true(is.list(corr)) - expect_equal(length(corr), 2) -}) - - -test_that("LdData S4 accessors return correct data", { - R <- diag(2) - gr <- GenomicRanges::GRanges( - seqnames = c("chr1", "chr1"), - ranges = IRanges::IRanges(start = c(100L, 200L), width = 1L) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - variant_id = c("chr1:100:A:G", "chr1:200:A:G"), - A1 = c("A", "C"), - A2 = c("G", "T") - ) - ld <- LdData( - correlation = R, - variants = gr, - blockMetadata = data.frame(blockId = 1L) - ) - expect_equal(ldMatrix(ld), R) - expect_equal(variantIds(ld), c("chr1:100:A:G", "chr1:200:A:G")) - expect_false(hasGenotypes(ld)) - rp <- refPanel(ld) - expect_true(is.data.frame(rp)) - expect_true("variant_id" %in% names(rp)) - expect_equal(rp$variant_id, c("chr1:100:A:G", "chr1:200:A:G")) -}) - - -test_that(".refPanelToGranges builds GRanges from data.frame", { - rp <- data.frame( - chrom = c("1", "1"), - pos = c(100L, 200L), - A1 = c("G", "T"), - A2 = c("A", "C"), - variant_id = c("chr1:100:A:G", "chr1:200:A:G"), - allele_freq = c(0.3, 0.7), - stringsAsFactors = FALSE - ) - gr <- pecotmr:::.refPanelToGranges(rp) - expect_s4_class(gr, "GRanges") - expect_equal(length(gr), 2) - expect_equal( - S4Vectors::mcols(gr)$variant_id, - c("chr1:100:A:G", "chr1:200:A:G") - ) - expect_equal(S4Vectors::mcols(gr)$allele_freq, c(0.3, 0.7)) -}) -# ============================================================================= -# topLoci() ranges -# ============================================================================= - -# === Tests migrated from test_s4Constructors.R (LdData) === - -test_that("LdData: pre-computed correlation matrix is returned by ldMatrix", { - gr <- GenomicRanges::GRanges( - seqnames = rep("chr1", 3), - ranges = IRanges::IRanges(start = c(100L, 200L, 300L), width = 1L) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - A1 = rep("A", 3), - A2 = rep("G", 3) - ) - R <- diag(3) - block_meta <- S4Vectors::DataFrame(region = "chr1:100-300") - ld <- LdData( - correlation = R, - genotypeHandle = NULL, - snpIdx = NULL, - variants = gr, - blockMetadata = block_meta, - nSamples = 100L - ) - expect_s4_class(ld, "LdData") - expect_equal(ldMatrix(ld), R) -}) - - -test_that("LdData: validity rejects both correlation AND genotypeHandle being NULL", { - gr <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(start = 100L, width = 1L) - ) - expect_error( - LdData( - correlation = NULL, - genotypeHandle = NULL, - variants = gr, - blockMetadata = S4Vectors::DataFrame(x = 1) - ), - "At least one of 'correlation' or 'genotypeHandle' must be non-NULL" - ) -}) - - -test_that("LdData: validity rejects empty variants", { - expect_error( - LdData( - correlation = diag(0), - genotypeHandle = NULL, - variants = GenomicRanges::GRanges(), - blockMetadata = S4Vectors::DataFrame(x = 1) - ), - "must cover >= 1 variant" - ) -}) - - -test_that("LdData: mixtureWeights only valid when genotypeHandle is a list", { - gh <- .sc_makeGenotypeHandle() - gr <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(start = 100L, width = 1L) - ) - expect_error( - LdData( - correlation = NULL, - genotypeHandle = gh, - variants = gr, - blockMetadata = S4Vectors::DataFrame(x = 1), - mixtureWeights = c(0.5, 0.5) - ), - "'mixtureWeights' may only be set when 'genotypeHandle' is a list" - ) -}) - - -test_that("LdData: mixtureWeights must be non-negative and sum to 1", { - gh1 <- .sc_makeGenotypeHandle() - gh2 <- .sc_makeGenotypeHandle() - gr <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(start = 100L, width = 1L) - ) - expect_error( - LdData( - correlation = NULL, - genotypeHandle = list(gh1, gh2), - variants = gr, - blockMetadata = S4Vectors::DataFrame(x = 1), - mixtureWeights = c(0.4, 0.4) - ), - "must be non-negative and sum to 1" - ) -}) - -# =========================================================================== -# QtlDataset -# =========================================================================== - -.sc_makeSe <- function(traits = c("ENSG1", "ENSG2"), n_samples = 10) { - rng <- GenomicRanges::GRanges( - seqnames = rep("chr1", length(traits)), - ranges = IRanges::IRanges( - start = seq(1000L, by = 1000L, length.out = length(traits)), - width = 500L - ) - ) - names(rng) <- traits - expr <- matrix( - rnorm(length(traits) * n_samples), - nrow = length(traits), - ncol = n_samples, - dimnames = list(traits, paste0("s", seq_len(n_samples))) - ) - cd <- S4Vectors::DataFrame( - sex = rep(c("M", "F"), length.out = n_samples), - row.names = paste0("s", seq_len(n_samples)) - ) - SummarizedExperiment::SummarizedExperiment( - assays = list(expression = expr), - rowRanges = rng, - colData = cd - ) -} - - -# =========================================================================== -# genotypeHandle / mixtureWeights / snpIdx accessors -# =========================================================================== - -test_that("LdData: genotypeHandle / mixtureWeights / snpIdx return their slots", { - gh1 <- .ld_makeHandle(path = "/tmp/h1.gds") - gh2 <- .ld_makeHandle(path = "/tmp/h2.gds") - ld <- LdData( - correlation = NULL, - genotypeHandle = list(gh1, gh2), - snpIdx = 1:4, - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1), - mixtureWeights = c(0.3, 0.7) - ) - expect_identical(genotypeHandle(ld), list(gh1, gh2)) - expect_equal(mixtureWeights(ld), c(0.3, 0.7)) - expect_equal(snpIdx(ld), 1:4) -}) - -test_that("ldMatrix: errors when neither correlation nor genotypeHandle is set", { - # LdData validity forbids this state at construction, so build a valid - # object and drop the correlation slot post-hoc to reach the defensive - # runtime stop(). - ld <- LdData( - correlation = diag(4), - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1) - ) - ld@correlation <- NULL - expect_error( - ldMatrix(ld), - "No correlation matrix or genotype handle available" - ) -}) - -# =========================================================================== -# genotypeHandle: what the slot admits -# =========================================================================== - -test_that("ldMatrix works when the source is a dosage matrix", { - # .loadLdFromBlocks stores extracted, filtered dosages in genotypeHandle - # with snpIdx NULL (the matrix IS the subset). genotypes() always had a - # branch for that shape; ldMatrix() did not, and died inside the - # file readers with a dispatch error on sampleIds(). - set.seed(3) - X <- matrix( - rbinom(40, 2, 0.3), - nrow = 10, - ncol = 4, - dimnames = list(paste0("s", 1:10), sprintf("chr1:%d:A:G", 100L * 1:4)) - ) - ld <- LdData( - correlation = NULL, - genotypeHandle = X, - snpIdx = NULL, - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1), - nSamples = 10L - ) - R <- ldMatrix(ld) - expect_equal(dim(R), c(4L, 4L)) - expect_equal(unname(R), unname(cor(X)), tolerance = 1e-8) -}) - -test_that("the genotypeHandle slot refuses a source LD cannot be read from", { - args <- list( - correlation = NULL, - snpIdx = NULL, - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1), - nSamples = 0L - ) - for (bad in list("a path", 42L, sum)) { - expect_error( - rlang::exec(LdData, !!!args, genotypeHandle = bad), - "genotypeHandle" - ) - } -}) - -test_that("a mixture list must hold sources, not arbitrary values", { - expect_error( - LdData( - correlation = NULL, - genotypeHandle = list(.ld_makeHandle(), "not a panel"), - snpIdx = 1:4, - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1), - nSamples = 0L, - mixtureWeights = c(0.5, 0.5) - ), - "must each be a genotype panel or a dosage matrix" - ) -}) - -test_that("the constructor unwraps a genotype panel to its handle", { - # readGenotypes() is the public way to open genotypes, so LdData has to - # take a panel; the slot keeps the handle, since snpIdx selects into the - # handle's snpInfo and the panel adds nothing on top of it. - panel <- readGenotypes( - test_path("test_data", "test_variants"), - format = "plink1" - ) - ld <- LdData( - correlation = NULL, - genotypeHandle = panel, - snpIdx = 1:4, - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1), - nSamples = 0L - ) - expect_s4_class(genotypeHandle(ld), "GenotypeHandle") - expect_equal(dim(ldMatrix(ld)), c(4L, 4L)) -}) - -test_that("a DelayedMatrix is refused with the panel route named", { - # assay(panel, "dosage") is a plausible thing to reach for, but it drops - # the variant identity `snpIdx` indexes into. The slot's class union would - # reject it either way; this checks the caller is told what to pass. - h <- .readGenotypeHandle( - test_path("test_data", "test_variants"), - format = "plink1" - ) - dm <- genotypeDelayedArray(h)[1:4, ] - expect_false(is.matrix(dm)) - expect_error( - LdData( - genotypeHandle = dm, - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1) - ), - "pass the panel it came from" - ) -}) - -# =========================================================================== -# The remaining payload slots: typed, not ANY -# =========================================================================== - -.ld_baseArgs <- function() { - list( - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame(x = 1) - ) -} - -test_that("snpIdx accepts doubles and stores them as integer", { - # 1:5 is integer but c(1, 2, 3) is double, so the slot is typed integer - # and the constructor coerces rather than the union being widened. - ld <- rlang::exec( - LdData, - !!!.ld_baseArgs(), - genotypeHandle = .ld_makeHandle(), - snpIdx = c(1, 2, 3, 4) - ) - expect_identical(snpIdx(ld), 1:4) -}) - -test_that("correlation takes a matrix, a per-block list, or NULL", { - R <- matrix(1, 2, 2) - for (v in list(R, list(R, R), NULL)) { - ld <- rlang::exec( - LdData, - !!!.ld_baseArgs(), - correlation = v, - genotypeHandle = if (is.null(v)) .ld_makeHandle() else NULL - ) - expect_s4_class(ld, "LdData") - } -}) - -test_that("a block-diagonal correlation list must hold matrices", { - expect_error( - rlang::exec( - LdData, - !!!.ld_baseArgs(), - correlation = list(matrix(1, 2, 2), "not a matrix") - ), - "must each be a matrix" - ) -}) - -test_that("the payload slots refuse values of the wrong shape", { - args <- .ld_baseArgs() - expect_error( - rlang::exec(LdData, !!!args, correlation = "a string"), - "correlation" - ) - expect_error( - rlang::exec( - LdData, - !!!args, - correlation = matrix(1), - mixtureWeights = "half" - ), - "mixtureWeights" - ) - expect_error( - LdData( - correlation = matrix(1), - variants = .ld_makeVariants(), - blockMetadata = "not a table" - ), - "blockMetadata" - ) -}) - -test_that("blockMetadata takes ranges as well as tables", { - gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1L, 1000L)) - for (v in list( - gr, - data.frame(chrom = "chr1"), - S4Vectors::DataFrame(chrom = "chr1") - )) { - ld <- LdData( - correlation = matrix(1), - variants = .ld_makeVariants(), - blockMetadata = v - ) - expect_s4_class(ld, "LdData") - } -}) - - -test_that("show() labels a list-valued correlation block-diagonal", { - # Only single-matrix LdData objects were ever printed, so the other arm - # of the label was never produced. - ld <- makeTestLdDataMultiBlock(sizes = c(2L, 2L)) - expect_output(show(ld), "block-diagonal") - expect_output(show(ld), "LdData: 4 variants") -}) - - -test_that("an LdData refuses to be subset", { - # Narrowing would leave the correlation and snpIdx describing variants - # that are no longer present, so `[` errors rather than half-working. - ld <- makeTestLdData(n = 3L) - expect_error(ld[1:2], "an LdData cannot be subset") - expect_error(ld[1:2, ], "an LdData cannot be subset") -}) - -# =========================================================================== -# blockMetadata normalisation -# --------------------------------------------------------------------------- -# Five construction paths used to emit five different column sets, so -# consumers read startIdx / size / chrom that were present by luck. The -# constructor now fills whatever is absent and stores ONE shape: a GRanges -# whose seqnames/ranges are the block's chromosome and span, with the index -# payload the matrix is addressed by in mcols. -# =========================================================================== - -.ld_bmMcols <- c("blockId", "size", "startIdx", "endIdx") - -test_that("blockMetadata: a bare genomic span is completed from variants", { - ld <- LdData( - correlation = diag(4), - variants = .ld_makeVariants(), - blockMetadata = S4Vectors::DataFrame( - chrom = "chr1", - start = 100L, - end = 400L - ) - ) - bm <- blockMetadata(ld) - expect_s4_class(bm, "GRanges") - expect_true(all(.ld_bmMcols %in% names(S4Vectors::mcols(bm)))) - expect_equal(length(bm), 1L) - expect_equal(bm$startIdx, 1L) - expect_equal(bm$endIdx, 4L) - expect_equal(bm$size, 4L) - # start/end name the BLOCK's span, so they become the range itself - # rather than colliding with a variant position. - expect_equal(as.character(GenomicRanges::seqnames(bm)), "chr1") - expect_equal(GenomicRanges::start(bm), 100L) - expect_equal(GenomicRanges::end(bm), 400L) -}) - -test_that("blockMetadata: a placeholder table means one block, not none", { - ld <- LdData( - correlation = diag(4), - variants = .ld_makeVariants(), - blockMetadata = data.frame() - ) - bm <- blockMetadata(ld) - expect_equal(length(bm), 1L) - expect_true(all(.ld_bmMcols %in% names(S4Vectors::mcols(bm)))) - expect_equal(bm$size, 4L) -}) - -test_that("blockMetadata: a GRanges keeps its mcols over its ranges", { - gr <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(start = c(100L, 300L), end = c(200L, 400L)) - ) - # An LdBlocks-style GRanges carries these in mcols AND in the ranges. - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - blockId = c(1L, 2L), - chrom = c("1", "1"), - size = c(2L, 2L), - startIdx = c(1L, 3L), - endIdx = c(2L, 4L) - ) - ld <- LdData( - correlation = diag(4), - variants = .ld_makeVariants(), - blockMetadata = gr - ) - bm <- blockMetadata(ld) - expect_equal(length(bm), 2L) - # chrom is the seqnames now, and must not ALSO linger as an mcol: - # binding the ranges and the mcols both would duplicate it. - expect_equal(as.character(GenomicRanges::seqnames(bm)), c("1", "1")) - expect_false(is_in("chrom", names(S4Vectors::mcols(bm)))) - expect_equal(as.character(GenomicRanges::seqnames(bm)), c("1", "1")) - expect_equal(bm$startIdx, c(1L, 3L)) -}) - -test_that("blockMetadata: several blocks take their ranges from size", { - ld <- LdData( - correlation = diag(4), - variants = .ld_makeVariants(), - blockMetadata = tibble(blockId = 1:2, size = c(3L, 1L)) - ) - bm <- blockMetadata(ld) - expect_equal(bm$startIdx, c(1L, 4L)) - expect_equal(bm$endIdx, c(3L, 4L)) - expect_equal( - as.character(GenomicRanges::seqnames(bm)), - c("chr1", "chr1") - ) -}) - -test_that("blockMetadata: several blocks with no size and no range error", { - expect_error( - LdData( - correlation = diag(4), - variants = .ld_makeVariants(), - blockMetadata = tibble(blockId = 1:2) - ), - "cannot be determined" - ) -}) - -test_that("blockMetadata: half an index range is refused", { - expect_error( - LdData( - correlation = diag(4), - variants = .ld_makeVariants(), - blockMetadata = tibble(blockId = 1L, startIdx = 1L) - ), - "both or neither" - ) -}) - -test_that("blockMetadata: supplied indices are never replaced", { - # partitionLdMatrix() has to reject an out-of-range block, so the - # normaliser must not quietly substitute valid indices. - ld <- LdData( - correlation = diag(4), - variants = .ld_makeVariants(), - blockMetadata = tibble( - blockId = 1L, - size = 4L, - startIdx = 10L, - endIdx = 20L - ) - ) - bm <- blockMetadata(ld) - expect_equal(bm$startIdx, 10L) - expect_equal(bm$endIdx, 20L) - # An out-of-range block has no span to derive, and a GRanges cannot - # hold an NA one -- it gets a width-0 range, which is visibly not an - # interval. partitionLdMatrix() still rejects it on its indices. - expect_equal(GenomicRanges::width(bm), 0L) -}) - -test_that("blockMetadata: a caller's own columns are carried through", { - ld <- LdData( - correlation = diag(4), - variants = .ld_makeVariants(), - blockMetadata = tibble(region = "chr1:100-400", note = "kept") - ) - bm <- blockMetadata(ld) - expect_equal(bm$region, "chr1:100-400") - expect_equal(bm$note, "kept") - # The index payload comes first so the mcols read the same way whatever - # the caller supplied. - got <- names(S4Vectors::mcols(bm)) - expect_equal(got[seq_along(.ld_bmMcols)], .ld_bmMcols) -}) diff --git a/tests/testthat/test_manifestLoaders.R b/tests/testthat/test_manifestLoaders.R index 8ab98967d..a34b44f87 100644 --- a/tests/testthat/test_manifestLoaders.R +++ b/tests/testthat/test_manifestLoaders.R @@ -14,8 +14,8 @@ ) } -.toyLdSketch <- function() { - GenotypeHandle(plink1Prefix = .toyRefPrefix()) +.toyLdRef <- function() { + readGenotypes(plink1Prefix = .toyRefPrefix()) } # A small GWAS sumstats data.frame over real toy_ref chr22 variants. @@ -34,6 +34,9 @@ A2 = c("A", "T", "T", "T", "G"), z = c(1.2, -0.4, 2.1, 0.05, -1.8), n_sample = rep(10000L, 5), + # The A1 frequency, directional, which a column named `af` declares; + # without one every load warns that top_loci$af will be NA. + af = c(0.12, 0.33, 0.48, 0.71, 0.05), stringsAsFactors = FALSE ) base[seq_len(n), , drop = FALSE] @@ -119,10 +122,10 @@ test_that(".reconcileScalar resolves arg/column and flags conflicts", { # Genotype-format detection # --------------------------------------------------------------------------- -test_that(".detectGenotypeFormat builds a PLINK1 handle from a prefix", { - h <- pecotmr:::.detectGenotypeFormat(.toyRefPrefix()) - expect_s4_class(h, "GenotypeHandle") - expect_equal(genotypeFormat(h), "plink1") +test_that(".readGenotypePath reads a PLINK1 prefix as a panel", { + panel <- pecotmr:::.readGenotypePath(.toyRefPrefix()) + expect_s4_class(panel, "RangedSummarizedExperiment") + expect_equal(pecotmr:::.ldRefFormat(panel), "plink1") }) test_that("BCF sumstats are rejected", { @@ -138,7 +141,7 @@ test_that("BCF sumstats are rejected", { test_that(".checkLdContainment passes for overlapping variants", { gr <- pecotmr:::.dfToEntryGranges(.toyGwasDf(5)) - expect_silent(pecotmr:::.checkLdContainment(.toyLdSketch(), gr, 0.5, "lbl")) + expect_silent(pecotmr:::.checkLdContainment(.toyLdRef(), gr, 0.5, "lbl")) }) test_that(".checkLdContainment errors on a chromosome absent from the sketch", { @@ -146,8 +149,8 @@ test_that(".checkLdContainment errors on a chromosome absent from the sketch", { df$chrom <- "1" gr <- pecotmr:::.dfToEntryGranges(df) expect_error( - pecotmr:::.checkLdContainment(.toyLdSketch(), gr, 0.5, "lbl"), - "absent from the LD sketch" + pecotmr:::.checkLdContainment(.toyLdRef(), gr, 0.5, "lbl"), + "absent from the LD reference" ) }) @@ -156,7 +159,7 @@ test_that(".checkLdContainment errors on zero overlap", { df$pos <- c(999999001, 999999002) gr <- pecotmr:::.dfToEntryGranges(df) expect_error( - pecotmr:::.checkLdContainment(.toyLdSketch(), gr, 0.5, "lbl"), + pecotmr:::.checkLdContainment(.toyLdRef(), gr, 0.5, "lbl"), "none of the" ) }) @@ -166,8 +169,8 @@ test_that(".checkLdContainment warns on low overlap", { df$pos[3:4] <- c(999999001, 999999002) # 2/4 present -> 50% gr <- pecotmr:::.dfToEntryGranges(df) expect_warning( - pecotmr:::.checkLdContainment(.toyLdSketch(), gr, 0.9, "lbl"), - "are present in the LD sketch" + pecotmr:::.checkLdContainment(.toyLdRef(), gr, 0.9, "lbl"), + "are present in the LD reference" ) }) @@ -186,7 +189,7 @@ test_that("loadGwasSumStatsFromManifest builds from a data.frame manifest", { obj <- loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) expect_s4_class(obj, "GwasSumStats") expect_true(methods::validObject(obj)) @@ -217,7 +220,7 @@ test_that("loadGwasSumStatsFromManifest reads a file and reconciles genome", { obj <- loadGwasSumStatsFromManifest( mfPath, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) expect_equal(unname(GenomeInfoDb::genome(obj)), "hg38") # conflicting arg errors. @@ -225,7 +228,7 @@ test_that("loadGwasSumStatsFromManifest reads a file and reconciles genome", { loadGwasSumStatsFromManifest( mfPath, genome = "hg19", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ), "disagrees" ) @@ -243,7 +246,7 @@ test_that("loadGwasSumStatsFromManifest rejects duplicate studies", { loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ), "must be unique" ) @@ -287,7 +290,16 @@ test_that("loadGwasSumStatsFromManifest resolves a YAML column mapping", { tmp <- withr::local_tempdir() # Sumstats with non-standard source column names. df <- .toyGwasDf(5) - names(df) <- c("CHR", "POS", "RSID", "EA", "OA", "ZSCORE", "SAMPLE_N") + names(df) <- c( + "CHR", + "POS", + "RSID", + "EA", + "OA", + "ZSCORE", + "SAMPLE_N", + "EA_FREQ" + ) ssPath <- .writeSumstatsTsv(df, file.path(tmp, "study1.tsv")) mapPath <- file.path(tmp, "mapping.yaml") yaml::write_yaml( @@ -298,7 +310,8 @@ test_that("loadGwasSumStatsFromManifest resolves a YAML column mapping", { A1 = "EA", A2 = "OA", z = "ZSCORE", - n_sample = "SAMPLE_N" + n_sample = "SAMPLE_N", + af = "EA_FREQ" ), mapPath ) @@ -311,7 +324,7 @@ test_that("loadGwasSumStatsFromManifest resolves a YAML column mapping", { obj <- loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) expect_s4_class(obj, "GwasSumStats") expect_equal(length(obj[[1L]]), 5L) @@ -340,7 +353,7 @@ test_that("loadGwasSumStatsFromManifest reads per-variant N_CASE/N_CONTROL", { obj <- loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) expect_s4_class(obj, "GwasSumStats") mc <- S4Vectors::mcols(obj[[1L]]) @@ -403,7 +416,7 @@ test_that("loadGwasSumStatsFromManifest builds from beta/se with no z column", { obj <- loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) expect_s4_class(obj, "GwasSumStats") mc <- S4Vectors::mcols(obj[[1L]]) @@ -433,7 +446,7 @@ test_that("loadGwasSumStatsFromManifest builds from a study nSample scalar", { obj <- loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) expect_s4_class(obj, "GwasSumStats") expect_false("N" %in% colnames(S4Vectors::mcols(obj[[1L]]))) @@ -455,7 +468,7 @@ test_that("loadGwasSumStatsFromManifest builds from case/control scalars", { obj <- loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) expect_s4_class(obj, "GwasSumStats") expect_false("N" %in% colnames(S4Vectors::mcols(obj[[1L]]))) @@ -477,7 +490,7 @@ test_that("loadGwasSumStatsFromManifest errors when a study has no N source", { loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ), "needs an N field" ) @@ -511,7 +524,7 @@ test_that("loadQtlSumStatsFromManifest builds a per-tuple collection", { obj <- loadQtlSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) expect_s4_class(obj, "QtlSumStats") expect_true(methods::validObject(obj)) @@ -537,7 +550,7 @@ test_that("loadQtlSumStatsFromManifest derives the Wald z from beta/se", { obj <- loadQtlSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) expect_s4_class(obj, "QtlSumStats") mc <- S4Vectors::mcols(obj[[1L]]) @@ -585,7 +598,7 @@ test_that("loadQtlSumStatsFromManifest reads a cis-QTL nominal table", { obj <- loadQtlSumStatsFromManifest( .qtlCisManifest(ss), genome = "hg38", - ldSketch = .toyLdSketch(), + ldReference = .toyLdRef(), traitColumn = "molecular_trait_id", variantIdAlleles = "A1A2" ) @@ -604,7 +617,7 @@ test_that("variantIdAlleles = 'A2A1' reads the id in canonical order", { obj <- loadQtlSumStatsFromManifest( .qtlCisManifest(ss), genome = "hg38", - ldSketch = .toyLdSketch(), + ldReference = .toyLdRef(), traitColumn = "molecular_trait_id", variantIdAlleles = "A2A1" ) @@ -623,7 +636,7 @@ test_that("an explicit allele column beats variantIdAlleles", { obj <- loadQtlSumStatsFromManifest( .qtlCisManifest(ss), genome = "hg38", - ldSketch = .toyLdSketch(), + ldReference = .toyLdRef(), traitColumn = "molecular_trait_id", variantIdAlleles = "A1A2" ) @@ -639,7 +652,7 @@ test_that("the trait filter and the id-allele request report what went wrong", { loadQtlSumStatsFromManifest( .qtlCisManifest(ss), genome = "hg38", - ldSketch = .toyLdSketch(), + ldReference = .toyLdRef(), traitColumn = "no_such_col" ), "not a column of the sumstats file" @@ -648,7 +661,7 @@ test_that("the trait filter and the id-allele request report what went wrong", { loadQtlSumStatsFromManifest( .qtlCisManifest(ss, trait = "geneZ"), genome = "hg38", - ldSketch = .toyLdSketch(), + ldReference = .toyLdRef(), traitColumn = "molecular_trait_id" ), "no rows with molecular_trait_id == 'geneZ'" @@ -662,7 +675,7 @@ test_that("the trait filter and the id-allele request report what went wrong", { loadQtlSumStatsFromManifest( .qtlCisManifest(rsPath), genome = "hg38", - ldSketch = .toyLdSketch(), + ldReference = .toyLdRef(), variantIdAlleles = "A2A1" ), "carry no allele pair" @@ -685,7 +698,7 @@ test_that("loadQtlSumStatsFromManifest builds from a tuple nSample scalar", { obj <- loadQtlSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) expect_s4_class(obj, "QtlSumStats") expect_false("N" %in% colnames(S4Vectors::mcols(obj[[1L]]))) @@ -708,7 +721,7 @@ test_that("loadQtlSumStatsFromManifest errors when a tuple has no N source", { loadQtlSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ), "needs an N field" ) @@ -763,7 +776,7 @@ test_that("loadQtlDatasetFromManifest accepts study/genotypes as arguments", { qd <- loadQtlDatasetFromManifest( manifest, studyName = "studyY", - genotypes = .toyLdSketch() + genotypes = .toyLdRef() ) expect_equal(studyName(qd), "studyY") }) @@ -811,7 +824,7 @@ test_that("loadMultiStudyQtlDatasetFromManifest attaches a summary study", { qdMan, sumStatsManifest = ssMan, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) expect_true(methods::validObject(msd)) expect_s4_class(msd@sumStats, "QtlSumStats") @@ -858,7 +871,7 @@ test_that("loadGwasSumStatsFromManifest resolves manifest-relative paths", { obj <- loadGwasSumStatsFromManifest( mfPath, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) expect_equal(length(obj[[1L]]), 5L) }) @@ -871,47 +884,53 @@ test_that(".reconcileScalar returns NULL for an optional unset scalar", { # Coverage: genotype-format detection and LD-sketch resolution # =========================================================================== -test_that(".detectGenotypeFormat dispatches by extension", { - expect_error(pecotmr:::.detectGenotypeFormat("x.vcf.gz")) # vcf branch - expect_error(pecotmr:::.detectGenotypeFormat("x.pgen")) # plink2 branch +test_that(".readGenotypePath dispatches by extension", { + expect_error(pecotmr:::.readGenotypePath("x.vcf.gz")) # vcf branch + expect_error(pecotmr:::.readGenotypePath("x.pgen")) # plink2 branch expect_error( - pecotmr:::.detectGenotypeFormat("x.unknown"), - "Could not determine genotype format" + pecotmr:::.readGenotypePath("x.unknown"), + "manifest: .* is neither a genotype file nor a PLINK prefix" ) - h <- pecotmr:::.detectGenotypeFormat(paste0(.toyRefPrefix(), ".bed")) - expect_equal(genotypeFormat(h), "plink1") + panel <- pecotmr:::.readGenotypePath(paste0(.toyRefPrefix(), ".bed")) + expect_equal(pecotmr:::.ldRefFormat(panel), "plink1") }) -test_that(".resolveLdSketch accepts a genoMeta vector or path, rejects junk", { - sharded <- pecotmr:::.resolveLdSketch(c("22" = .toyRefPrefix())) - expect_s4_class(sharded, "GenotypeHandle") - expect_true("22" %in% names(chromPaths(sharded))) +test_that(".readGenotypePath reads a VCF as a panel", { + skip_if_not_installed("VariantAnnotation") + vcf <- .writeTestVcf(.vcfGtOnly(.vcfOverlapRecords()), c("s1", "s2", "s3")) + panel <- suppressWarnings(pecotmr:::.readGenotypePath(vcf)) + expect_equal(pecotmr:::.ldRefFormat(panel), "vcf") +}) + +test_that(".resolveLdRef accepts a genoMeta vector or path, rejects junk", { + sharded <- pecotmr:::.resolveLdRef(c("22" = .toyRefPrefix())) + expect_s4_class(sharded, "RangedSummarizedExperiment") + expect_true("22" %in% names(pecotmr:::.ldRefChromPaths(sharded))) expect_s4_class( - pecotmr:::.resolveLdSketch(.toyRefPrefix()), - "GenotypeHandle" + pecotmr:::.resolveLdRef(.toyRefPrefix()), + "RangedSummarizedExperiment" ) - expect_error(pecotmr:::.resolveLdSketch("nonexistent_meta.tsv")) - expect_error(pecotmr:::.resolveLdSketch(42L), "must be a genotype panel") + expect_error(pecotmr:::.resolveLdRef("nonexistent_meta.tsv")) + expect_error(pecotmr:::.resolveLdRef(42L), "must be a genotype panel") }) -test_that(".resolveLdSketch takes the panel readGenotypes returns", { +test_that(".resolveLdRef takes the panel readGenotypes returns", { # readGenotypes() is the only public way to open genotypes now, so the - # loaders have to accept its return value wherever they accepted a handle. + # loaders have to accept its return value wherever they accepted a + # handle -- as it stands, since a panel need not read through a handle, + # and one the caller narrowed stays narrowed. panel <- readGenotypes(plink1Prefix = .toyRefPrefix()) - resolved <- pecotmr:::.resolveLdSketch(panel) - expect_s4_class(resolved, "GenotypeHandle") - expect_identical(resolved, pecotmr:::.resolveLdSketch(.toyRefPrefix())) + expect_identical(pecotmr:::.resolveLdRef(panel), panel) + narrowed <- panel[1:5, 1:10] + expect_identical(pecotmr:::.resolveLdRef(narrowed), narrowed) }) -test_that(".materializeLdSketch and .resolveGenoHandle take a panel too", { +test_that(".materializeLdRef and .resolveGenotypes take a panel too", { panel <- readGenotypes(plink1Prefix = .toyRefPrefix()) - expect_s4_class( - pecotmr:::.materializeLdSketch(panel, "22"), - "GenotypeHandle" - ) - expect_s4_class( - pecotmr:::.resolveGenoHandle(NULL, "s1", NULL, panel), - "GenotypeHandle" + expect_identical(pecotmr:::.materializeLdRef(panel, "22"), panel) + expect_identical( + pecotmr:::.resolveGenotypes(NULL, "s1", NULL, panel), + panel ) }) @@ -925,21 +944,22 @@ test_that(".entriesChroms collects canonical chromosomes across entries", { expect_equal(pecotmr:::.entriesChroms(list(NULL)), character(0)) }) -test_that(".materializeLdSketch passes a handle through, restricts shards", { - h <- .toyLdSketch() - expect_identical(pecotmr:::.materializeLdSketch(h, "22"), h) # already in memory - expect_null(pecotmr:::.materializeLdSketch(NULL, "22")) +test_that(".materializeLdRef passes a handle through, restricts shards", { + h <- .toyLdRef() + # already in memory + expect_identical(pecotmr:::.materializeLdRef(h, "22"), h) + expect_null(pecotmr:::.materializeLdRef(NULL, "22")) # A chrom-sharded spec with a bogus chr21 payload: restricting to chr22 must # skip (never open) the chr21 shard; requesting chr21 too fails on it. spec <- c("22" = .toyRefPrefix(), "21" = "/no/such/chr21/prefix") - restricted <- pecotmr:::.materializeLdSketch(spec, "22") - expect_s4_class(restricted, "GenotypeHandle") - expect_equal(names(chromPaths(restricted)), "22") - expect_error(pecotmr:::.materializeLdSketch(spec, c("22", "21"))) + restricted <- pecotmr:::.materializeLdRef(spec, "22") + expect_s4_class(restricted, "RangedSummarizedExperiment") + expect_equal(names(pecotmr:::.ldRefChromPaths(restricted)), "22") + expect_error(pecotmr:::.materializeLdRef(spec, c("22", "21"))) }) test_that("loadGwasSumStatsFromManifest reads only the needed shards", { - skip_if_not_installed("snpStats") + skip_if_not_installed("PlinkMatrix") tmp <- withr::local_tempdir() ssPath <- .writeSumstatsTsv(.toyGwasDf(5), file.path(tmp, "study1.tsv")) manifest <- data.frame( @@ -947,24 +967,25 @@ test_that("loadGwasSumStatsFromManifest reads only the needed shards", { sumStatsPath = ssPath, stringsAsFactors = FALSE ) - # Sharded ldSketch: chr22 real (toy_ref), chr21 a bogus path. The sumstats are - # all chr22, so the loader must skip the chr21 shard -- opening it would fail. + # Sharded ldReference: chr22 real (toy_ref), chr21 a bogus path. The + # sumstats are all chr22, so the loader must skip the chr21 shard -- + # opening it would fail. obj <- loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = c("22" = .toyRefPrefix(), "21" = "/no/such/chr21/prefix") + ldReference = c("22" = .toyRefPrefix(), "21" = "/no/such/chr21/prefix") ) expect_s4_class(obj, "GwasSumStats") expect_true(methods::validObject(obj)) }) -test_that("ldSketch resolves from an ldSketchPath column; conflicts error", { +test_that("ldReference resolves from ldReferencePath; conflicts error", { tmp <- withr::local_tempdir() ssPath <- .writeSumstatsTsv(.toyGwasDf(5), file.path(tmp, "s.tsv")) manifest <- data.frame( study = "s1", sumStatsPath = ssPath, - ldSketchPath = .toyRefPrefix(), + ldReferencePath = .toyRefPrefix(), stringsAsFactors = FALSE ) obj <- loadGwasSumStatsFromManifest(manifest, genome = "hg38") @@ -974,7 +995,7 @@ test_that("ldSketch resolves from an ldSketchPath column; conflicts error", { loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = "/some/other/prefix" + ldReference = "/some/other/prefix" ), "disagrees" ) @@ -986,19 +1007,20 @@ test_that("ldSketch resolves from an ldSketchPath column; conflicts error", { ) expect_error( loadGwasSumStatsFromManifest(bare, genome = "hg38"), - "must be provided as an argument or an .ldSketchPath" + "must be provided as an argument or an .ldReferencePath" ) }) test_that("LD containment uses a sharded sketch's chromPaths", { - sharded <- GenotypeHandle(genoMeta = c("22" = .toyRefPrefix())) + skip_if_not_installed("PlinkMatrix") + sharded <- readGenotypes(genoMeta = c("22" = .toyRefPrefix())) gr <- pecotmr:::.dfToEntryGranges(.toyGwasDf(5)) expect_silent(pecotmr:::.checkLdContainment(sharded, gr, 0.5, "lbl")) }) test_that(".checkLdContainment short-circuits on an empty entry", { expect_null(pecotmr:::.checkLdContainment( - .toyLdSketch(), + .toyLdRef(), GenomicRanges::GRanges(), 0.5, "lbl" @@ -1009,7 +1031,7 @@ test_that(".checkLdContainment warns when the sketch has no variant metadata", { h <- methods::new( "GenotypeHandle", path = "meta", - format = "plink1", + format = "plink2", snpInfo = data.frame(), nSamples = 0L, sampleIds = character(), @@ -1088,7 +1110,7 @@ test_that("loadGwasSumStatsFromManifest attaches nCase/nControl/varY", { obj <- loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) expect_equal(as.numeric(obj$nCase), 1200) expect_equal(as.numeric(obj$nControl), 3400) @@ -1109,7 +1131,7 @@ test_that("loadQtlSumStatsFromManifest attaches varY and honours region", { obj <- suppressWarnings(loadQtlSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch(), + ldReference = .toyLdRef(), region = data.frame(chrom = "22", start = 1, end = 5e7) )) expect_equal(as.numeric(obj$varY), 1.7) @@ -1315,7 +1337,7 @@ test_that("loadGwasSumStatsFromManifest reads a GWAS-VCF (A1=ALT, Z=ES/SE)", { obj <- suppressWarnings(loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() )) mc <- S4Vectors::mcols(obj[[1L]]) expect_equal(as.character(mc$A1), c("G", "C", "G", "C", "A")) # ALT @@ -1344,14 +1366,14 @@ test_that("GWAS-VCF sample selection is enforced for multi-sample files", { suppressWarnings(loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() )), "pass .sampleSelect" ) obj <- suppressWarnings(loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch(), + ldReference = .toyLdRef(), sampleSelect = "study2" )) expect_equal(length(obj[[1L]]), 5L) @@ -1359,7 +1381,7 @@ test_that("GWAS-VCF sample selection is enforced for multi-sample files", { suppressWarnings(loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch(), + ldReference = .toyLdRef(), sampleSelect = "nope" )), "not a sample" @@ -1379,7 +1401,7 @@ test_that("GWAS-VCF without SS errors", { suppressWarnings(loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() )), "SS" ) @@ -1425,7 +1447,7 @@ test_that("GWAS-VCF without ES/SE errors", { suppressWarnings(loadGwasSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() )), "ES and SE" ) @@ -1462,32 +1484,32 @@ test_that("optional sumstats columns (BETA/SE/P/MAF) are attached", { stringsAsFactors = FALSE ), genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) mc <- S4Vectors::mcols(obj[[1L]]) expect_true(all(c("BETA", "SE", "P", "MAF") %in% colnames(mc))) }) -test_that(".detectGenotypeFormat probes a PLINK2 prefix", { +test_that(".readGenotypePath probes a PLINK2 prefix", { tmp <- withr::local_tempdir() file.create(file.path(tmp, "g.pgen")) - expect_error(pecotmr:::.detectGenotypeFormat(file.path(tmp, "g"))) + expect_error(pecotmr:::.readGenotypePath(file.path(tmp, "g"))) }) -test_that(".resolveLdSketch passes through NULL and a handle", { - expect_null(pecotmr:::.resolveLdSketch(NULL)) - h <- .toyLdSketch() - expect_identical(pecotmr:::.resolveLdSketch(h), h) +test_that(".resolveLdRef passes through NULL and a handle", { + expect_null(pecotmr:::.resolveLdRef(NULL)) + h <- .toyLdRef() + expect_identical(pecotmr:::.resolveLdRef(h), h) }) -test_that("non-constant ldSketchPath column errors", { +test_that("non-constant ldReferencePath column errors", { tmp <- withr::local_tempdir() ss1 <- .writeSumstatsTsv(.toyGwasDf(3), file.path(tmp, "a.tsv")) ss2 <- .writeSumstatsTsv(.toyGwasDf(3), file.path(tmp, "b.tsv")) manifest <- data.frame( study = c("a", "b"), sumStatsPath = c(ss1, ss2), - ldSketchPath = c(.toyRefPrefix(), "other"), + ldReferencePath = c(.toyRefPrefix(), "other"), stringsAsFactors = FALSE ) expect_error( @@ -1559,7 +1581,16 @@ test_that("genotypeCovariates accepts a path string", { test_that("QtlSumStats manifest resolves a per-row columnMapping", { tmp <- withr::local_tempdir() df <- .toyGwasDf(5) - names(df) <- c("CHR", "POS", "RSID", "EA", "OA", "ZSCORE", "SAMPLE_N") + names(df) <- c( + "CHR", + "POS", + "RSID", + "EA", + "OA", + "ZSCORE", + "SAMPLE_N", + "EA_FREQ" + ) ssPath <- .writeSumstatsTsv(df, file.path(tmp, "g.tsv")) mapPath <- file.path(tmp, "m.yaml") yaml::write_yaml( @@ -1570,7 +1601,8 @@ test_that("QtlSumStats manifest resolves a per-row columnMapping", { A1 = "EA", A2 = "OA", z = "ZSCORE", - n_sample = "SAMPLE_N" + n_sample = "SAMPLE_N", + af = "EA_FREQ" ), mapPath ) @@ -1585,7 +1617,7 @@ test_that("QtlSumStats manifest resolves a per-row columnMapping", { obj <- loadQtlSumStatsFromManifest( manifest, genome = "hg38", - ldSketch = .toyLdSketch() + ldReference = .toyLdRef() ) expect_equal(length(obj[[1L]]), 5L) }) @@ -1659,7 +1691,7 @@ test_that("loadGwasSumStatsFromManifest splits by LD block when asked", { plain <- suppressWarnings(loadGwasSumStatsFromManifest( manifest = mf, genome = "hg38", - ldSketch = ldStem, + ldReference = ldStem, region = region )) expect_equal(length(plain), 1L) @@ -1673,7 +1705,7 @@ test_that("loadGwasSumStatsFromManifest splits by LD block when asked", { split <- suppressWarnings(loadGwasSumStatsFromManifest( manifest = mf, genome = "hg38", - ldSketch = ldStem, + ldReference = ldStem, region = region, ldBlocks = blocks )) diff --git a/tests/testthat/test_mashPipeline.R b/tests/testthat/test_mashPipeline.R index 97953bb05..868f8f685 100644 --- a/tests/testthat/test_mashPipeline.R +++ b/tests/testthat/test_mashPipeline.R @@ -16,8 +16,8 @@ set.seed(13L) gh <- new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(nSnp)), CHR = "1", @@ -48,7 +48,7 @@ trait = rep("g1", length(contexts)), entry = entries, genome = "hg19", - ldSketch = gh, + ldReference = gh, qcInfo = list(prebuilt = "synthetic") ) } @@ -56,8 +56,8 @@ .qszm_gh <- function() { new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = "chr1:100:A:G", CHR = "1", @@ -3144,8 +3144,8 @@ test_that(".mashSumStatsToMatrices fills missing variants with bhat=0 / sbhat=10 set.seed(42L) gh <- new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * (1:5)), CHR = "1", @@ -3186,7 +3186,7 @@ test_that(".mashSumStatsToMatrices fills missing variants with bhat=0 / sbhat=10 mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))) ), genome = "hg19", - ldSketch = gh, + ldReference = gh, qcInfo = list(prebuilt = "synthetic") ) out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") @@ -3204,8 +3204,8 @@ test_that(".mashSumStatsToMatrices disambiguates rownames across (study, trait) set.seed(7L) gh <- new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), CHR = "1", @@ -3247,7 +3247,7 @@ test_that(".mashSumStatsToMatrices disambiguates rownames across (study, trait) mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))) ), genome = "hg19", - ldSketch = gh, + ldReference = gh, qcInfo = list(prebuilt = "synthetic") ) out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") @@ -3266,8 +3266,8 @@ test_that(".mashSumStatsToMatrices errors when entry lacks SNP mcol", { set.seed(8L) gh <- new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), CHR = "1", @@ -3298,7 +3298,7 @@ test_that(".mashSumStatsToMatrices errors when entry lacks SNP mcol", { trait = "g1", entry = list(gr), genome = "hg19", - ldSketch = gh, + ldReference = gh, qcInfo = list(prebuilt = "synthetic") ) expect_error( @@ -3311,8 +3311,8 @@ test_that(".mashSumStatsToMatrices on GwasSumStats: studies become columns", { set.seed(11L) gh <- new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), CHR = "1", @@ -3352,7 +3352,7 @@ test_that(".mashSumStatsToMatrices on GwasSumStats: studies become columns", { mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))) ), genome = "hg19", - ldSketch = gh, + ldReference = gh, qcInfo = list(prebuilt = "synthetic") ) out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") @@ -3385,8 +3385,8 @@ test_that(".mashSumStatsToMatrices errors on a non-SumStats input", { test_that(".mashSumStatsToMatrices errors when SumStats has empty QC info", { gh <- new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), CHR = "1", @@ -3417,7 +3417,7 @@ test_that(".mashSumStatsToMatrices errors when SumStats has empty QC info", { trait = "g1", entry = list(gr), genome = "hg19", - ldSketch = gh, + ldReference = gh, qcInfo = list() ) # empty QC info expect_error( @@ -3429,8 +3429,8 @@ test_that(".mashSumStatsToMatrices errors when SumStats has empty QC info", { test_that(".mashSumStatsToMatrices errors when SumStats has zero entries", { gh <- new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), CHR = "1", @@ -3449,7 +3449,7 @@ test_that(".mashSumStatsToMatrices errors when SumStats has zero entries", { trait = character(0), entry = list(), genome = "hg19", - ldSketch = gh, + ldReference = gh, varY = numeric(0), qcInfo = list(prebuilt = "synthetic") ) @@ -3478,7 +3478,7 @@ test_that("qtlSumStatsFromZMatrix: one row per context, Z preserved verbatim", { c("brain", "liver") ) ) - qss <- qtlSumStatsFromZMatrix(z, studyName = "s1", ldSketch = .qszm_gh()) + qss <- qtlSumStatsFromZMatrix(z, studyName = "s1", ldReference = .qszm_gh()) expect_s4_class(qss, "QtlSumStats") # The variants span chr1 and chr2, so each context becomes one ELEMENT per # chromosome. The tuple is what stays 1:1 with a matrix column. @@ -3501,7 +3501,7 @@ test_that("qtlSumStatsFromZMatrix: decodes chrom/pos from ids, synthesises when ncol = 1, dimnames = list(c("chr1:250:A:G", "not_a_variant"), "ctx") ) - qss <- qtlSumStatsFromZMatrix(z, studyName = "s1", ldSketch = .qszm_gh()) + qss <- qtlSumStatsFromZMatrix(z, studyName = "s1", ldReference = .qszm_gh()) # Stitched across whatever seqnames the ids decoded to, so the variant # order still matches the matrix rows. e <- sumStats(qss, studyName = "s1", context = "ctx", trait = "mash") @@ -3515,7 +3515,7 @@ test_that("qtlSumStatsFromZMatrix: decodes chrom/pos from ids, synthesises when test_that("qtlSumStatsFromZMatrix: NULL rownames get synthetic variant ids", { z <- matrix(rnorm(4), nrow = 2, dimnames = list(NULL, c("a", "b"))) - qss <- qtlSumStatsFromZMatrix(z, studyName = "s1", ldSketch = .qszm_gh()) + qss <- qtlSumStatsFromZMatrix(z, studyName = "s1", ldReference = .qszm_gh()) expect_equal(S4Vectors::mcols(qss[[1]])$SNP, c("var1", "var2")) }) @@ -3524,7 +3524,7 @@ test_that("qtlSumStatsFromZMatrix: placeholders and pass-through qcInfo are set" qss <- qtlSumStatsFromZMatrix( z, studyName = "s1", - ldSketch = .qszm_gh(), + ldReference = .qszm_gh(), n = 500L, a1 = "T", a2 = "C", @@ -3544,7 +3544,7 @@ test_that("qtlSumStatsFromZMatrix: columns can map to traits or context x trait qss <- qtlSumStatsFromZMatrix( z, studyName = "s1", - ldSketch = .qszm_gh(), + ldReference = .qszm_gh(), context = "brain", trait = colnames(z) ) @@ -3554,7 +3554,7 @@ test_that("qtlSumStatsFromZMatrix: columns can map to traits or context x trait qss2 <- qtlSumStatsFromZMatrix( z, studyName = "s1", - ldSketch = .qszm_gh(), + ldReference = .qszm_gh(), context = c("brain", "liver"), trait = c("geneA", "geneA") ) @@ -3568,7 +3568,7 @@ test_that("qtlSumStatsFromZMatrix: a condition label of the wrong length errors" qtlSumStatsFromZMatrix( z, studyName = "s1", - ldSketch = .qszm_gh(), + ldReference = .qszm_gh(), trait = c("t1", "t2", "t3") ), "must be length 1 or ncol" @@ -3577,13 +3577,13 @@ test_that("qtlSumStatsFromZMatrix: a condition label of the wrong length errors" test_that("qtlSumStatsFromZMatrix: rejects non-matrix input and unlabelled conditions", { expect_error( - qtlSumStatsFromZMatrix(1:5, studyName = "s1", ldSketch = .qszm_gh()), + qtlSumStatsFromZMatrix(1:5, studyName = "s1", ldReference = .qszm_gh()), "variants x conditions matrix" ) # no colnames -> the default context = colnames(z) is NULL z <- matrix(rnorm(4), nrow = 2) expect_error( - qtlSumStatsFromZMatrix(z, studyName = "s1", ldSketch = .qszm_gh()), + qtlSumStatsFromZMatrix(z, studyName = "s1", ldReference = .qszm_gh()), "column names" ) }) @@ -3594,7 +3594,7 @@ test_that("qtlSumStatsFromBetaMatrix: one entry per context, BETA/SE/Z mcols set d$bhat, d$shat, studyName = "s1", - ldSketch = .qszm_gh() + ldReference = .qszm_gh() ) expect_s4_class(qss, "QtlSumStats") expect_setequal(as.character(qss$context), c("brain", "liver")) @@ -3615,7 +3615,7 @@ test_that("qtlSumStatsFromBetaMatrix: feeds .mashSumStatsToMatrices on both scal d$bhat, d$shat, studyName = "s1", - ldSketch = .qszm_gh() + ldReference = .qszm_gh() ) mb <- .mashSumStatsToMatrices(qss, "strong", inputScale = "beta") expect_equal(unname(mb$b), unname(d$bhat)) @@ -3651,7 +3651,7 @@ test_that("qtlSumStatsFromBetaMatrix: NULL rownames -> synthetic ids; placeholde bhat, shat, studyName = "s1", - ldSketch = .qszm_gh(), + ldReference = .qszm_gh(), n = 500L, a1 = "T", a2 = "C", @@ -3690,7 +3690,7 @@ test_that("mashInput: QtlSumStats path returns the flat b/s/z + XtX contract", { expect_equal(unname(out$XtX), unname(t(out$XtX))) }) -test_that("mashInput: FineMappingResult strong = CS lead (max PIP) per condition", { +test_that("mashInput: fine-mapping strong = CS lead (max PIP) per condition", { fmr <- .mi_makeFmr() out <- mashInput( list(geneA = fmr), @@ -3709,7 +3709,7 @@ test_that("mashInput: FineMappingResult strong = CS lead (max PIP) per condition expect_equal(nrow(out$random.z), 4L) }) -test_that("mashInput: a FineMappingResult with no credible set yields no strong", { +test_that("mashInput: a fine-mapping result with no credible set: no strong", { vids <- paste0("chr1:", 100 * seq_len(6), ":A:G") noCsTL <- function(zvec) { data.frame( @@ -3806,7 +3806,7 @@ test_that("mashInput: excludeCondition drops the condition column everywhere", { test_that("mashInput: rejects a non-SumStats/non-FineMapping element", { expect_error( mashInput(list(1L)), - "must be a QtlSumStats, GwasSumStats, or FineMappingResult" + "must be a QtlSumStats, GwasSumStats, QtlFineMappingResult or" ) expect_error(mashInput(list()), "non-empty list") }) @@ -3875,7 +3875,7 @@ test_that(".qtlSumStatsFromMatrix synthesises coords for unparseable ids", { vids = c("weird1", "weird2"), nCond = 1L, studyName = "s1", - ldSketch = NULL, + ldReference = NULL, context = "cA", trait = "g1", genome = "hg19", diff --git a/tests/testthat/test_pvalCombineWrappers.R b/tests/testthat/test_pvalCombineWrappers.R index 779ec4ea9..2e50f16ef 100644 --- a/tests/testthat/test_pvalCombineWrappers.R +++ b/tests/testthat/test_pvalCombineWrappers.R @@ -422,6 +422,53 @@ test_that("pvalPoolr invchisq method returns valid p-value", { }) +test_that("generalized poolr tests reduce to the plain ones when independent", { + # With R = I the generalized adjustment must give the unadjusted test. + # poolr reads R as the covariance of each test's transformed statistic, + # so the raw correlations understated Var(-2 log p) as 1 rather than 4: + # Fisher on these four p-values gave 1.9e-6 instead of 0.0076. + skip_if_not_installed("poolr") + p <- c(0.01, 0.2, 0.5, 0.03) + R <- diag(4) + expect_equal(pecotmr:::pvalPoolr(p, "fisher", R), poolr::fisher(p)$p) + expect_equal(pecotmr:::pvalPoolr(p, "stouffer", R), poolr::stouffer(p)$p) + expect_equal(pecotmr:::pvalPoolr(p, "invchisq", R), poolr::invchisq(p)$p) +}) + +test_that(".poolrDependence converts R for the adjustment poolr runs", { + skip_if_not_installed("poolr") + R <- 0.6^abs(outer(1:4, 1:4, "-")) + gen <- list(adjust = "generalized") + expect_equal( + pecotmr:::.poolrDependence(R, "fisher", gen), + poolr::mvnconv(R, target = "m2lp") + ) + expect_equal( + pecotmr:::.poolrDependence(R, "stouffer", gen), + poolr::mvnconv(R, target = "z") + ) + expect_equal( + pecotmr:::.poolrDependence(R, "invchisq", gen), + poolr::mvnconv(R, target = "chisq1") + ) + # The effective-number adjustments read the p-values' correlations, on + # the sidedness the caller declared. + expect_equal( + pecotmr:::.poolrDependence( + R, + "fisher", + list(adjust = "nyholt", side = 1) + ), + poolr::mvnconv(R, side = 1, target = "p", cov2cor = TRUE) + ) + # "empirical" simulates from the statistics' own correlations. + expect_identical( + pecotmr:::.poolrDependence(R, "fisher", list(adjust = "empirical")), + R + ) + expect_identical(pecotmr:::.poolrDependence(R, "fisher", list()), R) +}) + test_that("pvalPoolr errors on unknown method", { skip_if_not_installed("poolr") expect_error( @@ -679,7 +726,9 @@ test_that("combinePValues refuses options for a method it will not run", { pvals = c(0.01, 0.2, 0.5), methods = "fisher", R = diag(3), - methodArgs = PvalMethodsParam(stouffer = PoolrOptions(side = 1)) + pvalMethodsParam = PvalMethodsParam( + stouffer = PoolrOptions(side = 1) + ) ), "configures stouffer, which `methods` does not request" ) @@ -687,7 +736,7 @@ test_that("combinePValues refuses options for a method it will not run", { combinePValues( pvals = c(0.01, 0.2), methods = "acat", - methodArgs = list(fisher = list()) + pvalMethodsParam = list(fisher = list()) ), "PvalMethodsParam" ) @@ -702,7 +751,7 @@ test_that("combinePValues forwards each method's options to its engine", { pvals = c(0.01, 0.2, 0.5), methods = "stouffer", R = diag(3), - methodArgs = PvalMethodsParam( + pvalMethodsParam = PvalMethodsParam( stouffer = PoolrOptions(adjust = "empirical", size = 1000) ) ), @@ -732,7 +781,7 @@ test_that("an unconfigured method still gets its constructor's defaults", { }, .package = "poolr" ) - # The adjustment pecotmr hard-coded before `methodArgs` existed. + # The adjustment pecotmr hard-coded before per-method options existed. expect_equal(seen$adjust, "generalized") }) @@ -750,7 +799,7 @@ test_that("combinePValues forwards GBJ and aSPU options", { zScores = z, methods = c("gbj", "aspu"), R = diag(3), - methodArgs = PvalMethodsParam( + pvalMethodsParam = PvalMethodsParam( gbj = GbjOptions(pairwise_cors = rep(0, 3)), aspu = AspuOptions(n.perm = 200) ) diff --git a/tests/testthat/test_qtlEnrichmentPipeline.R b/tests/testthat/test_qtlEnrichmentPipeline.R index 29f1b7015..9c3b251e0 100644 --- a/tests/testthat/test_qtlEnrichmentPipeline.R +++ b/tests/testthat/test_qtlEnrichmentPipeline.R @@ -27,7 +27,7 @@ context("qtlEnrichmentPipeline") new( "GenotypeHandle", path = path, - format = "gds", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), @@ -85,7 +85,7 @@ context("qtlEnrichmentPipeline") studyName = studyVec, method = methodVec, entry = entries, - ldSketch = if (with_sketch) .qep_makeHandle() else NULL + ldReference = if (with_sketch) .qep_makeHandle() else NULL ) } @@ -110,7 +110,7 @@ context("qtlEnrichmentPipeline") trait = trs, method = methods, entry = entries, - ldSketch = if (with_sketch) .qep_makeHandle() else NULL + ldReference = if (with_sketch) .qep_makeHandle() else NULL ) } @@ -170,7 +170,7 @@ test_that("qtlEnrichmentPipeline: the real estimator fills the value columns", { ), topLoci = data.frame(variant_id = ids, pip = gwasPip) )), - ldSketch = sketch + ldReference = sketch ) qfmr <- QtlFineMappingResult( studyName = "Q1", @@ -186,13 +186,13 @@ test_that("qtlEnrichmentPipeline: the real estimator fills the value columns", { ), topLoci = data.frame(variant_id = ids, pip = colSums(alpha)) )), - ldSketch = sketch + ldReference = sketch ) suppressWarnings(capture.output( out <- qtlEnrichmentPipeline( gwasFineMappingResult = gfmr, qtlFineMappingResult = qfmr, - methodArgs = QtlEnrichmentParam(impN = 5), + qtlEnrichmentParam = QtlEnrichmentParam(impN = 5), seed = 1L ) )) @@ -221,7 +221,7 @@ test_that("qtlEnrichmentPipeline: keys a QTL outcome side by its trait", { .qep_makeFmEntry(pip = c(0.9, 0.05, 0.02, 0.02, 0.01)), .qep_makeFmEntry(pip = c(0.1, 0.7, 0.1, 0.05, 0.05)) ), - ldSketch = .qep_makeHandle() + ldReference = .qep_makeHandle() ) local_mocked_bindings( qtlEnrichment = .qep_mockEnrichment(2.0), @@ -257,7 +257,7 @@ test_that("qtlEnrichmentPipeline: pairs two GWAS collections", { )))) }) -test_that("qtlEnrichmentPipeline: a QTL outcome side may carry no ldSketch", { +test_that("qtlEnrichmentPipeline: a QTL outcome may carry no ldReference", { # The RSS-derived requirement is a GWAS-side contract; an individual-level # QTL outcome has no panel to check. local_mocked_bindings( @@ -297,7 +297,7 @@ test_that("qtlEnrichmentPipeline: rejects non-QtlFineMappingResult qtlFmr", { ) }) -test_that("qtlEnrichmentPipeline: NULL ldSketch on the GWAS side errors", { +test_that("qtlEnrichmentPipeline: NULL ldReference on the GWAS side errors", { gfmr <- .qep_makeGwasFmr(with_sketch = FALSE) qfmr <- .qep_makeQtlFmr() expect_error( @@ -305,11 +305,11 @@ test_that("qtlEnrichmentPipeline: NULL ldSketch on the GWAS side errors", { gwasFineMappingResult = gfmr, qtlFineMappingResult = qfmr ), - "must have a non-NULL ldSketch" + "must have a non-NULL ldReference" ) }) -test_that("qtlEnrichmentPipeline: ldSketch mismatch errors", { +test_that("qtlEnrichmentPipeline: ldReference mismatch errors", { # Build the QTL with a sketch carrying a different sample set. gfmr <- .qep_makeGwasFmr() qSketch <- .qep_makeHandle() @@ -320,7 +320,7 @@ test_that("qtlEnrichmentPipeline: ldSketch mismatch errors", { trait = "t1", method = "susie", entry = list(.qep_makeFmEntry()), - ldSketch = qSketch + ldReference = qSketch ) expect_error( qtlEnrichmentPipeline( @@ -367,7 +367,7 @@ test_that("qtlEnrichmentPipeline: distinguishes two QTL studies that share a con trait = c("t1", "t1"), method = c("susie", "susie"), entry = list(e1, e2), - ldSketch = .qep_makeHandle() + ldReference = .qep_makeHandle() ) gfmr <- .qep_makeGwasFmr() capturedRegions <- list() @@ -422,7 +422,7 @@ test_that("qtlEnrichmentPipeline: empty input collections yield the empty schema studyName = "G1", method = "susie", entry = list(emptyEntry), - ldSketch = .qep_makeHandle() + ldReference = .qep_makeHandle() ) qfmr <- .qep_makeQtlFmr() expect_warning( @@ -475,7 +475,7 @@ test_that(".enrBuildGwasPipVector: deduplicates identical PIPs across blocks", { studyName = c("G1", "G1"), method = c("susie", "susie"), entry = list(e1, e2), - ldSketch = .qep_makeHandle() + ldReference = .qep_makeHandle() ) out <- pecotmr:::.enrBuildGwasPipVector(g, .qep_gwasIdent("G1")) expect_setequal( @@ -504,7 +504,7 @@ test_that(".enrBuildGwasPipVector: conflicting PIPs across blocks errors", { studyName = c("G1", "G1"), method = c("susie", "susie"), entry = list(e1, e2), - ldSketch = .qep_makeHandle() + ldReference = .qep_makeHandle() ) expect_error( pecotmr:::.enrBuildGwasPipVector(g, .qep_gwasIdent("G1")), @@ -542,7 +542,7 @@ test_that(".enrBuildQtlRegionsList: returns empty list when the (study, context) # =========================================================================== # qtlEnrichment() — kernel wrapper + real C++ integration -# These tests deliberately do NOT mock qtlEnrichmentRcpp so the C++ +# These tests deliberately do NOT mock qtlEnrichmentCpp so the C++ # kernel in src/qtl_enrichment.cpp gets coverage. The wrapper itself # (R/qtlEnrichmentPipeline.R::qtlEnrichment) is exercised here directly # rather than via the deprecated `computeQtlEnrichment` shim (which has @@ -874,7 +874,7 @@ test_that(".enrBuildGwasPipVector: skips a block whose pip length disagrees with studyName = "G1", method = "susie", entry = list(badEntry), - ldSketch = .qep_makeHandle() + ldReference = .qep_makeHandle() ) expect_identical( pecotmr:::.enrBuildGwasPipVector(g, .qep_gwasIdent("G1")), @@ -903,7 +903,7 @@ test_that(".enrBuildQtlRegionsList: skips an entry whose fit lacks alpha/pip", { trait = "t1", method = "susie", entry = list(badEntry), - ldSketch = NULL + ldReference = NULL ) expect_equal( length(pecotmr:::.enrBuildQtlRegionsList( @@ -934,7 +934,7 @@ test_that(".enrBuildQtlRegionsList: skips a fit with no V and no prior_variance" trait = "t1", method = "susie", entry = list(entry), - ldSketch = NULL + ldReference = NULL ) expect_equal( length(pecotmr:::.enrBuildQtlRegionsList( @@ -966,7 +966,7 @@ test_that(".enrBuildQtlRegionsList: names an unnamed pip from the entry's varian trait = "t1", method = "susie", entry = list(entry), - ldSketch = NULL + ldReference = NULL ) out <- pecotmr:::.enrBuildQtlRegionsList(qfmr, .qep_qtlIdent("Q1", "c1")) expect_equal(length(out), 1L) @@ -988,7 +988,7 @@ test_that("qtlEnrichmentPipeline: empty QTL collection errors with the no-triple trait = character(0), method = character(0), entry = list(), - ldSketch = NULL + ldReference = NULL ) expect_error( qtlEnrichmentPipeline( @@ -1015,7 +1015,7 @@ test_that("qtlEnrichmentPipeline: alignTuple cache is reused across GWAS studies studyName = c("G1", "G2"), method = c("susie", "susie"), entry = list(e1, e2), - ldSketch = .qep_makeHandle() + ldReference = .qep_makeHandle() ) qfmr <- .qep_makeQtlFmr() local_mocked_bindings( @@ -1047,7 +1047,7 @@ test_that("qtlEnrichmentPipeline: a tuple with no usable QTL regions warns and i trait = "t1", method = "susie", entry = list(emptyQtlEntry), - ldSketch = .qep_makeHandle() + ldReference = .qep_makeHandle() ) expect_warning( out <- qtlEnrichmentPipeline( @@ -1071,7 +1071,7 @@ test_that(".enrRunEnrichment turns a stored alignment failure into a warning", { gwasPip = NULL, k = 1L, alignedByTuple = list(cnd), - methodArgs = QtlEnrichmentParam(), + qtlEnrichmentParam = QtlEnrichmentParam(), numThreads = 1L, seed = NULL, verbose = FALSE, @@ -1149,12 +1149,12 @@ test_that("every QtlEnrichmentParam field is a qtlEnrichment formal", { )) }) -test_that("qtlEnrichmentPipeline refuses a bare list for methodArgs", { +test_that("qtlEnrichmentPipeline refuses a bare list for qtlEnrichmentParam", { expect_error( qtlEnrichmentPipeline( gwasFineMappingResult = NULL, qtlFineMappingResult = NULL, - methodArgs = list(impN = 5) + qtlEnrichmentParam = list(impN = 5) ), "must be built with QtlEnrichmentParam" ) diff --git a/tests/testthat/test_qtlSumStats.R b/tests/testthat/test_qtlSumStats.R index 85744ad98..5b2148532 100644 --- a/tests/testthat/test_qtlSumStats.R +++ b/tests/testthat/test_qtlSumStats.R @@ -7,8 +7,8 @@ context("qtlSumStats") .qtlMakeGenotypeHandle <- function() { new( "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", + path = "/tmp/test", + format = "plink2", snpInfo = data.frame(), nSamples = 0L, sampleIds = character(), @@ -60,7 +60,7 @@ context("qtlSumStats") trait = trait, entry = list(.qtlMakeEntryGr(n, with_maf = with_maf)), genome = genome, - ldSketch = .qtlMakeGenotypeHandle(), + ldReference = .qtlMakeGenotypeHandle(), varY = varY, qcInfo = qcInfo ) @@ -88,7 +88,7 @@ test_that("QtlSumStats: multi-tuple object is keyed by (study, context, trait)", .qtlMakeEntryGr(5) ), genome = "hg38", - ldSketch = .qtlMakeGenotypeHandle() + ldReference = .qtlMakeGenotypeHandle() ) expect_equal(nrow(obj), 3L) expect_setequal(contexts(obj), c("c1", "c2")) @@ -111,7 +111,7 @@ test_that("QtlSumStats: traitPosition returns the supplied trait position", { trait = "ENSGX", entry = list(.qtlMakeEntryGr(5)), genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle(), + ldReference = .qtlMakeGenotypeHandle(), traitPos = tpos ) tp <- traitPosition(obj) @@ -135,7 +135,7 @@ test_that("QtlSumStats: errors on length mismatch among study/context/trait/entr trait = c("t1"), entry = list(.qtlMakeEntryGr(1)), genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle() + ldReference = .qtlMakeGenotypeHandle() ), "same length" ) @@ -149,7 +149,7 @@ test_that("QtlSumStats: errors when entry is not a list", { trait = "t1", entry = "not_a_list", genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle() + ldReference = .qtlMakeGenotypeHandle() ), "must be a list" ) @@ -163,7 +163,7 @@ test_that("QtlSumStats: errors on non-singleton genome", { trait = "t1", entry = list(.qtlMakeEntryGr(1)), genome = c("hg19", "hg38"), - ldSketch = .qtlMakeGenotypeHandle() + ldReference = .qtlMakeGenotypeHandle() ), "single character string" ) @@ -177,7 +177,7 @@ test_that("QtlSumStats: errors on duplicate (study, context, trait) tuple", { trait = c("t1", "t1"), entry = list(.qtlMakeEntryGr(1), .qtlMakeEntryGr(1)), genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle() + ldReference = .qtlMakeGenotypeHandle() ), "uniqueness violated" ) @@ -191,7 +191,7 @@ test_that("QtlSumStats: errors when entry list contains non-GRanges", { trait = "t1", entry = list("not_a_granges"), genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle() + ldReference = .qtlMakeGenotypeHandle() ), "must be a GRanges" ) @@ -204,7 +204,7 @@ test_that("QtlSumStats: scalar varY is recycled across tuples", { trait = c("t1", "t1"), entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle(), + ldReference = .qtlMakeGenotypeHandle(), varY = 1.5 ) expect_equal(obj$varY, c(1.5, 1.5)) @@ -218,7 +218,7 @@ test_that("QtlSumStats: errors when varY length is neither 1 nor n", { trait = c("t1", "t1"), entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle(), + ldReference = .qtlMakeGenotypeHandle(), varY = c(1, 2, 3) ), "length 1 or length\\(study\\)" @@ -234,7 +234,7 @@ test_that("QtlSumStats: optional nSample column is absent by default, attached a trait = c("t1", "t1"), entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle(), + ldReference = .qtlMakeGenotypeHandle(), nSample = 838 ) # scalar recycled to both tuples expect_equal(as.numeric(obj$nSample), c(838, 838)) @@ -249,7 +249,7 @@ test_that("QtlSumStats: errors when nSample length is neither 1 nor n", { trait = c("t1", "t1"), entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle(), + ldReference = .qtlMakeGenotypeHandle(), nSample = c(1, 2, 3) ), "length 1 or length\\(study\\)" @@ -264,7 +264,7 @@ test_that("QtlSumStats: subsetChr preserves the nSample column", { trait = "t1", entry = list(gr), genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle(), + ldReference = .qtlMakeGenotypeHandle(), nSample = 838 ) sub <- subsetChr(obj, "chr1") @@ -278,7 +278,7 @@ test_that("QtlSumStats: accepts and stores extra per-tuple columns via ...", { trait = c("t1", "t1"), entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle(), + ldReference = .qtlMakeGenotypeHandle(), extraCols = list(cohort = c("UKB", "FinnGen")) ) expect_equal(as.character(obj$cohort), c("UKB", "FinnGen")) @@ -341,7 +341,7 @@ test_that("contexts / traitNames return unique values across tuples", { .qtlMakeEntryGr(1) ), genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle() + ldReference = .qtlMakeGenotypeHandle() ) expect_setequal(contexts(obj), c("c1", "c2")) expect_setequal(traitNames(obj), c("t1", "t2")) @@ -354,7 +354,7 @@ test_that("accessors require (study, context, trait) when collection has >1 entr trait = c("t1", "t1"), entry = list(.qtlMakeEntryGr(1), .qtlMakeEntryGr(1)), genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle() + ldReference = .qtlMakeGenotypeHandle() ) expect_error( sumStats(obj), @@ -410,7 +410,7 @@ test_that("subsetChr keeps only variants on the requested chromosome", { trait = "t1", entry = list(gr), genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle() + ldReference = .qtlMakeGenotypeHandle() ) chr1_only <- subsetChr(obj, "1") @@ -435,10 +435,10 @@ test_that("subsetChr drops the element when no variants on that chromosome", { unname(GenomeInfoDb::genome(empty)), unname(GenomeInfoDb::genome(obj)) ) - expect_identical(ldSketch(empty), ldSketch(obj)) + expect_identical(ldReference(empty), ldReference(obj)) }) -test_that("subsetChr preserves class-level slots (genome, ldSketch, qcInfo)", { +test_that("subsetChr keeps class-level slots (genome, ldReference, qcInfo)", { obj <- .qtlMakeOne(qcInfo = list(step1 = "ok")) res <- subsetChr(obj, "1") expect_equal( @@ -446,7 +446,7 @@ test_that("subsetChr preserves class-level slots (genome, ldSketch, qcInfo)", { unname(GenomeInfoDb::genome(obj)) ) expect_equal(qcInfo(res), qcInfo(obj)) - expect_identical(ldSketch(res), ldSketch(obj)) + expect_identical(ldReference(res), ldReference(obj)) }) # =========================================================================== @@ -469,26 +469,26 @@ test_that("sumStats errors on an empty QtlSumStats collection", { trait = character(0), entry = list(), genome = "hg19", - ldSketch = .qtlMakeGenotypeHandle(), + ldReference = .qtlMakeGenotypeHandle(), varY = numeric(0) ) expect_equal(nrow(empty), 0L) expect_error(sumStats(empty), "has no rows") }) -test_that("QtlSumStats: ldSketch is optional (NULL for LD-free workflows)", { +test_that("QtlSumStats: ldReference is optional (NULL for LD-free workflows)", { obj <- QtlSumStats( studyName = "s1", context = "c1", trait = "t1", entry = list(.qtlMakeEntryGr(1)), genome = "hg19" - ) # ldSketch omitted - expect_null(ldSketch(obj)) + ) # ldReference omitted + expect_null(ldReference(obj)) expect_output(show(obj), "none \\(LD-free\\)") }) -test_that("QtlSumStats: a non-GenotypeHandle ldSketch is rejected", { +test_that("QtlSumStats: a non-GenotypeHandle ldReference is rejected", { expect_error( QtlSumStats( studyName = "s1", @@ -496,7 +496,7 @@ test_that("QtlSumStats: a non-GenotypeHandle ldSketch is rejected", { trait = "t1", entry = list(.qtlMakeEntryGr(1)), genome = "hg19", - ldSketch = "not_a_handle" + ldReference = "not_a_handle" ), "must be a genotype panel" ) @@ -609,10 +609,10 @@ test_that("combineQtlSumStats() row-binds collections and keeps NULL sketches", ) a2 <- a - a2@ldSketch <- NULL + a2@ldReference <- NULL b2 <- b - b2@ldSketch <- NULL - expect_null(ldSketch(combineQtlSumStats(a2, b2))) + b2@ldReference <- NULL + expect_null(ldReference(combineQtlSumStats(a2, b2))) }) diff --git a/tests/testthat/test_regularizedRegressionWrappers.R b/tests/testthat/test_regularizedRegressionWrappers.R index 027e32576..2c48d9911 100644 --- a/tests/testthat/test_regularizedRegressionWrappers.R +++ b/tests/testthat/test_regularizedRegressionWrappers.R @@ -574,7 +574,12 @@ test_that("mrashWeights returns length-p weights and can retain the fit", { skip_if_not_installed("susieR") skip_if_not_installed("glmnet") f <- .rrwXy() - w <- mrashWeights(f$X, f$y, fitRetention = "slim") + # mr.ash's own default grid is too narrow for this fixture's two strong + # effects, and mr.ash says so. + expect_warning( + w <- mrashWeights(f$X, f$y, fitRetention = "slim"), + "larger setting of the prior variance" + ) expect_length(w, f$p) expect_false(is.null(attr(w, "fit"))) }) @@ -783,28 +788,272 @@ test_that("RSS solvers validate their R-matrix / sample-size / length inputs", { test_that("lassosumRssWeights returns length-p weights and records the selection", { f <- .rrwStatLd() - w <- lassosumRssWeights(f$stat, f$LD) + w <- lassosumRssWeights(f$stat, f$ldReference) expect_length(w, f$p) expect_equal(unname(attr(w, "lassosum_selection")["mode"]), "ldQuadratic") expect_length( - lassosumRssWeights(f$stat, f$LD, selection = "minFbeta"), + lassosumRssWeights(f$stat, f$ldReference, selection = "minFbeta"), f$p ) }) test_that("scadRssWeights / mcpRssWeights / l0learnRssWeights return length-p weights", { f <- .rrwStatLd() - expect_length(scadRssWeights(f$stat, f$LD), f$p) - expect_length(mcpRssWeights(f$stat, f$LD), f$p) - expect_length(l0learnRssWeights(f$stat, f$LD), f$p) + expect_length(scadRssWeights(f$stat, f$ldReference), f$p) + expect_length(mcpRssWeights(f$stat, f$ldReference), f$p) + expect_length(l0learnRssWeights(f$stat, f$ldReference), f$p) +}) + +test_that("mrashRssWeights attaches the mr.ash.rss fit on request", { + f <- .rrwStatLd() + none <- mrashRssWeights(f$stat, f$ldReference) + expect_null(attr(none, "fit")) + slim <- mrashRssWeights(f$stat, f$ldReference, fitRetention = "slim") + expect_equal(as.numeric(slim), as.numeric(none)) + expect_equal(as.numeric(attr(slim, "fit")$mu1), as.numeric(none)) +}) + +test_that("the raw RSS solvers are internal behind their weight adapters", { + # The adapters are the public route; the Options constructors still read + # the now-internal solvers' formals, so they keep rejecting a stray name. + exported <- getNamespaceExports("pecotmr") + solvers <- c("prsCs", "sdpr", "lassosumRss", "penalizedRss") + adapters <- c( + "prsCsWeights", + "sdprWeights", + "lassosumRssWeights", + "scadRssWeights", + "mcpRssWeights", + "l0learnRssWeights" + ) + expect_false(any(is_in(solvers, exported))) + expect_true(all(is_in(adapters, exported))) + expect_error(PrsCsOptions(notAnOption = 1), "unknown argument") + expect_error(SdprOptions(notAnOption = 1), "unknown argument") + expect_error(LassosumOptions(notAnOption = 1), "unknown argument") + expect_error(PenalizedRssOptions(notAnOption = 1), "unknown argument") +}) + +test_that("prsCsWeights and sdprWeights attach the sampler's estimates", { + # What the samplers estimate besides the weights reaches the caller as + # the "fit" attribute; asking for it leaves the weights unchanged. + f <- .rrwStatLd() + prsOpts <- PrsCsOptions(nIter = 100, nBurnin = 20, thin = 1, seed = 42L) + prsNone <- prsCsWeights(f$stat, f$ldReference, methodArgs = prsOpts) + expect_null(attr(prsNone, "fit")) + prsSlim <- prsCsWeights( + f$stat, + f$ldReference, + fitRetention = "slim", + methodArgs = prsOpts + ) + prsFit <- attr(prsSlim, "fit") + expect_named(prsFit, c("betaEst", "psiEst", "sigmaEst", "phiEst")) + expect_equal(as.numeric(prsSlim), as.numeric(prsNone)) + expect_equal(prsFit$betaEst, as.numeric(prsNone)) + expect_length(prsFit$psiEst, f$p) + sdprOpts <- SdprOptions( + iter = 100, + burn = 20, + thin = 1, + verbose = FALSE, + seed = 42L + ) + sdprNone <- sdprWeights(f$stat, f$ldReference, methodArgs = sdprOpts) + expect_null(attr(sdprNone, "fit")) + sdprFull <- sdprWeights( + f$stat, + f$ldReference, + fitRetention = "full", + methodArgs = sdprOpts + ) + expect_named(attr(sdprFull, "fit"), c("betaEst", "h2")) + expect_length(attr(sdprFull, "fit")$h2, 1L) + expect_equal(as.numeric(sdprFull), as.numeric(sdprNone)) + expect_error( + prsCsWeights(f$stat, f$ldReference, fitRetention = "all"), + "fitRetention" + ) +}) + +test_that("lassosumRssWeights keeps its search: path at slim, beta at full", { + f <- .rrwStatLd() + s <- c(0.5, 1) + none <- lassosumRssWeights(f$stat, f$ldReference, s = s) + expect_null(attr(none, "fit")) + slim <- lassosumRssWeights( + f$stat, + f$ldReference, + s = s, + fitRetention = "slim" + ) + expect_named(attr(slim, "fit"), "path") + path <- attr(slim, "fit")$path + expect_named( + path, + c("s", "lambda", "fbeta", "loss", "conv", "nparams", "selected") + ) + # One row per (s, lambda): lassosumRss() traces 20 lambdas by default. + expect_equal(nrow(path), length(s) * 20L) + expect_equal(sum(path$selected), 1L) + expect_equal(as.numeric(slim), as.numeric(none)) + # The selected row is the one the selection attribute names. + sel <- attr(slim, "lassosum_selection") + expect_equal(path$s[path$selected], as.numeric(sel[["s"]])) + expect_equal(path$lambda[path$selected], as.numeric(sel[["lambda"]])) + full <- lassosumRssWeights( + f$stat, + f$ldReference, + s = s, + fitRetention = "full" + ) + beta <- attr(full, "fit")$beta + expect_equal(dim(beta), c(f$p, nrow(path))) + expect_equal(unname(beta[, path$selected]), as.numeric(full)) + expect_equal(colSums(beta != 0), path$nparams) }) -test_that("prsCsWeights and sdprWeights follow the (stat, LD) contract", { +test_that("scad, mcp and l0learn RSS weights pass fitRetention through", { + f <- .rrwStatLd() + cols <- c("s", "lambda", "fbeta", "loss", "conv", "nparams", "selected") + scad <- scadRssWeights(f$stat, f$ldReference, s = 1, fitRetention = "slim") + mcp <- mcpRssWeights(f$stat, f$ldReference, s = 1, fitRetention = "slim") + expect_named(attr(scad, "fit")$path, cols) + expect_named(attr(mcp, "fit")$path, cols) + l0 <- l0learnRssWeights( + f$stat, + f$ldReference, + s = 1, + lambda0 = c(0.01, 0.1), + fitRetention = "full" + ) + path <- attr(l0, "fit")$path + expect_named(path, c("s", "lambda0", cols[-1])) + # Plain L0 traces the single lambda = 0, so one row per lambda0. + expect_equal(path$lambda0, c(0.01, 0.1)) + expect_equal(ncol(attr(l0, "fit")$beta), 2L) +}) + +test_that("the RSS solvers run on a factor of the LD as on the LD itself", { + # The factor route keeps F beta rather than R_s beta, so R_s is never + # formed; the coordinate updates, the L0 swaps and the path are the same. + # The dense route applies the shrinkage itself too, as fitting the + # pre-shrunk matrix would. + set.seed(8) + X <- matrix(rbinom(80 * 120, 2, 0.3), 80, 120) + F <- pecotmr:::.ldFactorFromDosage(X) + R <- crossprod(F) / (nrow(F) - 1) + beta <- replace(numeric(120), c(5, 40, 90), c(0.3, -0.2, 0.25)) + z <- as.vector(R %*% beta) + rnorm(120, sd = 0.05) + lambda <- exp(seq(log(0.1), log(0.001), length.out = 8)) + for (s in c(0.2, 0.9)) { + Rs <- (1 - s) * R + s * diag(120) + dense <- pecotmr:::lassosumRssCpp(z, list(R), s, lambda, 1e-6, 1000L) + expect_equal( + dense, + pecotmr:::lassosumRssCpp(z, list(Rs), 0, lambda, 1e-6, 1000L), + tolerance = 1e-10 + ) + expect_equal( + pecotmr:::lassosumRssFactorCpp(z, F, s, lambda, 1e-6, 1000L), + dense, + tolerance = 1e-8 + ) + for (pen in c("lasso", "MCP", "SCAD", "L0")) { + args <- list( + lambdaR = lambda, + penaltyStr = pen, + gamma = 3.7, + alpha = 1, + lambda0 = 0.001, + lambda2 = 0, + thr = 1e-6, + maxiter = 1000L, + maxSwaps = 10L + ) + dense <- exec(pecotmr:::penalizedRssCpp, z, list(R), s, !!!args) + expect_equal( + dense, + exec(pecotmr:::penalizedRssCpp, z, list(Rs), 0, !!!args), + tolerance = 1e-10, + label = pen + ) + expect_equal( + exec(pecotmr:::penalizedRssFactorCpp, z, F, s, !!!args), + dense, + tolerance = 1e-8, + label = pen + ) + } + } +}) + +test_that("SDPR on a factor of the LD draws as it does on the matrix", { + # The factor route holds SDPR's matrices in low-rank form, B = W W', and + # runs SDPR's own sampler on them, so a seeded chain matches the dense one + # to rounding. optLlk = 2 reaches B through the Woodbury identity while + # its low-rank part is narrower than p (one sample size, three sizes, or + # arrays), and otherwise forms it as the dense route does (three sizes + # with arrays). + set.seed(7) + X <- matrix(rbinom(40 * 120, 2, 0.3), 40, 120) + F <- pecotmr:::.ldFactorFromDosage(X) + R <- crossprod(F) / (nrow(F) - 1) + p <- ncol(F) + effects <- replace(numeric(p), c(5, 40, 90), c(0.3, -0.25, 0.2)) + bhat <- as.vector(R %*% effects) + rnorm(p, sd = 0.02) + sizes <- sample(c(400, 500, 600), p, replace = TRUE) + arrays <- sample(0:2, p, replace = TRUE) + base <- list( + bhatR = bhat, + n = 500L, + perVariantSampleSize = NULL, + array = NULL, + a = 0.1, + c = 1, + M = 50L, + a0k = 0.5, + b0k = 0.5, + iter = 200L, + burn = 50L, + thin = 5L, + numThreads = 1L, + optLlk = 1L, + verbose = FALSE, + seed = 11L + ) + cases <- list( + llk1 = list(), + llk2 = list(optLlk = 2L), + sizes = list(optLlk = 2L, perVariantSampleSize = sizes), + arrays = list(optLlk = 2L, array = arrays), + sizesArrays = list( + optLlk = 2L, + perVariantSampleSize = sizes, + array = arrays + ) + ) + for (nm in names(cases)) { + args <- list_modify(base, !!!cases[[nm]]) + expect_equal( + exec(pecotmr:::sdprFactorCpp, factorR = F, !!!args), + exec(pecotmr:::sdprCpp, LD = list(R), !!!args), + tolerance = 1e-8, + label = nm + ) + } + expect_error( + exec(pecotmr:::sdprFactorCpp, factorR = F[, -1], !!!base), + "The LD factor has 119 columns but there are 120 effects" + ) +}) + +test_that("prsCsWeights and sdprWeights take (stat, ldReference)", { f <- .rrwStatLd() expect_length( prsCsWeights( f$stat, - f$LD, + f$ldReference, methodArgs = PrsCsOptions(nIter = 100, nBurnin = 20, thin = 1) ), f$p @@ -812,7 +1061,7 @@ test_that("prsCsWeights and sdprWeights follow the (stat, LD) contract", { expect_length( sdprWeights( f$stat, - f$LD, + f$ldReference, methodArgs = SdprOptions( iter = 100, burn = 20, @@ -824,12 +1073,144 @@ test_that("prsCsWeights and sdprWeights follow the (stat, LD) contract", { ) }) +test_that("prsCsWeights and sdprWeights hand the engine z / sqrt(n)", { + # Both upstream tools fit the standardized marginal effects, so a z-only + # stat (the QtlSumStats shape) and b with its standard error both reach + # the engine on that scale. + f <- .rrwStatLd() + want <- as.numeric(f$stat$z) / sqrt(f$n) + local_mocked_bindings( + .prsCsRun = function(bhat, ld, n, ...) list(betaEst = bhat), + .sdprRun = function(bhat, ld, n, ...) list(betaEst = bhat) + ) + ids <- f$stat$variantNames + zOnly <- list(z = f$stat$z, n = f$n, variantNames = ids) + withSe <- list( + b = 3 * f$stat$z, + seb = rep(3, f$p), + n = rep(f$n, f$p), + variantNames = ids + ) + for (stat in list(zOnly, withSe)) { + expect_equal(prsCsWeights(stat, f$ldReference), want) + expect_equal(sdprWeights(stat, f$ldReference), want) + } +}) + +# Statistics over the first p variants of the test genotype panel, with the +# same LD as an LdMatrix: a weight method must read the panel's LD (through +# its standardized genotypes) as it reads the matrix. +.rrwPanelStat <- function(p = 40) { + panel <- readGenotypes(test_path("test_data", "test_variants.bed")) + ids <- names(SummarizedExperiment::rowRanges(panel))[seq_len(p)] + R <- pecotmr:::.ldFromRef(panel, ids, "test") + set.seed(3) + effects <- replace(numeric(p), c(3, 20), c(4, -3)) + z <- as.vector(R %*% effects) + rnorm(p) + list( + panel = panel, + ldMatrix = LdMatrix(R, nSamples = ncol(panel)), + stat = list(z = z, n = rep(500, p), variantNames = ids) + ) +} + +test_that("RSS weights read a genotype panel's LD as they read the matrix", { + # The panel route gives the solvers the panel's factor and never forms + # the LD matrix; it must land on the matrix route's weights. + d <- .rrwPanelStat() + fns <- list( + lassosum = lassosumRssWeights, + scad = scadRssWeights, + mcp = mcpRssWeights, + l0learn = l0learnRssWeights + ) + for (nm in names(fns)) { + expect_equal( + fns[[nm]](d$stat, d$panel), + fns[[nm]](d$stat, d$ldMatrix), + tolerance = 1e-6, + label = nm + ) + } + # mr.ash.rss takes only a matrix, formed from the panel. + expect_equal( + mrashRssWeights(d$stat, d$panel), + mrashRssWeights(d$stat, d$ldMatrix), + tolerance = 1e-8 + ) + # SDPR runs its own sampler on the low-rank form of its matrices, so a + # seeded chain lands on the matrix route's. + for (optLlk in 1:2) { + opts <- SdprOptions( + iter = 100, + burn = 20, + thin = 1, + optLlk = optLlk, + verbose = FALSE, + seed = 1L + ) + expect_equal( + sdprWeights(d$stat, d$panel, methodArgs = opts), + sdprWeights(d$stat, d$ldMatrix, methodArgs = opts), + tolerance = 1e-6, + label = str_c("sdpr optLlk ", optLlk) + ) + } +}) + +test_that("an RSS weight method matches its LD reference by variant id", { + f <- .rrwStatLd() + unnamed <- f$stat + unnamed$variantNames <- NULL + expect_error( + lassosumRssWeights(unnamed, f$ldReference), + "must carry `variantNames`" + ) + expect_error( + mrashRssWeights(unnamed, f$ldReference), + "must carry `variantNames`" + ) + # The extractors need the ids only to check against a reference. + expect_equal(pecotmr:::.rssVariantCount(unnamed, NULL, "t"), f$p) + expect_equal(pecotmr:::.rssVariantCount(f$stat, f$ldReference, "t"), f$p) + expect_true(is.na(pecotmr:::.rssVariantCount(list(), NULL, "t"))) +}) + +test_that(".formalDefaults evaluates a function's own defaults", { + expect_equal( + pecotmr:::.formalDefaults(prsCs, c("a", "phi", "nIter")), + list(a = 1, phi = NULL, nIter = 1000) + ) +}) + +test_that("mrashRssWeights defaults to mr.ash's own prior grid", { + # On the standardized scale mr.ash.rss fits, its sufficient statistics + # are those of standardized genotypes, whose grid mr.ash builds itself. + set.seed(1) + X <- scale(matrix(rnorm(200 * 10), 200)) + fit <- susieR::mr.ash(X, rnorm(200), verbose = FALSE, max.iter = 5) + expect_equal( + pecotmr:::.mrashRssDefaultGrid(200, rnorm(10), numeric(0), NULL), + fit$data$sa2 + ) + f <- .rrwStatLd() + expect_length(mrashRssWeights(f$stat, f$ldReference), f$p) + # With b, seb and varY the unstandardized statistics set the scale. + z <- f$stat$z + shat <- f$stat$seb + w <- 2 * (f$n - 1) / (z^2 + f$n - 2) / shat^2 + expect_equal( + pecotmr:::.mrashRssDefaultGrid(f$n, z, shat, 2), + (2^((0:24) / 25) - 1)^2 / median(w) * f$n + ) +}) + test_that("mrashRssWeights returns posterior-mean weights of length p", { skip_if_not_installed("susieR") f <- .rrwStatLd() w <- mrashRssWeights( f$stat, - f$LD, + f$ldReference, varY = 1, sigma2E = 1, s0 = c(0, 0.01, 0.1, 0.5, 1), @@ -843,7 +1224,7 @@ test_that("mrashRssWeights returns posterior-mean weights of length p", { test_that("mrmashRssWeights fits mr.mash.rss and returns p x K weights", { skip_if_not_installed("mr.mashr") m <- .rrwMulti(n = 60, p = 6, K = 3) - w <- mrmashRssWeights(m$stat, m$LD) + w <- mrmashRssWeights(m$stat, m$ldReference) expect_equal(dim(w), c(m$p, m$K)) expect_true(all(is.finite(w))) }) @@ -851,17 +1232,21 @@ test_that("mrmashRssWeights fits mr.mash.rss and returns p x K weights", { test_that("mrmashRssWeights errors on single-context stat$z", { skip_if_not_installed("mr.mashr") f <- .rrwStatLd() - oneCol <- list(z = matrix(f$stat$z, ncol = 1), n = f$n) - expect_error(mrmashRssWeights(oneCol, f$LD), ">= 2 columns") + oneCol <- list( + z = matrix(f$stat$z, ncol = 1), + n = f$n, + variantNames = f$stat$variantNames + ) + expect_error(mrmashRssWeights(oneCol, f$ldReference), ">= 2 columns") }) # ------------------------------- pure helpers ------------------------------- -test_that(".lassosumCorFromStat reads cor / z / b and validates length", { +test_that(".rssMarginalCor reads cor / z / b and validates length", { f <- .rrwStatLd() expect_length( - pecotmr:::.lassosumCorFromStat( + pecotmr:::.rssMarginalCor( list(cor = f$stat$cor), n = f$n, p = f$p @@ -869,19 +1254,28 @@ test_that(".lassosumCorFromStat reads cor / z / b and validates length", { f$p ) expect_equal( - pecotmr:::.lassosumCorFromStat(list(z = f$stat$z), n = f$n, p = f$p), + pecotmr:::.rssMarginalCor(list(z = f$stat$z), n = f$n, p = f$p), as.numeric(f$stat$z) / sqrt(f$n) ) expect_equal( - pecotmr:::.lassosumCorFromStat(list(b = f$stat$b), n = f$n, p = f$p), + pecotmr:::.rssMarginalCor(list(b = f$stat$b), n = f$n, p = f$p), as.numeric(f$stat$b) ) + # With its standard error, b is a z-score on any scale. + expect_equal( + pecotmr:::.rssMarginalCor( + list(b = 2 * f$stat$z, seb = rep(2, f$p)), + n = f$n, + p = f$p + ), + as.numeric(f$stat$z) / sqrt(f$n) + ) expect_error( - pecotmr:::.lassosumCorFromStat(list(), n = f$n, p = f$p), + pecotmr:::.rssMarginalCor(list(), n = f$n, p = f$p), "one of" ) expect_error( - pecotmr:::.lassosumCorFromStat( + pecotmr:::.rssMarginalCor( list(z = f$stat$z[-1]), n = f$n, p = f$p @@ -916,7 +1310,7 @@ test_that(".lassosumSelectLdQuadratic scores candidates by c'b / sqrt(b'Rb)", { f <- .rrwStatLd() set.seed(8) cb <- matrix(rnorm(f$p * 4), f$p, 4) - r <- pecotmr:::.lassosumSelectLdQuadratic(cb, f$stat$b, f$LD) + r <- pecotmr:::.lassosumSelectLdQuadratic(cb, f$stat$b, list(R = f$LD)) expect_equal(r$mode, "ldQuadratic") expect_true(r$index %in% seq_len(4)) expect_equal(r$beta, cb[, r$index]) @@ -1057,10 +1451,6 @@ test_that("MCMC / optimiser control arguments are guarded", { ncvregWeights(NULL, NULL, penalty = "SCAD", nfolds = 0), "nfolds.*Must be >= 1" ) - expect_error( - mrashWeights(NULL, NULL, initPriorSd = NA), - "initPriorSd.*May not be NA" - ) expect_error( computeCoefficientsGlasso(NULL, NULL, standardize = NA, numThreads = 1), "standardize.*May not be NA" @@ -1086,23 +1476,23 @@ test_that("RSS solver control arguments are guarded", { "maxiter.*Must be >= 1" ) expect_error( - scadRssWeights(stat = "nope", LD = NULL), + scadRssWeights(stat = "nope", ldReference = NULL), "stat.*Must be of type 'list'" ) expect_error( - scadRssWeights(stat = list(), LD = NULL, s = -1), + scadRssWeights(stat = list(), ldReference = NULL, s = -1), "s.*is not >= 0" ) expect_error( - mcpRssWeights(stat = "nope", LD = NULL), + mcpRssWeights(stat = "nope", ldReference = NULL), "stat.*Must be of type 'list'" ) expect_error( - mrashRssWeights(stat = "nope", LD = NULL, NULL, NULL, NULL, NULL), + mrashRssWeights(stat = "nope", ldReference = NULL), "stat.*Must be of type 'list'" ) expect_error( - mrmashRssWeights(stat = "nope", LD = NULL), + mrmashRssWeights(stat = "nope", ldReference = NULL), "stat.*Must be of type 'list'" ) }) diff --git a/tests/testthat/test_resultWriters.R b/tests/testthat/test_resultWriters.R index a263d443d..ed18d2da2 100644 --- a/tests/testthat/test_resultWriters.R +++ b/tests/testthat/test_resultWriters.R @@ -8,8 +8,8 @@ makeTestGenotypeHandle <- function() { new( "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", + path = "/tmp/test", + format = "plink2", snpInfo = data.frame(), nSamples = 0L, sampleIds = character(), @@ -33,7 +33,7 @@ makeTestGwasSumStats <- function(n = 5) { studyName = "test_trait", entry = list(gr), genome = "hg38", - ldSketch = makeTestGenotypeHandle() + ldReference = makeTestGenotypeHandle() ) } @@ -113,10 +113,10 @@ test_that("exportToVcf writes GwasSumStats to bgzipped VCF", { }) # ============================================================================= -# FineMappingResult to VCF +# Fine-mapping result to VCF # ============================================================================= -test_that("exportToVcf writes FineMappingResult to uncompressed VCF", { +test_that("exportToVcf writes a fine-mapping result to uncompressed VCF", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") @@ -153,10 +153,10 @@ test_that("exportToVcf(FineMapping): emits PIP + CS FORMAT fields", { }) # ============================================================================= -# FineMappingResult to BCF +# Fine-mapping result to BCF # ============================================================================= -test_that("exportToVcf writes FineMappingResult to BCF", { +test_that("exportToVcf writes a fine-mapping result to BCF", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") skip_if_not_installed("Rsamtools") @@ -212,10 +212,10 @@ test_that("exportToVcf writes FineMappingResult to BCF", { }) # ============================================================================= -# Empty FineMappingResult errors +# Empty fine-mapping result errors # ============================================================================= -test_that("exportToVcf errors on empty FineMappingResult", { +test_that("exportToVcf errors on an empty fine-mapping result", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") @@ -455,7 +455,7 @@ test_that("exportToVcf(FineMapping): a fit missing a variant leaves a gap", { studyName = c("studyA", "studyB"), entry = list(mkGr(), mkGr()), genome = "hg38", - ldSketch = makeTestGenotypeHandle() + ldReference = makeTestGenotypeHandle() ) } @@ -498,7 +498,7 @@ test_that("exportToVcf(SumStats): emits AF when MAF is present", { gr })), genome = "hg38", - ldSketch = makeTestGenotypeHandle() + ldReference = makeTestGenotypeHandle() ) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) @@ -526,7 +526,8 @@ test_that("exportToVcf(SumStats): .vcf.gz is renamed from .bgz", { }) # ============================================================================= -# FineMappingResult: explicit selectors, no-match error, composite/empty tags +# Fine-mapping result: explicit selectors, no-match error, composite/empty +# tags # ============================================================================= test_that("exportToVcf(FineMapping): selectors pick a single row", { @@ -547,7 +548,7 @@ test_that("exportToVcf(FineMapping): selectors pick a single row", { expect_true(file.exists(out)) }) -test_that("exportToVcf(FineMappingResult): no matching rows errors", { +test_that("exportToVcf(fine-mapping result): no matching rows errors", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fmr <- .makeMultiTupleQtlFmr() @@ -927,7 +928,7 @@ test_that("exportToBed combines several results into one table", { ) }) -test_that("exportToBed rejects a non-FineMappingResult", { +test_that("exportToBed rejects something that is not a result collection", { out <- withr::local_tempfile(fileext = ".bed") expect_error(exportToBed(data.frame(a = 1), out), "FineMappingResult") expect_error(exportToBed(list(), out), "at least one") @@ -1208,7 +1209,7 @@ test_that("exporting refuses a TwasWeights with no full-data fit", { ) }) -test_that("exporting refuses a FineMappingResult row with no fitted variants", { +test_that("exporting refuses a fine-mapping row with no fitted variants", { # Fine-mapping has no CV-only mode -- CV is attached on top of the fit -- # but the export checks rather than assumes it. fmr <- QtlFineMappingResult( @@ -1243,7 +1244,7 @@ test_that("exportToBed rejects a list that holds neither result type", { expect_error(exportToBed(list(), out), "at least one") expect_error( exportToBed(list(1, 2), out), - "TwasWeights or FineMappingResult" + "TwasWeights, QtlFineMappingResult or GwasFineMappingResult" ) }) @@ -1450,11 +1451,11 @@ test_that("columns = 'all' appends the rest of the source view", { # additive: the published columns keep their place, the rest follow expect_identical(fullCols[seq_along(baseCols)], baseCols) # "all" is a request for whatever is there, so it stays subject to the - # drop-empty rule. Every remaining view column is empty in this fixture - # (`gene`, `event`, `grange_*`), so it appends nothing and never removes - # anything. An explicitly NAMED column is kept even when empty -- that is - # what the next test checks. - expect_identical(fullCols, baseCols) + # drop-empty rule: of the remaining view columns only `theta` holds values + # in this fixture, so it alone is appended, while the empty `gene`, + # `event` and `grange_*` stay out. An explicitly NAMED column is kept even + # when empty -- that is what the next test checks. + expect_identical(setdiff(fullCols, baseCols), "theta") # the range columns an as.data.frame() adds duplicate chr/pos, so they # must not come back under a second name expect_false(any(c("seqnames", "width", "strand") %in% fullCols)) @@ -1833,7 +1834,7 @@ test_that("a weights export takes AF from the collection's LD panel", { # standardized-to-raw conversion would need, so its absence is worth # seeing rather than faking. data(twasWeightsExample, envir = environment()) - expect_null(ldSketch(twasWeightsExample)) + expect_null(ldReference(twasWeightsExample)) out <- withr::local_tempfile(fileext = ".bed") suppressMessages(exportToBed(twasWeightsExample, out)) expect_false(is_in("AF", names(read.delim(out, check.names = FALSE)))) @@ -1885,7 +1886,7 @@ test_that("both formats skip fine-mapping-derived weight rows alike", { # The BED path skipped them and the VCF path published them, so the two # disagreed about what a weights file contains. The rule is the same in # both: those weights are the fine-mapping posterior re-expressed, and the - # FineMappingResult says strictly more. + # fine-mapping result says strictly more. skip_if_not_installed("VariantAnnotation") data(twasWeightsExample, envir = environment()) derived <- is_in( @@ -1924,26 +1925,40 @@ test_that("a VCF of only fine-mapping-derived weights is refused", { test_that("a weights export reads AF off the collection's LD panel", { # A TwasWeights element records only alleles and a weight, so the panel is - # the only place a frequency can come from. This panel carries no `af`, so - # the column stays absent rather than being faked. + # the only place a frequency can come from. The bundled sketch panel + # records its variants' frequencies (from its .afreq), and they are what + # is published; a panel recording none leaves the column absent rather + # than faked. data(ctwasWeightsExample, twasWeightsExample, envir = environment()) - panel <- ldSketch(ctwasWeightsExample) + panel <- ldReference(ctwasWeightsExample) expect_false(is.null(panel)) lasso <- twasWeightsExample[ as.character(twasWeightsExample$method) == "lasso" ] expect_equal(nrow(lasso), 1L) - withPanel <- TwasWeights( - studyName = as.character(lasso$study), - context = as.character(lasso$context), - trait = as.character(lasso$trait), - method = as.character(lasso$method), - entry = list(.twrRowParts(lasso, 1L)), - ldSketch = panel + exported <- function(ref) { + withPanel <- TwasWeights( + studyName = as.character(lasso$study), + context = as.character(lasso$context), + trait = as.character(lasso$trait), + method = as.character(lasso$method), + entry = list(.twrRowParts(lasso, 1L)), + ldReference = ref + ) + out <- withr::local_tempfile(fileext = ".bed") + exportToBed(withPanel, out) + read.delim(out, check.names = FALSE) + } + tbl <- exported(panel) + rr <- SummarizedExperiment::rowRanges(panel) + expect_equal(tbl$AF, rr$AF[match(tbl$ID, .grVariantIds(rr))]) + expect_false(anyNA(tbl$AF)) + keep <- c("SNP", "A1", "A2") + noAf <- SummarizedExperiment::`rowData<-`( + panel, + value = SummarizedExperiment::rowData(panel)[, keep] ) - out <- withr::local_tempfile(fileext = ".bed") - exportToBed(withPanel, out) - expect_false(is_in("AF", names(read.delim(out, check.names = FALSE)))) + expect_false(is_in("AF", names(exported(noAf)))) }) test_that("a sumstats collection with no Z publishes no EZ", { @@ -1985,9 +2000,9 @@ test_that("a sumstats collection with no Z publishes no EZ", { # @noRd .pbw_jointWeights <- function(nVariant = 6L) { data(ctwasWeightsExample, envir = environment()) - panel <- ldSketch(ctwasWeightsExample) + panel <- ldReference(ctwasWeightsExample) vids <- .grVariantIds(SummarizedExperiment::rowRanges(panel)) - SummarizedExperiment::rowRanges(panel)$af <- seq( + SummarizedExperiment::rowRanges(panel)$AF <- seq( 0.05, 0.45, length.out = length(vids) @@ -2006,7 +2021,7 @@ test_that("a sumstats collection with no Z publishes no EZ", { variantIds = vids[seq_len(nVariant)], weights = w[seq_len(nVariant), , drop = FALSE] )), - ldSketch = panel + ldReference = panel ) } @@ -2027,9 +2042,9 @@ test_that("AF is published from the LD panel when it records one", { out <- withr::local_tempfile(fileext = ".bed") exportToBed(tw, out) bed <- read.delim(out, check.names = FALSE) - panel <- ldSketch(tw) + panel <- ldReference(tw) rr <- SummarizedExperiment::rowRanges(panel) - expected <- mcols(rr)$af[match(bed$ID, .grVariantIds(rr))] + expected <- mcols(rr)$AF[match(bed$ID, .grVariantIds(rr))] expect_equal(bed$AF, expected) }) @@ -2158,3 +2173,122 @@ test_that("a weight matrix with no columns publishes a header-only file", { ) ) }) + +# ---- THETA: the infinitesimal half of WGT ----------------------------------- + +.thetaFit <- function(nV = 12, theta = NULL) { + set.seed(1) + alpha <- matrix(runif(2 * nV), nrow = 2) + alpha <- alpha / rowSums(alpha) + mu <- matrix(rnorm(2 * nV), nrow = 2) + fit <- list( + alpha = alpha, + mu = mu, + mu2 = mu^2 + 0.1, + pip = runif(nV), + X_column_scale_factors = rep(1, nV) + ) + if (!is.null(theta)) { + fit$theta <- theta + } + fit +} + +.thetaFmr <- function(theta = NULL, nV = 12) { + vids <- sprintf("chr1:%d:A:T", seq_len(nV) * 1000) + fit <- .thetaFit(nV, theta) + tl <- buildTopLoci( + fit = fit, + csTables = NULL, + variantNames = vids, + method = "susie_inf" + ) + QtlFineMappingResult( + studyName = "s", + context = "c", + trait = "g", + method = "susie_inf", + entry = list(fineMappingRow( + variantIds = vids, + susieFit = fit, + topLoci = tl + )) + ) +} + +test_that("theta is the posterior effect's infinitesimal part, not an extra", { + nV <- 12 + th <- rnorm(nV, sd = 0.05) + fit <- .thetaFit(nV, th) + vids <- sprintf("chr1:%d:A:T", seq_len(nV) * 1000) + tl <- buildTopLoci( + fit = fit, + csTables = NULL, + variantNames = vids, + method = "susie_inf" + ) + sparse <- colSums(fit$alpha * fit$mu) + # coef.susie() sums the sparse and infinitesimal terms, so the published + # effect ALREADY contains theta -- publishing theta only exposes the split. + expect_equal(tl$posterior_mean, sparse + th, tolerance = 1e-10) + expect_equal(tl$posterior_theta, th, tolerance = 1e-10) + expect_equal( + tl$posterior_mean - tl$posterior_theta, + sparse, + tolerance = 1e-10 + ) +}) + +test_that("a fit with no infinitesimal term reports theta = 0, not NA", { + tl <- buildTopLoci( + fit = .thetaFit(12), + csTables = NULL, + variantNames = sprintf("chr1:%d:A:T", seq_len(12) * 1000), + method = "susie" + ) + expect_true(all(tl$posterior_theta == 0)) + expect_false(anyNA(tl$posterior_theta)) +}) + +test_that("THETA round-trips through both published formats", { + th <- rnorm(12, sd = 0.05) + fmr <- .thetaFmr(th) + want <- as.data.frame(topLoci(fmr, signalCutoff = 0))$theta + expect_equal(sort(want), sort(th), tolerance = 1e-10) + + bed <- withr::local_tempfile(fileext = ".bed") + exportToBed(fmr, bed) + expect_true(is_in("THETA", strsplit(readLines(bed, n = 1), "\t")[[1]])) + gotBed <- as.data.frame(topLoci( + readFineMappingResult(bed, weightStandardized = TRUE), + signalCutoff = 0 + ))$theta + expect_equal(sort(gotBed), sort(want), tolerance = 1e-5) + + vcf <- withr::local_tempfile(fileext = ".vcf.bgz") + exportToVcf(fmr, vcf) + hdr <- grep("^##FORMAT", readLines(gzfile(vcf)), value = TRUE) + expect_true(any(grepl("ID=THETA,", hdr))) + gotVcf <- as.data.frame(topLoci( + readFineMappingResult(vcf, weightStandardized = TRUE), + signalCutoff = 0 + ))$theta + expect_equal(sort(gotVcf), sort(want), tolerance = 1e-5) +}) + +test_that("THETA is omitted for collections that never recorded one", { + # Objects written before theta was published carry no posterior_theta, so + # the view yields NA and the drop-empty rule keeps it out of the file -- + # rather than inventing a column of zeros that claims the split is known. + # The example now records theta, so an older object is made from it. + data(qtlFineMappingExample) + old <- endoapply(qtlFineMappingExample, function(gr) { + S4Vectors::mcols(gr)$posterior_theta <- NULL + gr + }) + d <- as.data.frame(topLoci(old, signalCutoff = 0)) + expect_true(all(is.na(d$theta))) + bed <- withr::local_tempfile(fileext = ".bed") + exportToBed(old[1], bed) + expect_false(is_in("THETA", strsplit(readLines(bed, n = 1), "\t")[[1]])) +}) diff --git a/tests/testthat/test_rrDispatch.R b/tests/testthat/test_rrDispatch.R index aa4891614..b59be7ebe 100644 --- a/tests/testthat/test_rrDispatch.R +++ b/tests/testthat/test_rrDispatch.R @@ -18,7 +18,7 @@ test_that("susie-family weight wrappers never fit; they demand the fit", { expect_error(susieInfWeights(X = X, y = y), "no 'susieInf' fit supplied") }) -test_that("prsCsWeights dispatches to prsCs with correct arguments", { +test_that("prsCsWeights hands the PRS-CS sampler the right arguments", { set.seed(42) p <- 10 bhat <- rnorm(p, sd = 0.1) @@ -26,12 +26,16 @@ test_that("prsCsWeights dispatches to prsCs with correct arguments", { # Heterogeneous n with median != mean: this lets the test catch a regression # that swapped median(stat$n) for mean(stat$n) or sum(stat$n). # sorted: 10, 20, 30, 40, 50, 60, 70, 80, 90, 1000 -> median = 55, mean = 145. - stat <- list(b = bhat, n = c(10, 20, 30, 40, 50, 60, 70, 80, 90, 1000)) + stat <- list( + b = bhat, + n = c(10, 20, 30, 40, 50, 60, 70, 80, 90, 1000), + variantNames = .rrwIds(p) + ) captured <- new.env(parent = emptyenv()) local_mocked_bindings( - prsCs = function(bhat, R, n, ...) { + .prsCsRun = function(bhat, ld, n, ...) { captured$bhat <- bhat - captured$R <- R + captured$R <- ld$R captured$n <- n captured$dots <- list(...) list(betaEst = seq_len(length(bhat)) * 0.01) @@ -39,28 +43,28 @@ test_that("prsCsWeights dispatches to prsCs with correct arguments", { ) result <- prsCsWeights( stat = stat, - LD = R, + ldReference = .rrwLdMatrix(R), methodArgs = PrsCsOptions(maf = rep(0.3, p), nIter = 17) ) expect_equal(captured$bhat, bhat) - expect_equal(captured$R, R) + expect_equal(unname(captured$R), R) expect_equal(captured$n, 55) # median of stat$n, NOT mean (145) expect_equal(captured$dots$maf, rep(0.3, p)) expect_equal(captured$dots$nIter, 17) expect_equal(result, seq_len(p) * 0.01) }) -test_that("sdprWeights dispatches to sdpr with correct arguments", { +test_that("sdprWeights dispatches to the SDPR sampler with correct arguments", { set.seed(42) p <- 10 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - stat <- list(b = bhat, n = rep(456, p)) + stat <- list(b = bhat, n = rep(456, p), variantNames = .rrwIds(p)) captured <- new.env(parent = emptyenv()) local_mocked_bindings( - sdpr = function(bhat, R, n, ...) { + .sdprRun = function(bhat, ld, n, ...) { captured$bhat <- bhat - captured$R <- R + captured$R <- ld$R captured$n <- n captured$dots <- list(...) list(betaEst = seq_len(length(bhat)) * 0.02) @@ -68,18 +72,18 @@ test_that("sdprWeights dispatches to sdpr with correct arguments", { ) result <- sdprWeights( stat = stat, - LD = R, + ldReference = .rrwLdMatrix(R), methodArgs = SdprOptions(iter = 19, burn = 3) ) expect_equal(captured$bhat, bhat) - expect_equal(captured$R, R) + expect_equal(unname(captured$R), R) expect_equal(captured$n, 456) expect_equal(captured$dots$iter, 19) expect_equal(captured$dots$burn, 3) expect_equal(result, seq_len(p) * 0.02) }) -test_that("lassosumRssWeights dispatches to lassosumRss once per s value", { +test_that("lassosumRssWeights runs the lassosum path once per s value", { set.seed(42) p <- 10 bhat <- rnorm(p, sd = 0.1) @@ -88,14 +92,14 @@ test_that("lassosumRssWeights dispatches to lassosumRss once per s value", { R[i, i + 1] <- 0.4 R[i + 1, i] <- 0.4 } - stat <- list(b = bhat, n = rep(100, p)) + stat <- list(b = bhat, n = rep(100, p), variantNames = .rrwIds(p)) call_log <- new.env(parent = emptyenv()) call_log$calls <- list() local_mocked_bindings( - lassosumRss = function(bhat, R, n, ...) { + .lassosumRssPath = function(bhat, ld, n, ...) { call_log$calls <- c( call_log$calls, - list(list(bhat = bhat, R = R, n = n)) + list(list(bhat = bhat, ld = ld, n = n)) ) list( beta = cbind(rep(0, length(bhat)), rep(0.05, length(bhat))), @@ -106,27 +110,34 @@ test_that("lassosumRssWeights dispatches to lassosumRss once per s value", { ) lassosumRssWeights( stat = stat, - LD = R, + ldReference = .rrwLdMatrix(R), s = c(0.2, 0.9), selection = "minFbeta" ) expect_equal(length(call_log$calls), 2L) expect_equal(call_log$calls[[1]]$n, 100) expect_equal(length(call_log$calls[[1]]$bhat), p) - # R should differ between calls because s is different - expect_false(identical(call_log$calls[[1]]$R, call_log$calls[[2]]$R)) + # Each call carries its own s for the solver to apply to the one LD + # matrix, rather than a copy of the matrix shrunk for that s. + expect_equal(map_dbl(call_log$calls, c("ld", "shrink")), c(0.2, 0.9)) + expect_identical(call_log$calls[[1]]$ld$R, call_log$calls[[2]]$ld$R) + expect_equal(unname(call_log$calls[[1]]$ld$R), R) }) test_that("lassosumRssWeights defaults to LD-quadratic selection", { p <- 4 - stat <- list(cor = c(0.4, 0.1, 0, 0), n = rep(100, p)) + stat <- list( + cor = c(0.4, 0.1, 0, 0), + n = rep(100, p), + variantNames = .rrwIds(p) + ) R <- diag(p) R[1, 2] <- 0.5 R[2, 1] <- 0.5 expected <- c(1, 0, 0, 0) local_mocked_bindings( - lassosumRss = function(bhat, R, n, ...) { + .lassosumRssPath = function(bhat, ld, n, ...) { list( beta = cbind(expected, c(1, 1, 0, 0)), lambda = c(0.05, 0.01), @@ -135,7 +146,11 @@ test_that("lassosumRssWeights defaults to LD-quadratic selection", { } ) - result <- lassosumRssWeights(stat = stat, LD = R, s = 0.5) + result <- lassosumRssWeights( + stat = stat, + ldReference = .rrwLdMatrix(R), + s = 0.5 + ) expect_equal(c(result), expected) expect_equal( unname(attr(result, "lassosum_selection")["mode"]), @@ -145,11 +160,15 @@ test_that("lassosumRssWeights defaults to LD-quadratic selection", { test_that("lassosumRssWeights uses first-max tie behavior for LD-quadratic selection", { p <- 3 - stat <- list(cor = c(0.3, 0.3, 0), n = rep(100, p)) + stat <- list( + cor = c(0.3, 0.3, 0), + n = rep(100, p), + variantNames = .rrwIds(p) + ) R <- diag(p) local_mocked_bindings( - lassosumRss = function(bhat, R, n, ...) { + .lassosumRssPath = function(bhat, ld, n, ...) { list( beta = cbind(c(1, 0, 0), c(0, 1, 0)), lambda = c(0.05, 0.01), @@ -158,7 +177,11 @@ test_that("lassosumRssWeights uses first-max tie behavior for LD-quadratic selec } ) - result <- lassosumRssWeights(stat = stat, LD = R, s = 0.5) + result <- lassosumRssWeights( + stat = stat, + ldReference = .rrwLdMatrix(R), + s = 0.5 + ) expect_equal(c(result), c(1, 0, 0)) expect_equal( unname(attr(result, "lassosum_selection")["mode"]), @@ -168,12 +191,16 @@ test_that("lassosumRssWeights uses first-max tie behavior for LD-quadratic selec test_that("lassosumRssWeights still supports explicit min(fbeta)", { p <- 4 - stat <- list(cor = c(0.4, 0.1, 0, 0), n = rep(100, p)) + stat <- list( + cor = c(0.4, 0.1, 0, 0), + n = rep(100, p), + variantNames = .rrwIds(p) + ) R <- diag(p) expected <- c(1, 1, 0, 0) local_mocked_bindings( - lassosumRss = function(bhat, R, n, ...) { + .lassosumRssPath = function(bhat, ld, n, ...) { list( beta = cbind(c(1, 0, 0, 0), expected), lambda = c(0.05, 0.01), @@ -184,7 +211,7 @@ test_that("lassosumRssWeights still supports explicit min(fbeta)", { result <- lassosumRssWeights( stat = stat, - LD = R, + ldReference = .rrwLdMatrix(R), s = 0.5, selection = "minFbeta" ) @@ -346,38 +373,33 @@ test_that("mrashWeights actually calls lassoWeights for default beta.init", { lassoWeights = function(X, y) { called$lasso <- TRUE rep(0.01, ncol(X)) - }, - initPriorSd = function(X, y, n = 30) seq(0, 3, length.out = n) + } ) - mrashWeights(X, y) + suppressWarnings(mrashWeights(X, y)) expect_true(called$lasso) }) -test_that("mrashWeights calls init_prior_sd only when init_prior_sd = TRUE", { +test_that("mrashWeights leaves the prior grid to mr.ash unless one is given", { skip_if_not_installed("glmnet") set.seed(42) - n <- 50 - p <- 10 - X <- matrix(rnorm(n * p), nrow = n) - y <- X[, 1] * 0.5 + rnorm(n) - called <- new.env(parent = emptyenv()) - - # initPriorSd = TRUE: initPriorSd should be called - called$init <- FALSE + X <- matrix(rnorm(50 * 10), nrow = 50) + y <- X[, 1] * 0.5 + rnorm(50) + seen <- NULL + real <- susieR::mr.ash local_mocked_bindings( - lassoWeights = function(X, y) rep(0.01, ncol(X)), - initPriorSd = function(X, y, n = 30) { - called$init <- TRUE - seq(0, 3, length.out = n) + mr.ash = function(...) { + seen <<- list(...) + real(...) } ) - mrashWeights(X, y, initPriorSd = TRUE) - expect_true(called$init) - - # initPriorSd = FALSE: initPriorSd should NOT be called - called$init <- FALSE - mrashWeights(X, y, initPriorSd = FALSE) - expect_false(called$init) + # mr.ash's own default grid, built from the data's column scales. + suppressWarnings(mrashWeights(X, y)) + expect_false("sa2" %in% names(seen)) + grid <- c(0, 0.1, 0.5) + suppressWarnings( + mrashWeights(X, y, methodArgs = MrashOptions(sa2 = grid)) + ) + expect_equal(seen$sa2, grid) }) gc() diff --git a/tests/testthat/test_rrLassosum.R b/tests/testthat/test_rrLassosum.R index 1dcf44c9f..9e2be53bc 100644 --- a/tests/testthat/test_rrLassosum.R +++ b/tests/testthat/test_rrLassosum.R @@ -62,10 +62,10 @@ test_that("lassosumRssWeights calls lassosumRss and returns betaEst", { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } - stat <- list(b = bhat, n = rep(n, p)) + stat <- list(b = bhat, n = rep(n, p), variantNames = .rrwIds(p)) expected <- seq_len(p) * 0.02 local_mocked_bindings( - lassosumRss = function(bhat, R, n, ...) { + .lassosumRssPath = function(bhat, ld, n, ...) { list( beta = cbind(rep(0, length(bhat)), expected), lambda = c(0.05, 0.01), @@ -73,7 +73,11 @@ test_that("lassosumRssWeights calls lassosumRss and returns betaEst", { ) } ) - result <- lassosumRssWeights(stat = stat, LD = R, s = 0.5) + result <- lassosumRssWeights( + stat = stat, + ldReference = .rrwLdMatrix(R), + s = 0.5 + ) expect_equal(length(result), p) expect_true(is.numeric(result)) expect_equal(c(result), expected) @@ -90,10 +94,10 @@ test_that("lassosumRssWeights clamps correlation input before scaling", { # Construct bhat with max abs >= 1 to trigger the clamp branch bhat <- c(1.5, -0.2, 0.1, 0.05, -0.3) R <- diag(p) - stat <- list(b = bhat, n = rep(n, p)) + stat <- list(b = bhat, n = rep(n, p), variantNames = .rrwIds(p)) captured <- NULL local_mocked_bindings( - lassosumRss = function(bhat, R, n, ...) { + .lassosumRssPath = function(bhat, ld, n, ...) { captured <<- bhat list( beta = matrix(0, nrow = length(bhat), ncol = 2), @@ -104,7 +108,7 @@ test_that("lassosumRssWeights clamps correlation input before scaling", { ) result <- lassosumRssWeights( stat = stat, - LD = R, + ldReference = .rrwLdMatrix(R), s = 0.5, selection = "minFbeta" ) diff --git a/tests/testthat/test_rrMrAshRss.R b/tests/testthat/test_rrMrAshRss.R index 24c6d098a..52e0407e6 100644 --- a/tests/testthat/test_rrMrAshRss.R +++ b/tests/testthat/test_rrMrAshRss.R @@ -14,7 +14,8 @@ test_that("mrashRssWeights forwards arguments to susieR::mr.ash.rss", { stat <- list( b = bhat, seb = shat, - n = c(10, 20, 30, 40, 50, 60, 70, 80, 90, 1000) + n = c(10, 20, 30, 40, 50, 60, 70, 80, 90, 1000), + variantNames = .rrwIds(p) ) z_vec <- bhat / shat captured <- new.env(parent = emptyenv()) @@ -48,18 +49,17 @@ test_that("mrashRssWeights forwards arguments to susieR::mr.ash.rss", { ) result <- mrashRssWeights( stat = stat, - LD = R, + ldReference = .rrwLdMatrix(R), varY = 1.5, sigma2E = 0.4, s0 = c(0, 0.1, 0.2), w0 = c(0.5, 0.3, 0.2), - z = z_vec, - methodArgs = MrashOptions(tol = 1e-6) + methodArgs = MrashRssOptions(tol = 1e-6) ) expect_equal(captured$bhat, bhat) expect_equal(captured$shat, shat) expect_equal(captured$z, z_vec) - expect_equal(captured$R, R) + expect_equal(unname(captured$R), R) expect_equal(captured$var_y, 1.5) expect_equal(captured$n, 55) # median of stat$n, NOT mean (145) expect_equal(captured$sigma2_e, 0.4) @@ -81,10 +81,10 @@ test_that("mrashRssWeights returns a numeric vector of expected length", { bhat <- as.vector(cor(y, X)) shat <- rep(1 / sqrt(n - 1), p) R <- cor(X) - stat <- list(b = bhat, seb = shat, n = rep(n, p)) + stat <- list(b = bhat, seb = shat, n = rep(n, p), variantNames = .rrwIds(p)) w <- mrashRssWeights( stat = stat, - LD = R, + ldReference = .rrwLdMatrix(R), varY = var(y), sigma2E = NULL, s0 = c(0, 0.01, 0.1, 0.5), diff --git a/tests/testthat/test_rrMrash.R b/tests/testthat/test_rrMrash.R index f253730b9..14a593254 100644 --- a/tests/testthat/test_rrMrash.R +++ b/tests/testthat/test_rrMrash.R @@ -2,22 +2,6 @@ context("regularized_regression - mrash") # ---- mrashWeights ---- test_that("mrashWeights calls lassoWeights as default beta.init", { - skip_if_not_installed("glmnet") - set.seed(42) - n <- 50 - p <- 10 - X <- matrix(rnorm(n * p), nrow = n) - y <- X[, 1] * 0.5 + rnorm(n) - local_mocked_bindings( - lassoWeights = function(X, y) rep(0.01, ncol(X)), - initPriorSd = function(X, y, n = 30) seq(0, 3, length.out = n) - ) - result <- mrashWeights(X, y) - expect_true(is.numeric(result)) - expect_equal(length(result), p) -}) - -test_that("mrashWeights with initPriorSd = FALSE passes NULL sa2", { skip_if_not_installed("glmnet") set.seed(42) n <- 50 @@ -27,7 +11,7 @@ test_that("mrashWeights with initPriorSd = FALSE passes NULL sa2", { local_mocked_bindings( lassoWeights = function(X, y) rep(0.01, ncol(X)) ) - result <- mrashWeights(X, y, initPriorSd = FALSE) + result <- mrashWeights(X, y) expect_true(is.numeric(result)) expect_equal(length(result), p) }) diff --git a/tests/testthat/test_rrPenalizedRss.R b/tests/testthat/test_rrPenalizedRss.R index 1ef2f337b..65dce373a 100644 --- a/tests/testthat/test_rrPenalizedRss.R +++ b/tests/testthat/test_rrPenalizedRss.R @@ -155,8 +155,12 @@ test_that("penalizedRss MCP recovers signal direction", { y <- as.numeric(X %*% beta_true) + rnorm(n) bhat <- as.vector(cor(y, X)) R <- cor(X) - stat <- list(b = bhat, n = rep(n, p)) - w <- mcpRssWeights(stat = stat, LD = R, s = c(0.5, 0.9)) + stat <- list(b = bhat, n = rep(n, p), variantNames = .rrwIds(p)) + w <- mcpRssWeights( + stat = stat, + ldReference = .rrwLdMatrix(R), + s = c(0.5, 0.9) + ) expect_equal(length(w), p) expect_true(all(is.finite(w))) expect_gt(cor(w, beta_true), 0.4) @@ -172,8 +176,12 @@ test_that("penalizedRss SCAD recovers signal direction", { y <- as.numeric(X %*% beta_true) + rnorm(n) bhat <- as.vector(cor(y, X)) R <- cor(X) - stat <- list(b = bhat, n = rep(n, p)) - w <- scadRssWeights(stat = stat, LD = R, s = c(0.5, 0.9)) + stat <- list(b = bhat, n = rep(n, p), variantNames = .rrwIds(p)) + w <- scadRssWeights( + stat = stat, + ldReference = .rrwLdMatrix(R), + s = c(0.5, 0.9) + ) expect_equal(length(w), p) expect_true(all(is.finite(w))) expect_gt(cor(w, beta_true), 0.4) @@ -189,10 +197,10 @@ test_that("penalizedRss L0 recovers signal direction", { y <- as.numeric(X %*% beta_true) + rnorm(n) bhat <- as.vector(cor(y, X)) R <- cor(X) - stat <- list(b = bhat, n = rep(n, p)) + stat <- list(b = bhat, n = rep(n, p), variantNames = .rrwIds(p)) w <- l0learnRssWeights( stat = stat, - LD = R, + ldReference = .rrwLdMatrix(R), penalty = "L0", s = c(0.5, 0.9), lambda0 = exp(seq(log(0.001), log(0.5), length.out = 5)) @@ -210,8 +218,8 @@ test_that("scadRssWeights returns correct-length vector with attributes", { n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - stat <- list(b = bhat, n = rep(n, p)) - w <- scadRssWeights(stat = stat, LD = R, s = 0.5) + stat <- list(b = bhat, n = rep(n, p), variantNames = .rrwIds(p)) + w <- scadRssWeights(stat = stat, ldReference = .rrwLdMatrix(R), s = 0.5) expect_equal(length(w), p) expect_true(is.numeric(w)) sel <- attr(w, "penalized_rss_selection") @@ -225,8 +233,8 @@ test_that("mcpRssWeights returns correct-length vector with attributes", { n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - stat <- list(b = bhat, n = rep(n, p)) - w <- mcpRssWeights(stat = stat, LD = R, s = 0.5) + stat <- list(b = bhat, n = rep(n, p), variantNames = .rrwIds(p)) + w <- mcpRssWeights(stat = stat, ldReference = .rrwLdMatrix(R), s = 0.5) expect_equal(length(w), p) expect_true(is.numeric(w)) sel <- attr(w, "penalized_rss_selection") @@ -240,10 +248,10 @@ test_that("l0learnRssWeights returns correct-length vector with attributes", { n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - stat <- list(b = bhat, n = rep(n, p)) + stat <- list(b = bhat, n = rep(n, p), variantNames = .rrwIds(p)) w <- l0learnRssWeights( stat = stat, - LD = R, + ldReference = .rrwLdMatrix(R), penalty = "L0", s = 0.5, lambda0 = c(0.01, 0.1) diff --git a/tests/testthat/test_rrPrsCs.R b/tests/testthat/test_rrPrsCs.R index fb5e478ca..8342a4d7d 100644 --- a/tests/testthat/test_rrPrsCs.R +++ b/tests/testthat/test_rrPrsCs.R @@ -198,10 +198,10 @@ test_that("prsCsWeights calls prsCs and returns betaEst", { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } - stat <- list(b = bhat, n = rep(n, p)) + stat <- list(b = bhat, n = rep(n, p), variantNames = .rrwIds(p)) result <- prsCsWeights( stat = stat, - LD = R, + ldReference = .rrwLdMatrix(R), methodArgs = PrsCsOptions( maf = rep(0.3, p), nIter = 50, @@ -212,3 +212,54 @@ test_that("prsCsWeights calls prsCs and returns betaEst", { expect_equal(length(result), p) expect_true(is.numeric(result)) }) + +test_that("PRS-CS draws beta from the same posterior off a factor of the LD", { + # The factor sampler (Woodbury mean, Bhattacharya-Chakraborty-Mallick + # noise) draws differently from the dense Cholesky one, so the check is + # the distribution: the first draw, from psi = 1 and sigma = 1, must be + # N(A^-1 bhat, A^-1 / n) with A = R + I. + set.seed(12) + X <- matrix(rbinom(30 * 40, 2, 0.3), 30, 40) + F <- pecotmr:::.ldFactorFromDosage(X) + R <- crossprod(F) / (nrow(F) - 1) + effects <- replace(numeric(40), c(4, 20), c(0.2, -0.15)) + bhat <- as.vector(R %*% effects) + rnorm(40, sd = 0.03) + n <- 200L + A <- R + diag(40) + wantMean <- solve(A, bhat) + wantCov <- solve(A) / n + nDraws <- 3000L + draws <- vapply( + seq_len(nDraws), + function(s) { + pecotmr:::prsCsFactorCpp( + 1, + 0.5, + 1e-3, + bhat, + NULL, + n, + F, + 1L, + 0L, + 1L, + FALSE, + s + )$betaEst + }, + numeric(40) + ) + se <- sqrt(diag(wantCov) / nDraws) + expect_lt(max(abs(rowMeans(draws) - wantMean) / se), 4.5) + expect_equal(cov(t(draws)), wantCov, tolerance = 0.1) + # Each block also returns beta'A beta for sigma's update, so the chains' + # sigma, steady across seeds, must agree too; their beta means agree to + # Monte Carlo error. + chain <- function(fn, ld, seed) { + fn(1, 0.5, 1e-3, bhat, NULL, n, ld, 4000L, 500L, 5L, FALSE, seed) + } + dense <- chain(pecotmr:::prsCsCpp, list(R), 1L) + factor <- chain(pecotmr:::prsCsFactorCpp, F, 2L) + expect_equal(factor$sigmaEst, dense$sigmaEst, tolerance = 0.01) + expect_gt(cor(dense$betaEst, factor$betaEst), 0.9) +}) diff --git a/tests/testthat/test_rrSdpr.R b/tests/testthat/test_rrSdpr.R index a96930b62..6b6ac8840 100644 --- a/tests/testthat/test_rrSdpr.R +++ b/tests/testthat/test_rrSdpr.R @@ -219,10 +219,10 @@ test_that("sdprWeights calls sdpr and returns beta_est", { p <- 10 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - stat <- list(b = bhat, n = rep(100, p)) + stat <- list(b = bhat, n = rep(100, p), variantNames = .rrwIds(p)) result <- sdprWeights( stat = stat, - LD = R, + ldReference = .rrwLdMatrix(R), methodArgs = SdprOptions( iter = 50, burn = 10, diff --git a/tests/testthat/test_rrSignalRecovery.R b/tests/testthat/test_rrSignalRecovery.R index a76b4377c..fca5df91c 100644 --- a/tests/testthat/test_rrSignalRecovery.R +++ b/tests/testthat/test_rrSignalRecovery.R @@ -75,7 +75,6 @@ test_that("dprWeights with VB fitting recovers signal direction", { }) test_that("lassosumRssWeights recovers signal direction on simulated data", { - skip_if_not_installed("Rcpp") set.seed(2024) n <- 500 p <- 20 @@ -86,8 +85,16 @@ test_that("lassosumRssWeights recovers signal direction on simulated data", { bhat <- as.vector(cor(y, X)) R <- cor(X) # Heterogeneous n forces the median(stat$n) path; mean would be wrong. - stat <- list(b = bhat, n = c(rep(n, p - 1), 10 * n)) - w <- lassosumRssWeights(stat = stat, LD = R, s = c(0.2, 0.5, 0.9)) + stat <- list( + b = bhat, + n = c(rep(n, p - 1), 10 * n), + variantNames = .rrwIds(p) + ) + w <- lassosumRssWeights( + stat = stat, + ldReference = .rrwLdMatrix(R), + s = c(0.2, 0.5, 0.9) + ) expect_equal(length(w), p) expect_true(all(is.finite(w))) expect_gt(cor(w, beta_true), 0.5) diff --git a/tests/testthat/test_rrSusie.R b/tests/testthat/test_rrSusie.R index 4d56df314..118877d32 100644 --- a/tests/testthat/test_rrSusie.R +++ b/tests/testthat/test_rrSusie.R @@ -1,24 +1,5 @@ context("regularized_regression - susie") -# ---- initPriorSd ---- -test_that("initPriorSd returns correct number of values with expected properties", { - set.seed(123) - n <- 50 - p <- 10 - X <- matrix(rnorm(n * p), nrow = n) - y <- X[, 1] * 2 + rnorm(n) - - result <- initPriorSd(X, y) - expect_length(result, 30) - expect_equal(result[1], 0) - expect_true(all(diff(result) > 0)) - - result_15 <- initPriorSd(X, y, n = 15) - expect_length(result_15, 15) - expect_equal(result_15[1], 0) - expect_true(all(diff(result_15) > 0)) -}) - # ---- susieWeights ---- test_that("susieWeights returns zeros when no alpha/mu/X_column_scale_factors", { mock_fit <- list(pip = c(0.1, 0.2, 0.3)) diff --git a/tests/testthat/test_sumstatsQc.R b/tests/testthat/test_sumstatsQc.R index 2952b66fa..58aabf6fc 100644 --- a/tests/testthat/test_sumstatsQc.R +++ b/tests/testthat/test_sumstatsQc.R @@ -83,7 +83,10 @@ test_that("ldMismatchQc dentist returns a data frame with an outlier column", { p <- 20 R <- diag(p) z <- rnorm(p) - result <- ldMismatchQc(z, R = R, nSample = 1000, method = "dentist") + expect_warning( + result <- ldMismatchQc(z, R = R, nSample = 1000, method = "dentist"), + "below 2000" + ) expect_true(is.data.frame(result) || is.list(result)) expect_true("outlier" %in% names(result)) }) @@ -116,18 +119,6 @@ context("raiss") library(tidyverse) library(MASS) -# Helper: build LdData S4 from a ref_panel data.frame, correlation matrix, and blockMetadata -makeLdDataFromRefPanel <- function(R_mat, ref_panel, blockMetadata) { - ref_panel$chrom <- as.character(ref_panel$chrom) - ref_panel$variant_id <- as.character(ref_panel$variant_id) - variants_gr <- pecotmr:::.refPanelToGranges(ref_panel) - LdData( - correlation = R_mat, - variants = variants_gr, - blockMetadata = blockMetadata - ) -} - generateDummyData <- function( seed = 1, ref_panel_ordered = TRUE, @@ -202,6 +193,84 @@ test_that("Input validation for raiss works correctly", { )) }) +test_that("raiss refuses a plain list of block matrices", { + # Such a list does not say which variants each block holds; it used to + # come back as NULL with nothing said. + input_data <- generateDummyData() + R <- input_data$ldMatrix + expect_error( + raiss(input_data$ref_panel, input_data$known_zscores, list(R, R)), + "square LD matrix or an LdMatrix" + ) +}) + +test_that("raiss needs refPanel with a plain LD matrix", { + input_data <- generateDummyData() + expect_error( + raiss( + knownZscores = input_data$known_zscores, + ldMatrix = input_data$ldMatrix + ), + "`refPanel` is required" + ) +}) + +test_that("raiss takes an LdMatrix and uses its variants", { + set.seed(3) + p <- 30L + R <- 0.6^abs(outer(seq_len(p), seq_len(p), "-")) + pos <- seq(100L, by = 100L, length.out = p) + ref_panel <- data.frame( + chrom = "1", + pos = pos, + variant_id = sprintf("chr1:%d:A:G", pos), + A1 = "G", + A2 = "A" + ) + known <- ref_panel[seq_len(p) %% 3L != 0L, ] + known$z <- rnorm(nrow(known)) + full <- raiss( + ref_panel, + known, + ldMatrix = R, + r2Threshold = 0.3, + minimumLd = 1, + verbose = FALSE + ) + ld <- LdMatrix( + R, + variants = data.frame( + chrom = "chr1", + pos = pos, + SNP = ref_panel$variant_id, + A1 = "G", + A2 = "A" + ) + ) + # No refPanel: the LdMatrix's own variants supply it, so the z-scores + # label chromosomes canonically, as it does. + chr <- transform(known, chrom = "chr1") + expect_error( + raiss(knownZscores = chr, ldMatrix = ld, verbose = FALSE), + "chromosome labels" + ) + fromLd <- raiss( + knownZscores = known, + ldMatrix = ld, + r2Threshold = 0.3, + minimumLd = 1, + verbose = FALSE + ) + expect_equal( + arrange(fromLd$resultNofilter, variant_id)$z, + arrange(full$resultNofilter, variant_id)$z + ) + expect_error( + raiss(knownZscores = known, genotypes = ld), + "must be a genotype panel or a GenotypeMixture" + ) +}) + test_that("Default parameters for raiss work correctly", { input_data <- generateDummyData() result <- raiss( @@ -553,6 +622,13 @@ test_that("checkInversion correctly identifies inverse matrices in", { expect_true(checkInversion(sig_t, sig_t_inv)) }) +test_that("checkInversion reports a failed inversion as FALSE, not text", { + # all.equal() describes a mismatch as a string; passed through, that put + # text in the logical correctInversion column exactly when it failed. + sig_t <- matrix(c(1, 2, 3, 4), nrow = 2, ncol = 2) + expect_false(checkInversion(sig_t, diag(2))) +}) + test_that("varInBoundaries sets boundaries correctly", { lamb_test <- 0.05 var <- c(-1, 0, 0.5, 1.04, 1.05) @@ -605,56 +681,6 @@ test_that("invertMatRecursive handles errors and recurses correctly", { expect_error(invertMatRecursive(mat, lamb, rcond)) }) -# Test with Different Tolerance Levels -test_that("invertMatEigen behaves differently with varying tolerance levels", { - mat <- matrix(c(1, 0, 0, 1e-4), nrow = 2) - tol_high <- 1e-2 - tol_low <- 1e-6 - result_high_tol <- invertMatEigen(mat, tol_high) - result_low_tol <- invertMatEigen(mat, tol_low) - expect_true(!is.logical(all.equal(result_high_tol, result_low_tol))) -}) - -test_that("invertMatEigen handles non-square matrices", { - mat <- matrix(1:6, nrow = 2) - expect_error(invertMatEigen(mat)) -}) - -test_that("invertMatEigen returns the same matrix for an identity matrix", { - mat <- diag(2) - expected <- mat - actual <- invertMatEigen(mat) - expect_equal(actual, expected) -}) - -test_that("invertMatEigen returns a zero matrix for a zero matrix input", { - mat <- matrix(0, nrow = 2, ncol = 2) - expected <- mat - expect_error( - invertMatEigen(mat), - "Cannot invert the input matrix because all its eigen values are negative or close to zero" - ) -}) - -test_that("invertMatEigen handles matrices with negative eigenvalues", { - mat <- matrix(c(-2, 0, 0, -3), nrow = 2) - expect_silent(invertMatEigen(mat)) -}) - -test_that("invertMatEigen inverts a matrix that keeps a single eigenvector", { - # A near-rank-1 matrix puts >99.9% of the variance in one eigenvalue, so - # L == 1. That used to drop the eigenvector subscript to a vector and - # hand diag() a length-one value, which returns an identity matrix of - # THAT ORDER (diag(0.1) is 0x0) rather than a 1x1 matrix holding it. - v <- c(1, 1, 1) / sqrt(3) - mat <- 3 * outer(v, v) + diag(1e-9, 3) - actual <- invertMatEigen(mat) - expect_equal(dim(actual), c(3L, 3L)) - expect_equal(actual, t(actual)) - # The rank-1 pseudo-inverse reproduces the matrix it came from. - expect_equal(mat %*% actual %*% mat, mat, tolerance = 1e-6) -}) - # =========================================================================== # raissSingleMatrix edge cases # =========================================================================== @@ -776,796 +802,28 @@ test_that("raissSingleMatrixFromX returns known z when nothing to impute", { pos = seq(10, p * 10, 10), variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), - A2 = rep("G", p), - z = rnorm(p), - stringsAsFactors = FALSE - ) - X <- scale(matrix(sample(0:2, n * p, replace = TRUE), nrow = n)) - X[is.na(X)] <- 0 - colnames(X) <- ref_panel$variant_id - result <- raissSingleMatrixFromX( - ref_panel, - known_zscores, - X, - verbose = FALSE - ) - expect_true(is.list(result)) - expect_equal(result$resultNofilter, known_zscores) - expect_null(result$ldMat) -}) - -# =========================================================================== -# raiss() dispatch paths: single-matrix list and genotype_matrix list -# =========================================================================== - -test_that("raiss with single-matrix LD list dispatches to single matrix path", { - set.seed(42) - n_variants <- 20 - ref_panel <- data.frame( - chrom = rep(1, n_variants), - pos = seq(10, n_variants * 10, 10), - variant_id = paste0("rs", seq_len(n_variants)), - A1 = rep("A", n_variants), - A2 = rep("G", n_variants), - stringsAsFactors = FALSE - ) - n_known <- 10 - known_idx <- sort(sample(seq_len(n_variants), n_known)) - known_zscores <- data.frame( - chrom = rep(1, n_known), - pos = ref_panel$pos[known_idx], - variant_id = ref_panel$variant_id[known_idx], - A1 = ref_panel$A1[known_idx], - A2 = ref_panel$A2[known_idx], - z = rnorm(n_known), - stringsAsFactors = FALSE - ) - R <- diag(n_variants) - colnames(R) <- rownames(R) <- ref_panel$variant_id - - # Wrap in list structure with ldMatrices - LD_list <- list(ldMatrices = list(R)) - - result <- raiss( - ref_panel, - known_zscores, - ldMatrix = LD_list, - r2Threshold = 0, - minimumLd = 0, - verbose = FALSE - ) - expect_true(is.list(result)) - expect_true("resultNofilter" %in% names(result)) - expect_equal(nrow(result$resultNofilter), n_variants) -}) - -test_that("raiss with genotype_matrix list processes multiple blocks", { - set.seed(42) - n <- 50 - p <- 20 - # Each block has its own ref_panel subset matching the X columns - ref_panel <- data.frame( - chrom = rep(1, p), - pos = seq(10, p * 10, 10), - variant_id = paste0("rs", seq_len(p)), - A1 = rep("A", p), - A2 = rep("G", p), - stringsAsFactors = FALSE - ) - # Use only first block's variants as known (so second block has unknowns) - known_idx <- sort(sample(1:10, 5)) - known_zscores <- data.frame( - chrom = rep(1, length(known_idx)), - pos = ref_panel$pos[known_idx], - variant_id = ref_panel$variant_id[known_idx], - A1 = ref_panel$A1[known_idx], - A2 = ref_panel$A2[known_idx], - z = rnorm(length(known_idx)), - stringsAsFactors = FALSE - ) - X <- scale(matrix(sample(0:2, n * p, replace = TRUE), nrow = n)) - X[is.na(X)] <- 0 - colnames(X) <- ref_panel$variant_id - - # Use the full matrix as a single-element list - the simplest valid list input - X_list <- list(X) - - result <- raiss( - ref_panel, - known_zscores, - genotypeMatrix = X_list, - r2Threshold = 0, - minimumLd = 0, - verbose = FALSE - ) - expect_true(is.list(result)) - expect_true("resultNofilter" %in% names(result)) - expect_true(nrow(result$resultNofilter) > 0) - expect_null(result$ldMat) -}) - -test_that("raiss with genotype_matrix list returns NULL when all blocks fail", { - set.seed(42) - n <- 50 - p <- 10 - ref_panel <- data.frame( - chrom = rep(1, p), - pos = seq(10, p * 10, 10), - variant_id = paste0("rs", seq_len(p)), - A1 = rep("A", p), - A2 = rep("G", p), - stringsAsFactors = FALSE - ) - # known_zscores has no overlap with ref_panel - known_zscores <- data.frame( - chrom = rep(1, 3), - pos = c(200, 300, 400), - variant_id = paste0("other", 1:3), - A1 = rep("A", 3), - A2 = rep("G", 3), - z = rnorm(3), - stringsAsFactors = FALSE - ) - X <- scale(matrix(sample(0:2, n * p, replace = TRUE), nrow = n)) - X[is.na(X)] <- 0 - colnames(X) <- ref_panel$variant_id - X_list <- list(X[, 1:5, drop = FALSE], X[, 6:10, drop = FALSE]) - - result <- raiss( - ref_panel, - known_zscores, - genotypeMatrix = X_list, - verbose = FALSE - ) - expect_null(result) -}) - -# Block-Diagonal LD data generator for RAISS testing -# Corrected function to generate proper block-diagonal test data -generateBlockDiagonalTestData <- function( - seed = 123, - block_structure = "overlapping", - n_variants = 30 -) { - set.seed(seed) - - # Create reference panel with variants - ref_panel <- data.frame( - chrom = rep(1, n_variants), - pos = seq(1, n_variants * 10, 10), - variant_id = paste0("var", seq_len(n_variants)), - A1 = sample(c("A", "T", "G", "C"), n_variants, replace = TRUE), - A2 = sample(c("A", "T", "G", "C"), n_variants, replace = TRUE), - stringsAsFactors = FALSE - ) - - # Create known z-scores for every other variant - known_indices <- seq(1, n_variants, by = 2) - known_zscores <- data.frame( - chrom = rep(1, length(known_indices)), - pos = ref_panel$pos[known_indices], - variant_id = ref_panel$variant_id[known_indices], - A1 = ref_panel$A1[known_indices], - A2 = ref_panel$A2[known_indices], - z = rnorm(length(known_indices)), - stringsAsFactors = FALSE - ) - - # Define block boundaries based on requested structure - if (block_structure == "overlapping") { - block_boundaries <- list( - c(1, 11), # Block 1: variants 1-11 - c(11, 21), # Block 2: variants 11-21 (overlap at var11) - c(21, n_variants) # Block 3: variants 21-30 (overlap at var21) - ) - } else if (block_structure == "non_overlapping") { - block_boundaries <- list( - c(1, 10), - c(11, 20), - c(21, n_variants) - ) - } else if (block_structure == "uneven") { - block_boundaries <- list( - c(1, 5), - c(6, 20), - c(21, n_variants) - ) - } else if (block_structure == "many_small") { - block_size <- 5 - n_blocks <- ceiling(n_variants / block_size) - block_boundaries <- list() - for (i in seq_len(n_blocks)) { - startIdx <- (i - 1) * block_size + 1 - endIdx <- min(i * block_size, n_variants) - block_boundaries[[i]] <- c(startIdx, endIdx) - } - } else if (block_structure == "single_block") { - block_boundaries <- list(c(1, n_variants)) - } - - # First, create independent block matrices - block_matrices <- list() - for (i in seq_along(block_boundaries)) { - startIdx <- block_boundaries[[i]][1] - endIdx <- block_boundaries[[i]][2] - block_variant_ids <- ref_panel$variant_id[startIdx:endIdx] - n_block <- length(block_variant_ids) - - # Create the block matrix with correlations ONLY within the block - block_matrix <- matrix(0, nrow = n_block, ncol = n_block) - for (a in seq_len(n_block)) { - for (b in seq_len(n_block)) { - if (a == b) { - block_matrix[a, b] <- 1 - } else { - # Use positions within the block, not absolute positions - block_matrix[a, b] <- 0.95^abs(a - b) - } - } - } - rownames(block_matrix) <- block_variant_ids - colnames(block_matrix) <- block_variant_ids - - block_matrices[[i]] <- block_matrix - } - - # Create variant indices data frame - variantIndices <- data.frame( - variant_id = character(), - blockId = integer(), - stringsAsFactors = FALSE - ) - - for (i in seq_along(block_boundaries)) { - startIdx <- block_boundaries[[i]][1] - endIdx <- block_boundaries[[i]][2] - block_variant_ids <- ref_panel$variant_id[startIdx:endIdx] - - block_indices <- data.frame( - variant_id = block_variant_ids, - blockId = i, - stringsAsFactors = FALSE - ) - variantIndices <- rbind(variantIndices, block_indices) - } - - # Create block metadata - block_sizes <- map_dbl(block_boundaries, function(b) b[2] - b[1] + 1) - blockMetadata <- data.frame( - blockId = seq_along(block_boundaries), - chrom = rep(1, length(block_boundaries)), - size = block_sizes, - startIdx = map_dbl(seq_along(block_boundaries), function(i) { - # Adjust for 1-based indexing in R - if (i == 1) { - return(1) - } - # Count unique variants before this block - sum(map_dbl(seq_len(i - 1), function(j) { - # If there's an overlap with the next block, count one less - if ( - j < length(block_boundaries) && - block_boundaries[[j]][2] == block_boundaries[[j + 1]][1] - ) { - return(block_boundaries[[j]][2] - block_boundaries[[j]][1]) - } else { - return( - block_boundaries[[j]][2] - block_boundaries[[j]][1] + 1 - ) - } - })) + - 1 - }), - endIdx = map_dbl(seq_along(block_boundaries), function(i) { - # Count all unique variants up to and including this block - sum(map_dbl(seq_len(i), function(j) { - # If there's an overlap with the next block, count one less - if ( - j < i && - block_boundaries[[j]][2] == block_boundaries[[j + 1]][1] - ) { - return(block_boundaries[[j]][2] - block_boundaries[[j]][1]) - } else { - return( - block_boundaries[[j]][2] - block_boundaries[[j]][1] + 1 - ) - } - })) - }), - stringsAsFactors = FALSE - ) - - # Build the full matrix correctly ensuring proper block structure - # IMPORTANT: Initialize a matrix with zeros - ensure no correlations between blocks - all_variant_ids <- unique(variantIndices$variant_id) - LD_matrix_full <- matrix( - 0, - nrow = length(all_variant_ids), - ncol = length(all_variant_ids) - ) - rownames(LD_matrix_full) <- all_variant_ids - colnames(LD_matrix_full) <- all_variant_ids - - # For each block, fill in only the relevant section of the full matrix - for (i in seq_along(block_matrices)) { - block_matrix <- block_matrices[[i]] - block_vars <- rownames(block_matrix) - - for (var_a in block_vars) { - for (var_b in block_vars) { - LD_matrix_full[var_a, var_b] <- block_matrix[var_a, var_b] - } - } - } - - # Create the block structure for RAISS - LD_matrix_blocks <- list( - ldMatrices = block_matrices, - variantIndices = variantIndices, - blockMetadata = blockMetadata, - ldVariants = all_variant_ids - ) - - return(list( - ref_panel = ref_panel, - known_zscores = known_zscores, - LD_matrix_full = LD_matrix_full, - LD_matrix_blocks = LD_matrix_blocks, - variantIndices = variantIndices, - block_boundaries = block_boundaries, - blockMetadata = blockMetadata - )) -} - -test_that("full matrix and block processing produce identical results", { - # Only test non-overlapping structures for exact z-score matching - block_structures <- c("non_overlapping", "single_block") - - for (structure in block_structures) { - test_data <- generateBlockDiagonalTestData( - seed = 123, - block_structure = structure - ) - - # Prepare ld_data as LdData S4 for partitionLdMatrix - ld_data <- makeLdDataFromRefPanel( - test_data$LD_matrix_full, - test_data$ref_panel, - test_data$blockMetadata - ) - - # For non-overlapping structures, use partitionLdMatrix - partitioned <- partitionLdMatrix( - ld_data, - mergeSmallBlocks = FALSE - ) - - # Run RAISS with full matrix - result_full <- raiss( - refPanel = test_data$ref_panel, - knownZscores = test_data$known_zscores, - ldMatrix = test_data$LD_matrix_full, - lamb = 0.01, - rcond = 0.01, - r2Threshold = 0.3, - minimumLd = 1, - verbose = FALSE - ) - - # Run RAISS with partitioned blocks - result_blocks <- raiss( - refPanel = test_data$ref_panel, - knownZscores = test_data$known_zscores, - ldMatrix = partitioned, - lamb = 0.01, - rcond = 0.01, - r2Threshold = 0.3, - minimumLd = 1, - verbose = FALSE - ) - - # For non-overlapping blocks, we compare all variants - result_full_sorted <- result_full$resultNofilter %>% arrange(variant_id) - result_blocks_sorted <- result_blocks$resultNofilter %>% - arrange(variant_id) - - # Compare variant IDs - expect_equal( - sort(result_full$resultNofilter$variant_id), - sort(result_blocks$resultNofilter$variant_id), - info = paste("Variant IDs should match for", structure) - ) - - # Compare z-scores with appropriate tolerance - expect_equal( - result_full_sorted$z, - result_blocks_sorted$z, - tolerance = 0.01, - info = paste("Z-scores should match for", structure) - ) - - # Compare filtered results if present - if ( - !is.null(result_full$resultFilter) && - !is.null(result_blocks$resultFilter) && - nrow(result_full$resultFilter) > 0 && - nrow(result_blocks$resultFilter) > 0 - ) { - expect_equal( - sort(result_full$resultFilter$variant_id), - sort(result_blocks$resultFilter$variant_id), - info = paste("Filtered variant IDs should match for", structure) - ) - - result_full_filter_sorted <- result_full$resultFilter %>% - arrange(variant_id) - result_blocks_filter_sorted <- result_blocks$resultFilter %>% - arrange(variant_id) - - expect_equal( - result_full_filter_sorted$z, - result_blocks_filter_sorted$z, - tolerance = 0.01, - info = paste("Filtered Z-scores should match for", structure) - ) - } - } -}) - -test_that("overlapping blocks keep variant IDs but may differ in z", { - # Test only overlapping structure - test_data <- generateBlockDiagonalTestData( - seed = 123, - block_structure = "overlapping" - ) - - # Run RAISS with full matrix - result_full <- raiss( - refPanel = test_data$ref_panel, - knownZscores = test_data$known_zscores, - ldMatrix = test_data$LD_matrix_full, - lamb = 0.01, - rcond = 0.01, - r2Threshold = 0.3, - minimumLd = 1, - verbose = FALSE - ) - - # Run RAISS with block processing - result_blocks <- raiss( - refPanel = test_data$ref_panel, - knownZscores = test_data$known_zscores, - ldMatrix = test_data$LD_matrix_blocks, - lamb = 0.01, - rcond = 0.01, - r2Threshold = 0.3, - minimumLd = 1, - verbose = FALSE - ) - - # Test 1: Verify all variants are present in both results - expect_equal( - sort(result_full$resultNofilter$variant_id), - sort(result_blocks$resultNofilter$variant_id), - info = "Both methods should have the same set of variant IDs" - ) - - # Test 2: For overlapping blocks, verify boundary variants exist and have valid values - # Identify boundary variants - boundary_variants <- character(0) - for (i in seq_len(length(test_data$block_boundaries) - 1)) { - overlap_pos <- test_data$block_boundaries[[i]][2] - boundary_variants <- c(boundary_variants, paste0("var", overlap_pos)) - } - - # Verify boundary variants exist in results - expect_true( - all(boundary_variants %in% result_blocks$resultNofilter$variant_id), - info = "All boundary variants should be present in block results" - ) - - # Verify boundary variants have valid z-scores - boundaryResults <- result_blocks$resultNofilter %>% - filter(variant_id %in% boundary_variants) - - expect_true( - all(!is.na(boundaryResults$z)), - info = "Boundary variants should have valid z-scores in block results" - ) - - # Test 3: Verify non-boundary variants have z-scores with reasonable range - non_boundaryResults <- result_blocks$resultNofilter %>% - filter(!variant_id %in% boundary_variants) - - expect_true( - all(!is.na(non_boundaryResults$z)), - info = "Non-boundary variants should have valid z-scores" - ) - - expect_true( - all(abs(non_boundaryResults$z) < 10), - info = "Non-boundary variant z-scores should be in reasonable range" - ) - - # We deliberately do NOT compare z-score values between full matrix and block processing - # for overlapping blocks, as differences are expected and valid -}) - -test_that("raiss handles block boundaries correctly", { - # Generate test data with overlapping blocks - test_data <- generateBlockDiagonalTestData( - seed = 456, - block_structure = "overlapping" - ) - - # Define the thresholds explicitly - test_R2_threshold <- 0.3 - test_minimum_ld <- 1 - - # Run RAISS with block processing - result <- raiss( - refPanel = test_data$ref_panel, - knownZscores = test_data$known_zscores, - ldMatrix = test_data$LD_matrix_blocks, - lamb = 0.01, - rcond = 0.01, - r2Threshold = test_R2_threshold, - minimumLd = test_minimum_ld, - verbose = FALSE - ) - - # First verify that the required columns exist in the results - expect_true( - "variant_id" %in% names(result$resultNofilter), - info = "resultNofilter should contain a variant_id column" - ) - - expect_true( - "raissR2" %in% names(result$resultNofilter), - info = "resultNofilter should contain a raissR2 column" - ) - - expect_true( - "raissLdScore" %in% names(result$resultNofilter), - info = "resultNofilter should contain a raissLdScore column" - ) - - # Check that we have only one entry per variant ID (no duplicates) - expect_equal( - length(unique(result$resultNofilter$variant_id)), - length(result$resultNofilter$variant_id), - info = "Result should have no duplicate variant IDs" - ) - - # Check that boundary variants have reasonable values - boundary_variants <- character(0) - for (i in seq_len(length(test_data$block_boundaries) - 1)) { - overlap_pos <- test_data$block_boundaries[[i]][2] - boundary_variants <- c(boundary_variants, paste0("var", overlap_pos)) - } - - # Verify that boundary variants exist in the results - expect_true( - all(boundary_variants %in% result$resultNofilter$variant_id), - info = "All boundary variants should be present in the results" - ) - - # Get the boundary variant results - boundaryResults <- result$resultNofilter %>% - filter(variant_id %in% boundary_variants) - - # Check R-squared values for non-NA boundary variants - non_na_r2 <- boundaryResults$raissR2[!is.na(boundaryResults$raissR2)] - if (length(non_na_r2) > 0) { - expect_true( - all(non_na_r2 >= 0 & non_na_r2 <= 1), - info = "Non-NA boundary variant R-squared values should be between 0 and 1" - ) - } - - # Check LD scores for non-NA boundary variants - non_na_ld <- boundaryResults$raissLdScore[ - !is.na(boundaryResults$raissLdScore) - ] - if (length(non_na_ld) > 0) { - expect_true( - all(non_na_ld >= 0), - info = "Non-NA boundary variant LD scores should be non-negative" - ) - } - - # Verify that pre-filtering and post-filtering steps handle boundary variants correctly - if (!is.null(result$resultFilter) && nrow(result$resultFilter) > 0) { - # First check if filtered results have the required columns - expect_true( - "variant_id" %in% names(result$resultFilter), - info = "resultFilter should contain a variant_id column" - ) - - expect_true( - "raissR2" %in% names(result$resultFilter), - info = "resultFilter should contain a raissR2 column" - ) - - expect_true( - "raissLdScore" %in% names(result$resultFilter), - info = "resultFilter should contain a raissLdScore column" - ) - - # Check which boundary variants passed the filtering - boundary_in_filtered <- boundary_variants %in% - result$resultFilter$variant_id - - if (any(boundary_in_filtered)) { - # Get the filtered boundary variants - boundary_filtered <- result$resultFilter %>% - filter(variant_id %in% boundary_variants) - - # Check that non-NA R-squared values meet the threshold - non_na_r2_filtered <- boundary_filtered$raissR2[ - !is.na(boundary_filtered$raissR2) - ] - if (length(non_na_r2_filtered) > 0) { - expect_true( - all(non_na_r2_filtered >= test_R2_threshold), - info = paste( - "Non-NA filtered boundary variant R-squared values should meet the threshold of", - test_R2_threshold - ) - ) - } - - # Check that non-NA LD scores meet the threshold - non_na_ld_filtered <- boundary_filtered$raissLdScore[ - !is.na(boundary_filtered$raissLdScore) - ] - if (length(non_na_ld_filtered) > 0) { - expect_true( - all(non_na_ld_filtered >= test_minimum_ld), - info = paste( - "Non-NA filtered boundary variant LD scores should meet the threshold of", - test_minimum_ld - ) - ) - } - } - } -}) - -test_that("partitionLdMatrix integrates correctly with RAISS", { - test_data <- generateBlockDiagonalTestData( - seed = 456, - block_structure = "non_overlapping" - ) - - ld_data <- makeLdDataFromRefPanel( - test_data$LD_matrix_full, - test_data$ref_panel, - test_data$blockMetadata - ) - - partitioned <- partitionLdMatrix( - ld_data, - mergeSmallBlocks = FALSE - ) - - result_full <- raiss( - refPanel = test_data$ref_panel, - knownZscores = test_data$known_zscores, - ldMatrix = test_data$LD_matrix_full, - lamb = 0.01, - rcond = 0.01, - r2Threshold = 0.3, - minimumLd = 1, - verbose = FALSE - ) - - result_partitioned <- raiss( - refPanel = test_data$ref_panel, - knownZscores = test_data$known_zscores, - ldMatrix = partitioned, - lamb = 0.01, - rcond = 0.01, - r2Threshold = 0.3, - minimumLd = 1, - verbose = FALSE - ) - - result_full_sorted <- result_full$resultNofilter %>% arrange(variant_id) - result_partitioned_sorted <- result_partitioned$resultNofilter %>% - arrange(variant_id) - - expect_equal( - result_full_sorted$variant_id, - result_partitioned_sorted$variant_id, - info = "Variant IDs should match" - ) - - expect_equal( - result_full_sorted$z, - result_partitioned_sorted$z, - tolerance = 1e-4, - info = "Z-scores should match" - ) -}) - -# Test 3: Boundary overlap handling -test_that("boundary overlaps are handled correctly", { - test_data <- generateBlockDiagonalTestData( - seed = 789, - block_structure = "overlapping" - ) - - result_blocks <- raiss( - refPanel = test_data$ref_panel, - knownZscores = test_data$known_zscores, - ldMatrix = test_data$LD_matrix_blocks, - lamb = 0.01, - rcond = 0.01, - r2Threshold = 0.1, - minimumLd = 1, - verbose = FALSE - ) - - variant_counts <- table(test_data$variantIndices$variant_id) - boundary_vars <- names(variant_counts[variant_counts > 1]) - - for (var in boundary_vars) { - expect_equal( - sum(result_blocks$resultNofilter$variant_id == var), - 1, - info = paste("Boundary variant", var, "should appear once") - ) - } - - expect_equal( - nrow(result_blocks$resultNofilter), - length(unique(result_blocks$resultNofilter$variant_id)), - info = "No duplicate variants in results" - ) -}) - -# Test 4: Single-block case -test_that("RAISS handles single-block list correctly", { - test_data <- generateBlockDiagonalTestData( - seed = 202, - block_structure = "single_block" - ) - - result_full <- raiss( - refPanel = test_data$ref_panel, - knownZscores = test_data$known_zscores, - ldMatrix = test_data$LD_matrix_full, - lamb = 0.01, - rcond = 0.01, - r2Threshold = 0.3, - minimumLd = 1, - verbose = FALSE + A2 = rep("G", p), + z = rnorm(p), + stringsAsFactors = FALSE ) - - result_single_block <- raiss( - refPanel = test_data$ref_panel, - knownZscores = test_data$known_zscores, - ldMatrix = test_data$LD_matrix_blocks, - lamb = 0.01, - rcond = 0.01, - r2Threshold = 0.3, - minimumLd = 1, + X <- scale(matrix(sample(0:2, n * p, replace = TRUE), nrow = n)) + X[is.na(X)] <- 0 + colnames(X) <- ref_panel$variant_id + result <- raissSingleMatrixFromX( + ref_panel, + known_zscores, + X, verbose = FALSE ) - - result_full_sorted <- result_full$resultNofilter %>% arrange(variant_id) - result_single_block_sorted <- result_single_block$resultNofilter %>% - arrange(variant_id) - - expect_equal( - result_full_sorted$z, - result_single_block_sorted$z, - tolerance = 1e-6, - info = "Z-scores should match for single block" - ) + expect_true(is.list(result)) + expect_equal(result$resultNofilter, known_zscores) + expect_null(result$ldMat) }) +# =========================================================================== +# raiss() dispatch paths: single-matrix list and genotype_matrix list +# =========================================================================== + # ============================================================================ # Tests for SVD-based genotype matrix path (raissSingleMatrixFromX) # ============================================================================ @@ -1623,6 +881,35 @@ generateXTestData <- function(n = 200, p = 100, n_known = 50, seed = 42) { ) } +# The SVD route on a standardized genotype matrix. raiss() takes genotypes +# only as a panel, which it standardizes itself, so these numeric checks call +# the route it hands that matrix to. +.raissX <- function( + refPanel, + knownZscores, + X, + lamb = 0.01, + rcond = 0.01, + svdTol = 1e-8, + r2Threshold = 0.6, + minimumLd = 5, + verbose = FALSE +) { + pecotmr:::.raissGenotypePath( + refPanel, + knownZscores, + X, + list( + lamb = lamb, + rcond = rcond, + svdTol = svdTol, + r2Threshold = r2Threshold, + minimumLd = minimumLd, + verbose = verbose + ) + ) +} + test_that("safeSvd basic functionality", { set.seed(1) mat <- matrix(rnorm(20), nrow = 5, ncol = 4) @@ -1671,10 +958,10 @@ test_that("X path matches R path: basic equivalence (n > p)", { minimumLd = 0, verbose = FALSE ) - result_X <- raiss( + result_X <- .raissX( data$ref_panel, data$known_zscores, - genotypeMatrix = data$X, + data$X, lamb = 0.01, svdTol = 1e-12, r2Threshold = 0, @@ -1719,10 +1006,10 @@ test_that("X path matches R path: n < p regime", { minimumLd = 0, verbose = FALSE ) - result_X <- raiss( + result_X <- .raissX( data$ref_panel, data$known_zscores, - genotypeMatrix = data$X, + data$X, lamb = 0.01, svdTol = 1e-12, r2Threshold = 0, @@ -1747,6 +1034,66 @@ test_that("X path matches R path: n < p regime", { ) }) + +test_that("the genotype and LD routes drop the same weak directions", { + # Blocks of near-identical columns: a few large eigenvalues and many tiny + # ones, so rcond's cutoff removes directions the ridge alone would keep. + set.seed(17) + n <- 150 + p <- 40 + base <- matrix(sample(0:2, n * 5, replace = TRUE), nrow = n) + X_raw <- base[, rep(1:5, each = 8)] + flips <- cbind(sample(n, 6 * p, replace = TRUE), rep(seq_len(p), each = 6)) + X_raw[flips] <- sample(0:2, nrow(flips), replace = TRUE) + ref_panel <- data.frame( + chrom = 1, + pos = seq_len(p), + variant_id = paste0("rs", seq_len(p)), + A1 = "A", + A2 = "G" + ) + X <- `colnames<-`(scale(X_raw), ref_panel$variant_id) + R <- cor(X_raw) + dimnames(R) <- list(ref_panel$variant_id, ref_panel$variant_id) + known_idx <- which(seq_len(p) %% 4L != 0L) + known <- ref_panel[known_idx, ] + known$z <- rnorm(nrow(known)) + ridged <- `diag<-`(R[known_idx, known_idx], 1.01) + ev <- eigen(ridged, symmetric = TRUE, only.values = TRUE)$values + expect_true(any(ev < 0.01 * ev[[1L]])) + + viaLd <- raiss( + ref_panel, + known, + ldMatrix = R, + r2Threshold = 0, + minimumLd = 0, + verbose = FALSE + )$resultNofilter + viaX <- .raissX( + ref_panel, + known, + X, + svdTol = 1e-12, + r2Threshold = 0, + minimumLd = 0 + )$resultNofilter + expect_equal(viaX$z, viaLd$z, tolerance = 1e-8) + expect_equal(viaX$Var, viaLd$Var, tolerance = 1e-8) + expect_equal(viaX$raissLdScore, viaLd$raissLdScore, tolerance = 1e-8) + # Without the cutoff the genotype route keeps those directions and its + # imputation differs. + uncut <- .raissX( + ref_panel, + known, + X, + rcond = 0, + svdTol = 1e-12, + r2Threshold = 0, + minimumLd = 0 + )$resultNofilter + expect_false(isTRUE(all.equal(uncut$z, viaLd$z, tolerance = 1e-6))) +}) test_that("X path matches R path: n >> p regime", { data <- generateXTestData(n = 500, p = 50, n_known = 25, seed = 99) @@ -1760,10 +1107,10 @@ test_that("X path matches R path: n >> p regime", { minimumLd = 0, verbose = FALSE ) - result_X <- raiss( + result_X <- .raissX( data$ref_panel, data$known_zscores, - genotypeMatrix = data$X, + data$X, lamb = 0.01, svdTol = 1e-12, r2Threshold = 0, @@ -1792,10 +1139,10 @@ test_that("X path matches R path: varying lambda", { minimumLd = 0, verbose = FALSE ) - result_X <- raiss( + result_X <- .raissX( data$ref_panel, data$known_zscores, - genotypeMatrix = data$X, + data$X, lamb = lamb, svdTol = 1e-12, r2Threshold = 0, @@ -1833,10 +1180,10 @@ test_that("X path handles all-known edge case", { z = rnorm(nrow(data$ref_panel)), stringsAsFactors = FALSE ) - result <- raiss( + result <- .raissX( data$ref_panel, all_known, - genotypeMatrix = data$X, + data$X, verbose = FALSE ) expect_equal(nrow(result$resultNofilter), nrow(data$ref_panel)) @@ -1855,10 +1202,10 @@ test_that("X path handles single unknown variant", { minimumLd = 0, verbose = FALSE ) - result_X <- raiss( + result_X <- .raissX( data$ref_panel, data$known_zscores, - genotypeMatrix = data$X, + data$X, lamb = 0.01, svdTol = 1e-12, r2Threshold = 0, @@ -1875,10 +1222,10 @@ test_that("X path handles single unknown variant", { test_that("X path handles single known variant", { data <- generateXTestData(n = 100, p = 50, n_known = 1, seed = 20) - result_X <- raiss( + result_X <- .raissX( data$ref_panel, data$known_zscores, - genotypeMatrix = data$X, + data$X, lamb = 0.01, svdTol = 1e-12, r2Threshold = 0, @@ -1902,10 +1249,10 @@ test_that("X path R2 filtering matches R path", { minimumLd = 5, verbose = FALSE ) - result_X <- raiss( + result_X <- .raissX( data$ref_panel, data$known_zscores, - genotypeMatrix = data$X, + data$X, lamb = 0.01, svdTol = 1e-12, r2Threshold = 0.6, @@ -1923,7 +1270,9 @@ test_that("X path R2 filtering matches R path", { ) }) -test_that("raw genotype_matrix path differs from the legacy LD path", { +test_that("the SVD route needs standardized genotypes", { + # Why raiss() standardizes a panel's dosages itself: raw dosages through + # the same route give different answers from the LD path. set.seed(1) n <- 80 p <- 40 @@ -1970,20 +1319,20 @@ test_that("raw genotype_matrix path differs from the legacy LD path", { minimumLd = 0, verbose = FALSE ) - result_raw_X <- raiss( + result_raw_X <- .raissX( ref_panel, known_zscores, - genotypeMatrix = X_raw, + X_raw, lamb = 0.01, svdTol = 1e-8, r2Threshold = 0.6, minimumLd = 0, verbose = FALSE ) - result_scaled_X <- raiss( + result_scaled_X <- .raissX( ref_panel, known_zscores, - genotypeMatrix = X_scaled, + X_scaled, lamb = 0.01, svdTol = 1e-12, r2Threshold = 0.6, @@ -2005,20 +1354,30 @@ test_that("raw genotype_matrix path differs from the legacy LD path", { expect_equal(ld_sorted$raissR2, scaled_sorted$raissR2, tolerance = 1e-10) }) -test_that("raiss rejects both ldMatrix and genotype_matrix", { +test_that("raiss rejects both ldMatrix and genotypes", { data <- generateXTestData(n = 50, p = 20, n_known = 10, seed = 1) expect_error( raiss( data$ref_panel, data$known_zscores, ldMatrix = data$R, - genotypeMatrix = data$X + genotypes = data$X ), "not both" ) }) -test_that("raiss rejects neither ldMatrix nor genotype_matrix", { +test_that("raiss refuses genotypes that are not a panel", { + # A bare matrix leaves centring, scaling, column order and allele coding + # to the caller, and gets every one of them wrong silently. + data <- generateXTestData(n = 50, p = 20, n_known = 10, seed = 1) + expect_error( + raiss(data$ref_panel, data$known_zscores, genotypes = data$X), + "`genotypes` must be a genotype panel or a GenotypeMixture" + ) +}) + +test_that("raiss rejects neither ldMatrix nor genotypes", { data <- generateXTestData(n = 50, p = 20, n_known = 10, seed = 1) expect_error( raiss(data$ref_panel, data$known_zscores), @@ -2026,6 +1385,47 @@ test_that("raiss rejects neither ldMatrix nor genotype_matrix", { ) }) +test_that("raiss imputes from a genotype panel through the SVD route", { + # The panel's dosages are standardized here and the p x p matrix is never + # formed: the fit is the SVD route's on the same standardized dosages. + set.seed(11) + panel <- readGenotypes(test_path("test_data", "test_variants.bed"))[1:30, ] + ref_panel <- pecotmr:::.refVariantsFromLdRef(panel) + known <- ref_panel[seq_len(30L) %% 3L != 0L, ] + known$z <- rnorm(nrow(known)) + expect_message( + fromPanel <- raiss(knownZscores = known, genotypes = panel), + "SVD-based" + ) + direct <- .raissX( + ref_panel, + known, + pecotmr:::.ldRefFactor(panel, seq_len(30L)), + verbose = FALSE + ) + expect_equal(fromPanel$resultNofilter, direct$resultNofilter) + expect_error( + raiss(knownZscores = known, ldMatrix = panel), + "Pass genotypes as `genotypes`" + ) +}) + +test_that("the SVD route reports its progress when verbose", { + data <- generateXTestData(n = 60, p = 20, n_known = 10, seed = 3) + expect_message( + res <- .raissX( + data$ref_panel, + data$known_zscores, + data$X, + r2Threshold = 0, + minimumLd = 0, + verbose = TRUE + ), + "Processing genotype matrix" + ) + expect_equal(nrow(res$resultNofilter), nrow(data$ref_panel)) +}) + test_that("X path with collinear variants matches R path", { set.seed(55) n <- 150 @@ -2079,10 +1479,10 @@ test_that("X path with collinear variants matches R path", { minimumLd = 0, verbose = FALSE ) - result_X <- raiss( + result_X <- .raissX( ref_panel, known_zscores, - genotypeMatrix = X, + X, lamb = 0.01, svdTol = 1e-12, r2Threshold = 0, @@ -2101,7 +1501,6 @@ test_that("X path with collinear variants matches R path", { ) }) - context("RAISS missing-variant imputation in TWAS pipelines") # Previous tests covered `twasWeightsSumstatPipeline(imputeMissing = ...)`, @@ -2196,8 +1595,24 @@ test_that("slalom honours ldMethod when given genotypes", { ) invisible(slalom(zScore = z, X = X, ldMethod = "gcta")) expect_equal(seen, "gcta") + # The sample estimator reads the lead column off X's LD factor instead, + # never forming the matrix. + seen <- NULL invisible(slalom(zScore = z, X = X)) - expect_equal(seen, "sample") + expect_null(seen) +}) + +test_that("slalom from genotypes matches slalom from their LD", { + set.seed(12) + X <- matrix(sample(0:2, 80 * 7, replace = TRUE), nrow = 80, ncol = 7) + X[, 4] <- 2 + X[c(3, 17), 2] <- NA + colnames(X) <- paste0("snp", seq_len(7)) + z <- rnorm(7) + expect_equal( + slalom(zScore = z, X = X), + slalom(zScore = z, R = computeLd(X)) + ) }) test_that("slalom still refuses both or neither of R and X", { @@ -3020,7 +2435,6 @@ test_that("CS95 variants are ordered by decreasing PIP", { expect_true(all(diff(cs_pips) <= .Machine$double.eps)) }) - context("summaryStatsQc") # NOTE @@ -3028,7 +2442,7 @@ context("summaryStatsQc") # The variant-content QC (MAF/INFO/N) is pure data.frame filtering via # .applyContentFilters; no external genome / dbSNP packages required. # All pecotmr-native steps (.applyContentFilters, .applySkipRegion, -# .matchAgainstSketch, .applyLdMismatchQcToEntry) run +# .matchAgainstLdRef, .applyLdMismatchQcToEntry) run # for real on the synthetic fixture. # =========================================================================== @@ -3038,8 +2452,8 @@ context("summaryStatsQc") .ssQ_makeHandle <- function(snp_n = 8L, n_samples = 60L) { new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), CHR = rep("1", snp_n), @@ -3081,7 +2495,7 @@ context("summaryStatsQc") studyName = studyName, entry = list(.ssQ_makeEntryGr(snp_ids, positions)), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) } @@ -3159,7 +2573,7 @@ test_that("summaryStatsQc: infoCutoff > 0 with no INFO column errors", { expect_error( summaryStatsQc( ss, - sumstatsFilterArgs = SumstatsFilterParam(infoCutoff = 0.5) + sumstatsFilterParam = SumstatsFilterParam(infoCutoff = 0.5) ), "infoCutoff > 0 requires every entry to carry an INFO column" ) @@ -3183,12 +2597,12 @@ test_that("summaryStatsQc: PIP screen runs AFTER allele harmonization", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) out <- summaryStatsQc( ss, - signalScreenArgs = SignalScreenParam(pip = 0.5), - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + signalScreenParam = SignalScreenParam(pip = 0.5), + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) snps <- as.character(S4Vectors::mcols(out[[1L]])$SNP) expect_false("rsX" %in% snps) # dropped by harmonization @@ -3210,12 +2624,12 @@ test_that("summaryStatsQc: PIP screen off leaves the harmonized set intact", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) out <- summaryStatsQc( ss, - signalScreenArgs = SignalScreenParam(pip = 0), - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + signalScreenParam = SignalScreenParam(pip = 0), + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) snps <- as.character(S4Vectors::mcols(out[[1L]])$SNP) # SNP is re-keyed to the panel-harmonized id (chr:pos:A2:A1) after @@ -3257,12 +2671,12 @@ test_that("summaryStatsQc: harmonization re-keys SNP and sign-flips Z", { studyName = "g1", entry = list(.ssQ_makeFlipEntryGr()), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) out <- summaryStatsQc( ss, - signalScreenArgs = SignalScreenParam(pip = 0), - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + signalScreenParam = SignalScreenParam(pip = 0), + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) e <- out[[1L]] o <- order(GenomicRanges::start(e)) @@ -3277,16 +2691,16 @@ test_that("summaryStatsQc: harmonization re-keys SNP and sign-flips Z", { # never drop the variant # --------------------------------------------------------------------------- -test_that(".ldSketchMatchIds repairs tag ids and leaves clean labels alone", { +test_that(".ldRefMatchIds repairs tag ids and leaves clean labels alone", { h <- .ssQ_makeHandleVid() # ids chr1:100:G:A .. chr1:800:G:A, A1=A A2=G h@snpInfo$SNP[h@snpInfo$BP == 200L] <- "chr1:200:INS:A" - ids <- pecotmr:::.ldSketchMatchIds(h) + ids <- pecotmr:::.ldRefMatchIds(h) # the tag id is re-rendered from the panel's own A2/A1 columns ... expect_equal(ids[2L], "chr1:200:G:A") # ... and every other label is untouched. - expect_equal(ids[-2L], pecotmr:::.ldSketchVariantIds(h)[-2L]) + expect_equal(ids[-2L], pecotmr:::.ldRefVariantIds(h)[-2L]) # the raw accessor still answers the panel FILE's label (.afreq keys on it) - expect_equal(pecotmr:::.ldSketchVariantIds(h)[2L], "chr1:200:INS:A") + expect_equal(pecotmr:::.ldRefVariantIds(h)[2L], "chr1:200:INS:A") }) test_that(".raissUnsafeToImpute does not refuse a tag-allele id", { @@ -3318,11 +2732,11 @@ test_that("harmonization keeps a variant on a tag-named panel position", { N = c(1000L, 1000L) ) # control: both variants match the panel and survive - out0 <- pecotmr:::.matchAgainstSketch(df, h, matchMinProp = 0) + out0 <- pecotmr:::.matchAgainstLdRef(df, h, matchMinProp = 0) expect_setequal(pecotmr:::parseVariantId(out0$SNP)$pos, c(100L, 200L)) # tag the pos-200 panel id (A1/A2 columns stay the real alleles) h@snpInfo$SNP[h@snpInfo$BP == 200L] <- "chr1:200:INS:A" - outT <- pecotmr:::.matchAgainstSketch(df, h, matchMinProp = 0) + outT <- pecotmr:::.matchAgainstLdRef(df, h, matchMinProp = 0) # the tag costs nothing: both variants survive, with unchanged Z expect_setequal(pecotmr:::parseVariantId(outT$SNP)$pos, c(100L, 200L)) expect_equal(outT$SNP, out0$SNP) @@ -3336,18 +2750,18 @@ test_that("a tag-named panel entry survives the end-to-end sketch subset", { studyName = "g1", entry = list(.ssQ_makeEntryGr()), genome = "hg19", - ldSketch = h + ldReference = h ) out <- summaryStatsQc( ss, - signalScreenArgs = SignalScreenParam(pip = 0), - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + signalScreenParam = SignalScreenParam(pip = 0), + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) snp <- as.character(S4Vectors::mcols(out[[1L]])$SNP) expect_true("chr1:200:G:A" %in% snp) # the retained sketch keeps the panel row the QC'd entry still refers to expect_true( - "chr1:200:G:A" %in% pecotmr:::.ldSketchMatchIds(ldSketch(out)) + "chr1:200:G:A" %in% pecotmr:::.ldRefMatchIds(ldReference(out)) ) }) @@ -3357,8 +2771,8 @@ test_that("the sketch survives a chr:pos:A1:A2 panel (PLINK .bim order)", { # allele fields are already valid DNA. A panel keyed the other way round -- # which is how a PLINK .bim writes ids, whereas a .pvar writes REF:ALT and # is already canonical -- matched nothing under string equality, so - # .subsetSketchToIds() silently emptied the sketch and RSS fine-mapping / - # TWAS weights aborted later with "not present in the LD sketch panel". + # .subsetLdRefToIds() silently emptied the sketch and RSS fine-mapping / + # TWAS weights aborted later with "not present in the LD reference". h <- .ssQ_makeHandleVid() si <- snpInfo(h) h@snpInfo$SNP <- paste0("chr1:", si$BP, ":", si$A1, ":", si$A2) @@ -3368,14 +2782,14 @@ test_that("the sketch survives a chr:pos:A1:A2 panel (PLINK .bim order)", { snp_ids = paste0("chr1:", c(100L, 200L, 300L, 400L), ":G:A") )), genome = "hg19", - ldSketch = h + ldReference = h ) out <- summaryStatsQc( ss, - signalScreenArgs = SignalScreenParam(pip = 0), - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + signalScreenParam = SignalScreenParam(pip = 0), + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) - kept <- pecotmr:::.ldSketchMatchIds(ldSketch(out)) + kept <- pecotmr:::.ldRefMatchIds(ldReference(out)) expect_length(kept, 4L) expect_setequal( pecotmr:::parseVariantId(kept)$pos, @@ -3386,13 +2800,13 @@ test_that("the sketch survives a chr:pos:A1:A2 panel (PLINK .bim order)", { test_that("summaryStatsQc: slalom z-mismatch resolves sign-flipped variants", { # Pre-fix regression: a sign-flipped variant kept its input-orientation SNP, # which is absent from the panel, so .applyLdMismatchQcToEntry errored with - # "absent from the ldSketch panel". After the harmonization re-key the SNP - # matches the panel and slalom QC runs to completion. + # "absent from the ldReference panel". After the harmonization re-key the + # SNP matches the panel and slalom QC runs to completion. ss <- GwasSumStats( studyName = "g1", entry = list(.ssQ_makeFlipEntryGr()), genome = "hg19", - ldSketch = .ssQ_makeHandleVid() + ldReference = .ssQ_makeHandleVid() ) local_mocked_bindings( extractBlockGenotypes = .ssQ_mockExtractor(), @@ -3417,8 +2831,8 @@ test_that("summaryStatsQc: slalom z-mismatch resolves sign-flipped variants", { out <- summaryStatsQc( ss, ldMismatchQcMethod = "slalom", - signalScreenArgs = SignalScreenParam(pip = 0), - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + signalScreenParam = SignalScreenParam(pip = 0), + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) ) snp <- as.character(S4Vectors::mcols(out[[1L]])$SNP) @@ -3429,14 +2843,15 @@ test_that("summaryStatsQc: slalom z-mismatch resolves sign-flipped variants", { test_that("summaryStatsQc: ldMismatchQc reconciles a chr-prefix difference", { # Panel SNP ids are non-chr-prefixed positional; QC re-keys the entry to the # canonical chr-prefixed form, so the opt-in z-mismatch panel match must - # reconcile the prefix (previously errored "absent from the ldSketch panel"). + # reconcile the prefix (previously errored "absent from the ldReference + # panel"). h <- .ssQ_makeHandle() h@snpInfo$SNP <- paste0("1:", snpInfo(h)$BP, ":G:A") # non-chr-prefixed ss <- GwasSumStats( studyName = "g1", entry = list(.ssQ_makeEntryGr()), genome = "hg19", - ldSketch = h + ldReference = h ) local_mocked_bindings( extractBlockGenotypes = .ssQ_mockExtractor(), @@ -3461,8 +2876,8 @@ test_that("summaryStatsQc: ldMismatchQc reconciles a chr-prefix difference", { out <- summaryStatsQc( ss, ldMismatchQcMethod = "slalom", - signalScreenArgs = SignalScreenParam(pip = 0), - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + signalScreenParam = SignalScreenParam(pip = 0), + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) ) expect_gte(length(out[[1L]]), 1L) @@ -3555,9 +2970,9 @@ test_that("summaryStatsQc: PIP screen triggers when no variant has signal", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) - res <- summaryStatsQc(ss, signalScreenArgs = SignalScreenParam(pip = 0.99)) + res <- summaryStatsQc(ss, signalScreenParam = SignalScreenParam(pip = 0.99)) ea <- qcInfo(res)$entryAudit[[1L]] expect_true(isTRUE(ea$pipScreenSkipped)) expect_match(ea$pipScreenReason, "no signals above PIP threshold") @@ -3568,14 +2983,14 @@ test_that("summaryStatsQc: harmonized variants count is recorded", { ss <- .ssQ_makeGwasSumStats() res <- summaryStatsQc(ss) ea <- qcInfo(res)$entryAudit[[1L]] - expect_equal(ea$matchedAgainstSketch, 4L) + expect_equal(ea$matchedAgainstLdReference, 4L) }) test_that("summaryStatsQc: options block records the curated knobs", { ss <- .ssQ_makeGwasSumStats() res <- summaryStatsQc( ss, - sumstatsFilterArgs = SumstatsFilterParam( + sumstatsFilterParam = SumstatsFilterParam( removeIndels = TRUE, removeStrandAmbiguous = FALSE, nCutoff = 10 @@ -3595,7 +3010,7 @@ test_that("summaryStatsQc: round-trips QtlSumStats inputs", { trait = "t1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) res <- summaryStatsQc(ss) expect_s4_class(res, "QtlSumStats") @@ -3669,7 +3084,7 @@ test_that("summaryStatsQc(effectiveN=TRUE): counts, no N -> N == N_eff", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) res <- summaryStatsQc(ss) # 4*case*control/(case+control) per variant. @@ -3687,7 +3102,7 @@ test_that("summaryStatsQc(effectiveN=TRUE): counts + N -> counts win", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) expect_message(summaryStatsQc(ss), "overridden by effective N") res <- summaryStatsQc(ss) @@ -3713,7 +3128,7 @@ test_that("summaryStatsQc(effectiveN=FALSE): counts + N -> raw N", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) res <- summaryStatsQc(ss, effectiveN = FALSE) expect_true(all(.ssQ_entryNByPos(res[[1L]]) == 1000)) @@ -3729,7 +3144,7 @@ test_that("summaryStatsQc(effectiveN=FALSE): counts -> raw total", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) res <- summaryStatsQc(ss, effectiveN = FALSE) # Raw total n_case + n_control per variant. @@ -3744,7 +3159,7 @@ test_that("summaryStatsQc(effectiveN=TRUE): study scalars fill all variants", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle(), + ldReference = .ssQ_makeHandle(), nCase = 100, nControl = 900 ) @@ -3765,7 +3180,7 @@ test_that("summaryStatsQc: study nSample is the level-4 fallback", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle(), + ldReference = .ssQ_makeHandle(), nSample = 4321 ) res <- summaryStatsQc(ss) @@ -3787,7 +3202,7 @@ test_that("summaryStatsQc: QtlSumStats tuple nSample falls back too", { trait = "t1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle(), + ldReference = .ssQ_makeHandle(), nSample = 838 ) res <- summaryStatsQc(ss) @@ -3807,7 +3222,7 @@ test_that("summaryStatsQc: counts beat nSample, and an N column beats it", { studyName = "g1", entry = list(gr1), genome = "hg19", - ldSketch = .ssQ_makeHandle(), + ldReference = .ssQ_makeHandle(), nSample = 4321 ) res1 <- summaryStatsQc(ss1) @@ -3818,7 +3233,7 @@ test_that("summaryStatsQc: counts beat nSample, and an N column beats it", { studyName = "g1", entry = list(.ssQ_makeEntryGr()), genome = "hg19", - ldSketch = .ssQ_makeHandle(), + ldReference = .ssQ_makeHandle(), nSample = 4321 ) res2 <- summaryStatsQc(ss2) # .ssQ_makeEntryGr carries N = 1000 @@ -3844,7 +3259,7 @@ test_that("summaryStatsQc: quantitative QtlSumStats: no effective N", { trait = "t1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) res <- summaryStatsQc(ss) expect_true(all(.ssQ_entryNByPos(res[[1L]]) == 1000)) @@ -3865,7 +3280,7 @@ test_that("summaryStatsQc: ldMismatchQcMethod 'dentist' walks the LD branch", { positions = seq(100L, by = 100L, length.out = 8L) )), genome = "hg19", - ldSketch = .ssQ_makeHandleVid(snp_n = 8L) + ldReference = .ssQ_makeHandleVid(snp_n = 8L) ) local_mocked_bindings( extractBlockGenotypes = .ssQ_mockExtractor(), @@ -3893,12 +3308,17 @@ test_that("summaryStatsQc: impute = TRUE invokes RAISS, records counts", { positions = full_positions[1:4] )), genome = "hg19", - ldSketch = .ssQ_makeHandle(snp_n = 8L, n_samples = 60L) + ldReference = .ssQ_makeHandle(snp_n = 8L, n_samples = 60L) ) local_mocked_bindings( extractBlockGenotypes = .ssQ_mockExtractor(), - raiss = function(refPanel, knownZscores, genotypeMatrix, ...) { + .raissGenotypePath = function( + refPanel, + knownZscores, + genotypeMatrix, + p + ) { # Pretend RAISS imputed two of the missing panel variants (rs5, rs6) # with synthetic z-scores. added <- refPanel[ @@ -3917,7 +3337,7 @@ test_that("summaryStatsQc: impute = TRUE invokes RAISS, records counts", { res <- summaryStatsQc( ss, impute = TRUE, - imputeArgs = RaissParam(flank = 500) + raissParam = RaissParam(flank = 500) ) ea <- qcInfo(res)$entryAudit[[1L]] expect_equal(ea$raissTotalVariants, 6L) @@ -3944,7 +3364,7 @@ test_that("summaryStatsQc: impute scopes panel/dosage to the region", { c(100L, 200L, 300L, 400L) )), genome = "hg19", - ldSketch = .ssQ_makeHandle(snp_n = 8L, n_samples = 60L) + ldReference = .ssQ_makeHandle(snp_n = 8L, n_samples = 60L) ) inner <- .ssQ_mockExtractor(n_samples = 60L) local_mocked_bindings( @@ -3958,7 +3378,7 @@ test_that("summaryStatsQc: impute scopes panel/dosage to the region", { suppressWarnings(summaryStatsQc( ss, impute = TRUE, - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) )) expect_gt(length(cap$idx), 0L) # No read reaches past the region window's 4 panel variants. @@ -3976,7 +3396,7 @@ test_that("summaryStatsQc: impute with a NULL raiss records 0 imputed", { positions = full_positions[1:4] )), genome = "hg19", - ldSketch = .ssQ_makeHandle(snp_n = 8L, n_samples = 60L) + ldReference = .ssQ_makeHandle(snp_n = 8L, n_samples = 60L) ) local_mocked_bindings( @@ -4079,7 +3499,7 @@ test_that("summaryStatsQc: QtlSumStats log lines carry the tuple label", { trait = "qtrait", entry = list(.ssQ_makeEntryGr()), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) local_mocked_bindings( extractBlockGenotypes = .ssQ_mockExtractor(), @@ -4091,7 +3511,6 @@ test_that("summaryStatsQc: QtlSumStats log lines carry the tuple label", { expect_match(joined, "\\[qstudy/qctx/qtrait\\] QC summary") }) - context("sumstatsQc internal helpers") # =========================================================================== @@ -4101,8 +3520,8 @@ context("sumstatsQc internal helpers") .ssh_makeHandle <- function(snp_n = 6L, n_samples = 30L) { new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), CHR = rep("1", snp_n), @@ -4246,12 +3665,12 @@ test_that("entry GRanges round-trips through df conversion", { }) # =========================================================================== -# .refVariantsFromSketch +# .refVariantsFromLdRef # =========================================================================== -test_that(".refVariantsFromSketch: extracts chr/pos/alleles from snpInfo", { +test_that(".refVariantsFromLdRef: extracts chr/pos/alleles from snpInfo", { h <- .ssh_makeHandle() - rv <- pecotmr:::.refVariantsFromSketch(h) + rv <- pecotmr:::.refVariantsFromLdRef(h) expect_equal(rv$chrom, rep("1", 6)) # "chr" stripped expect_equal(rv$pos, c(100L, 200L, 300L, 400L, 500L, 600L)) expect_equal(rv$variant_id, paste0("rs", 1:6)) @@ -4421,7 +3840,7 @@ test_that("summaryStatsQc: surfaces the sanity audit, honours the knobs", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) res <- summaryStatsQc(ss) ea <- qcInfo(res)$entryAudit[[1L]] @@ -4429,7 +3848,7 @@ test_that("summaryStatsQc: surfaces the sanity audit, honours the knobs", { # Disable the knob: zero-effect rows should remain. res2 <- summaryStatsQc( ss, - sumstatsCleaningArgs = SumstatsCleaningParam(dropZeroEffect = FALSE) + sumstatsCleaningParam = SumstatsCleaningParam(dropZeroEffect = FALSE) ) ea2 <- qcInfo(res2)$entryAudit[[1L]] expect_null(ea2$sanityChecks$zeroEffectDropped) @@ -4477,10 +3896,10 @@ test_that(".applySkipRegion: rejects non-character non-GRanges input", { }) # =========================================================================== -# .matchAgainstSketch +# .matchAgainstLdRef # =========================================================================== -test_that(".matchAgainstSketch: errors when neither Z nor BETA is present", { +test_that(".matchAgainstLdRef: errors when neither Z nor BETA is present", { df <- data.frame( chrom = "1", pos = 100L, @@ -4490,12 +3909,12 @@ test_that(".matchAgainstSketch: errors when neither Z nor BETA is present", { stringsAsFactors = FALSE ) expect_error( - pecotmr:::.matchAgainstSketch(df, .ssh_makeHandle(), matchMinProp = 0), + pecotmr:::.matchAgainstLdRef(df, .ssh_makeHandle(), matchMinProp = 0), "must contain at least one of Z or BETA" ) }) -test_that(".matchAgainstSketch: errors when A1/A2 columns are missing", { +test_that(".matchAgainstLdRef: errors when A1/A2 columns are missing", { df <- data.frame( chrom = "1", pos = 100L, @@ -4504,12 +3923,12 @@ test_that(".matchAgainstSketch: errors when A1/A2 columns are missing", { stringsAsFactors = FALSE ) expect_error( - pecotmr:::.matchAgainstSketch(df, .ssh_makeHandle(), matchMinProp = 0), + pecotmr:::.matchAgainstLdRef(df, .ssh_makeHandle(), matchMinProp = 0), "must contain A1 and A2 columns" ) }) -test_that(".matchAgainstSketch: harmonizes the input against the sketch", { +test_that(".matchAgainstLdRef: harmonizes the input against the sketch", { df <- data.frame( chrom = c("1", "1"), pos = c(100L, 200L), @@ -4519,7 +3938,7 @@ test_that(".matchAgainstSketch: harmonizes the input against the sketch", { Z = c(1.0, 2.0), stringsAsFactors = FALSE ) - out <- pecotmr:::.matchAgainstSketch( + out <- pecotmr:::.matchAgainstLdRef( df, .ssh_makeHandle(), matchMinProp = 0 @@ -4549,7 +3968,7 @@ test_that(".applyLdMismatchQcToEntry: drops variants absent from the sketch", { # A variant can survive study-side QC while its LD-panel partner is removed # by the panel MAF/MAC/missingness filter, so it is absent from the sketch # the QC lookup sees. .panelVariantFilter passes such a variant through and - # leaves the drop to .ldFromSketch's onMissing, so the z-mismatch lookup + # leaves the drop to .ldFromRef's onMissing, so the z-mismatch lookup # drops it (recording the count) instead of aborting the run. local_mocked_bindings( extractBlockGenotypes = .ssh_mockExtractor(), @@ -4619,18 +4038,58 @@ test_that(".qcKrigingFlip: no-orphan entry is unchanged (drop is a no-op)", { expect_setequal(out$df$SNP, paste0("rs", 1:6)) }) +test_that("the kriging and mismatch checks read an entry's panel once", { + # Both run on the same panel-supported variants, so the reference is read + # once for the two, and the panel's drop is recorded once. + local_mocked_bindings( + extractBlockGenotypes = .ssh_mockExtractor(), + .package = "pecotmr" + ) + reads <- 0L + real <- pecotmr:::.qcPanelSupportedLd + local_mocked_bindings( + .qcPanelSupportedLd = function(...) { + reads <<- reads + 1L + real(...) + }, + .package = "pecotmr" + ) + df <- data.frame( + SNP = c(paste0("rs", 1:6), "ghost"), + Z = c(seq(1.0, by = 0.5, length.out = 6L), 2.0), + N = rep(1000L, 7L), + stringsAsFactors = FALSE + ) + state <- list( + df = df, + ldReference = .ssh_makeHandle(snp_n = 6L), + opts = list( + alleleFlipKriging = TRUE, + nForPip = NULL, + ldMismatchQcMethod = "slalom" + ), + lbl = NA_character_, + entryAudit = list(), + qcCount = list() + ) + out <- pecotmr:::.qcPhaseLdChecks(state) + expect_identical(reads, 1L) + expect_equal(out$entryAudit$panelUnsupportedDropped, 1L) + expect_false("ghost" %in% out$df$SNP) +}) + test_that("fine-mapping keeps onMissing='error' for an absent variant", { # The post-QC invariant: QC now drops panel-unsupported variants, so every - # variant reaching fine-mapping has a panel entry. .ldFromSketch's default + # variant reaching fine-mapping has a panel entry. .ldFromRef's default # onMissing='error' (used by the fine-mapping LD build) MUST still abort on # a genuinely absent variant, guaranteeing that invariant. expect_error( - pecotmr:::.ldFromSketch( + pecotmr:::.ldFromRef( .ssh_makeHandle(snp_n = 6L), c("rs1", "ghost"), label = "fine-mapping" ), - "not present in the LD sketch panel" + "not present in the LD reference" ) }) @@ -4648,8 +4107,8 @@ test_that("fine-mapping keeps onMissing='error' for an absent variant", { .ssTwin_makeHandle <- function(nSamples = 60L) { new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = c( "chr1:100:A:G", @@ -4687,7 +4146,7 @@ test_that("fine-mapping keeps onMissing='error' for an absent variant", { .ssTwin_opts <- function() { list( matchMinProp = 0, - sumstatsFilterArgs = SumstatsFilterParam( + sumstatsFilterParam = SumstatsFilterParam( removeIndels = FALSE, removeStrandAmbiguous = TRUE ), @@ -4741,7 +4200,7 @@ test_that("the fine-mapping LD build accepts every harmonized variant", { .ssTwin_opts(), NA_character_ )) - R <- pecotmr:::.ldFromSketch( + R <- pecotmr:::.ldFromRef( handle, as.character(harm$df$SNP), label = "fineMappingPipeline" @@ -4877,19 +4336,19 @@ test_that("summaryStatsQc: absZ / bf / logBf screens skip a no-signal entry", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) } for (arg in list( - list(signalScreenArgs = SignalScreenParam(absZ = 5)), - list(signalScreenArgs = SignalScreenParam(bf = 100)), - list(signalScreenArgs = SignalScreenParam(logBf = 5)) + list(signalScreenParam = SignalScreenParam(absZ = 5)), + list(signalScreenParam = SignalScreenParam(bf = 100)), + list(signalScreenParam = SignalScreenParam(logBf = 5)) )) { res <- exec( summaryStatsQc, mk(), !!!arg, - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) ea <- qcInfo(res)$entryAudit[[1L]] expect_true(isTRUE(ea$pipScreenSkipped)) @@ -4906,12 +4365,12 @@ test_that("summaryStatsQc: absZ screen keeps a strong marginal Z", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) res <- summaryStatsQc( ss, - signalScreenArgs = SignalScreenParam(absZ = 5), - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + signalScreenParam = SignalScreenParam(absZ = 5), + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) ea <- qcInfo(res)$entryAudit[[1L]] expect_false(isTRUE(ea$pipScreenSkipped)) @@ -4923,13 +4382,12 @@ test_that("summaryStatsQc: enabling two screens at once errors", { expect_error( summaryStatsQc( ss, - signalScreenArgs = SignalScreenParam(pip = 0.5, absZ = 5) + signalScreenParam = SignalScreenParam(pip = 0.5, absZ = 5) ), "only one screening metric" ) }) - context("dentist_qc") library(MASS) library(corpcor) @@ -5003,7 +4461,7 @@ test_that("dentist output has exactly N rows with correctChenEtAlBug = FALSE", { data$sumstat, R = data$ldMat, nSample = data$nSample, - methodArgs = DentistParam(correctChenEtAlBug = FALSE) + dentistParam = DentistParam(correctChenEtAlBug = FALSE) ) ) expect_equal(nrow(res), 100) @@ -5017,7 +4475,7 @@ test_that("dentist stops when missing position", { data$sumstat, R = data$ldMat, nSample = data$nSample, - methodArgs = DentistParam(correctChenEtAlBug = FALSE) + dentistParam = DentistParam(correctChenEtAlBug = FALSE) ), regexp = "missing either.*pos.*or.*z" ) @@ -5031,7 +4489,7 @@ test_that("dentist stops when missing zscore", { data$sumstat, R = data$ldMat, nSample = data$nSample, - methodArgs = DentistParam(correctChenEtAlBug = FALSE) + dentistParam = DentistParam(correctChenEtAlBug = FALSE) ), regexp = "missing either.*pos.*or.*z" ) @@ -5077,6 +4535,62 @@ test_that("dentist with X matrix input returns exactly N rows", { expect_equal(nrow(res), nSnps) }) +# Genotypes with strong LD clusters, a near-duplicate pair and a monomorphic +# variant, plus z-scores with two planted sign errors. +.dentistFactorData <- function(n = 250, p = 300, seed = 21) { + set.seed(seed) + base <- matrix(rnorm(n * 30), n) + X <- base[, sample(30, p, replace = TRUE)] + + matrix(rnorm(n * p, sd = 0.8), n) + X[, 7] <- X[, 6] + rnorm(n, sd = 0.01) + X[, 40] <- 1 + R <- computeLd(X) + z <- as.vector(R %*% c(rnorm(6) * 3, rep(0, p - 6)) + rnorm(p)) + z[c(90, 200)] <- -3 * z[c(90, 200)] + list(X = X, R = R, z = z, n = n) +} + +test_that("dentistSingleWindow from genotypes matches DENTIST on their LD", { + # Genotypes go to DENTIST's factor kernel, which never forms the LD; the + # duplicate scan reads the factor a block of rows at a time. + d <- .dentistFactorData() + viaX <- suppressWarnings(dentistSingleWindow(d$z, X = d$X)) + viaR <- suppressWarnings(dentistSingleWindow(d$z, R = d$R, nSample = d$n)) + expect_equal(viaX, viaR, tolerance = 1e-8) +}) + +test_that("dentist from genotypes matches DENTIST on their LD per window", { + d <- .dentistFactorData() + sumStat <- data.frame(pos = seq_along(d$z) * 1000, z = d$z) + viaX <- suppressWarnings( + dentist(sumStat, X = d$X, windowMode = "count", minDim = 120) + ) + viaR <- suppressWarnings(dentist( + sumStat, + R = d$R, + nSample = d$n, + windowMode = "count", + minDim = 120 + )) + expect_equal(viaX, viaR, tolerance = 1e-8) +}) + +test_that("the duplicate scan reads a factor as it reads the LD", { + d <- .dentistFactorData() + f <- pecotmr:::.ldFactorFromDosage(d$X) + viaR <- pecotmr:::.findDuplicateVariants(d$z, d$R, 0.995) + viaF <- pecotmr:::.findDuplicateVariantsFactor(d$z, f, 0.995) + expect_gt(sum(viaR$dupBearer != -1), 0L) + for (k in c("filteredZ", "dupBearer", "corABS", "sign", "minValue")) { + expect_equal(viaF[[k]], viaR[[k]], tolerance = 1e-10) + } + kept <- viaF$filteredFactor + expect_equal( + unname(crossprod(kept) / (nrow(kept) - 1)), + unname(viaR$filteredLD) + ) +}) + # =========================================================================== # dentistSingleWindow # =========================================================================== @@ -5196,7 +4710,7 @@ test_that("dentist with gcControl = TRUE returns N rows", { data$sumstat, R = data$ldMat, nSample = data$nSample, - methodArgs = DentistParam(gcControl = TRUE) + dentistParam = DentistParam(gcControl = TRUE) ) ) expect_equal(nrow(res), 100) @@ -5730,7 +5244,6 @@ test_that("resolve_LD_input uses explicit nSample when X provided", { expect_equal(result$nSample, 999) }) - # =========================================================================== # build_segment_result (internal) # =========================================================================== @@ -5789,7 +5302,6 @@ test_that("sliding_window_loop errors on infinite loop", { ) }) - context("univariate_rss_diagnostics") # =========================================================================== @@ -5854,15 +5366,15 @@ test_that("summaryStatsQc: preserves nCase/nControl columns through QC", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle(), + ldReference = .ssQ_makeHandle(), nCase = 500, nControl = 1500 ) expect_true(all(c("nCase", "nControl") %in% colnames(S4Vectors::mcols(ss)))) out <- summaryStatsQc( ss, - signalScreenArgs = SignalScreenParam(pip = 0), - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + signalScreenParam = SignalScreenParam(pip = 0), + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) expect_true(all( c("nCase", "nControl") %in% colnames(S4Vectors::mcols(out)) @@ -5871,7 +5383,6 @@ test_that("summaryStatsQc: preserves nCase/nControl columns through QC", { expect_equal(out$nControl, 1500) }) - # =========================================================================== # mergeVariantInfo (data.frame + GRanges, flip-aware, all = TRUE/FALSE) # =========================================================================== @@ -6438,70 +5949,6 @@ test_that("raissSingleMatrixFromX emits no-known / no-unknown messages", { }) # =========================================================================== -# raiss: genotypeMatrix dispatch verbose / error branches -# =========================================================================== - -test_that("raiss genotypeMatrix: single, list, all-fail and bad-type", { - data <- generateXTestData(n = 60, p = 20, n_known = 10, seed = 3) - - # Single matrix, verbose -> "Processing genotype matrix via SVD..." - expect_message( - res_single <- raiss( - data$ref_panel, - data$known_zscores, - genotypeMatrix = data$X, - r2Threshold = 0, - minimumLd = 0, - verbose = TRUE - ), - "Processing genotype matrix" - ) - expect_equal(nrow(res_single$resultNofilter), nrow(data$ref_panel)) - - # List of (one) matrix, verbose -> "Processing multiple genotype matrix blocks" - expect_message( - res_list <- raiss( - data$ref_panel, - data$known_zscores, - genotypeMatrix = list(data$X), - r2Threshold = 0, - minimumLd = 0, - verbose = TRUE - ), - "Processing multiple genotype matrix blocks" - ) - expect_true(is.list(res_list)) - - # List where every block fails (foreign known variants) -> NULL + message - ghost <- data.frame( - chrom = 1, - pos = 99999, - variant_id = "zzz", - A1 = "A", - A2 = "G", - z = 1, - stringsAsFactors = FALSE - ) - expect_message( - res_fail <- raiss( - data$ref_panel, - ghost, - genotypeMatrix = list( - data$X[, 1:10, drop = FALSE], - data$X[, 11:20, drop = FALSE] - ), - verbose = TRUE - ), - "No blocks could be processed" - ) - expect_null(res_fail) - - # Neither matrix nor list -> hard error - expect_error( - raiss(data$ref_panel, data$known_zscores, genotypeMatrix = 42), - "must be a matrix or a list" - ) -}) # =========================================================================== # .qcRaissMerge: observed-variant AF is preserved through the RAISS merge @@ -6635,73 +6082,6 @@ ssqcOverlapImputedBlocks <- function(seed = 5) { ) } -test_that("raiss multi-LD-block: messages and an imputed boundary merge", { - td <- ssqcOverlapImputedBlocks(seed = 5) - expect_message( - res <- raiss( - td$ref_panel, - td$known_zscores, - ldMatrix = td$LD_matrix_blocks, - lamb = 0.01, - rcond = 0.01, - r2Threshold = 0, - minimumLd = 0, - verbose = TRUE - ), - "Processing multiple LD blocks" - ) - expect_true(is.list(res)) - # Boundary variant v4 appears exactly once after the merge. - expect_equal(sum(res$resultNofilter$variant_id == "chr1:400:A:G"), 1L) -}) - -test_that("raiss multi-LD-block: stops on a block dimension mismatch", { - td <- generateBlockDiagonalTestData( - seed = 2, - block_structure = "non_overlapping", - n_variants = 30 - ) - blocks <- td$LD_matrix_blocks - # Shrink block 1's matrix so it no longer matches its variant count. - blocks$ldMatrices[[1]] <- blocks$ldMatrices[[1]][-1, -1, drop = FALSE] - expect_error( - raiss( - td$ref_panel, - td$known_zscores, - ldMatrix = blocks, - verbose = FALSE - ), - "LD matrix dimension does not match" - ) -}) - -test_that("raiss multi-LD-block: NULL when no block has known variants", { - td <- generateBlockDiagonalTestData( - seed = 3, - block_structure = "non_overlapping", - n_variants = 30 - ) - ghost <- data.frame( - chrom = 1, - pos = 99999, - variant_id = "zzz", - A1 = "A", - A2 = "G", - z = 1, - stringsAsFactors = FALSE - ) - expect_message( - res <- raiss( - td$ref_panel, - ghost, - ldMatrix = td$LD_matrix_blocks, - verbose = TRUE - ), - "No blocks could be processed" - ) - expect_null(res) -}) - # =========================================================================== # raissModel: batch = FALSE with condition-number reporting # =========================================================================== @@ -6719,11 +6099,20 @@ test_that("raissModel batch = FALSE reports the condition number", { ) expect_true(is.numeric(res$conditionNumber)) expect_true(is.finite(res$conditionNumber)) - # checkInversion() returns all.equal()'s value: TRUE when the inverse - # reproduces sigT within tolerance, otherwise a character diff string. - expect_true( - isTRUE(res$correctInversion) || is.character(res$correctInversion) - ) + # The inverse is checked against the ridged matrix it was computed from, + # so a well-conditioned sigT passes. + expect_true(res$correctInversion) +}) + +test_that("raissModel flags an inversion the rcond cutoff truncated", { + # Ridged, this sigT has eigenvalues 2.01 and 0.01; their ratio is under + # rcond = 0.01, so the pseudo-inverse drops one and cannot reproduce it. + sig_t <- matrix(1, nrow = 2, ncol = 2) + sig_i_t <- matrix(c(0.5, 0.2, 0.1, 0.3), nrow = 2) + res <- pecotmr:::raissModel(c(1.2, 0.5), sig_t, sig_i_t) + expect_identical(res$correctInversion, c(FALSE, FALSE)) + ok <- pecotmr:::raissModel(c(1.2, 0.5), diag(2), sig_i_t) + expect_identical(ok$correctInversion, c(TRUE, TRUE)) }) # =========================================================================== @@ -6832,11 +6221,11 @@ test_that("summaryStatsQc: emit() drops the label for an empty study id", { studyName = "", entry = list(.ssQ_makeEntryGr()), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) msgs <- capture_messages(summaryStatsQc( ss, - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) )) joined <- paste(msgs, collapse = "") expect_match(joined, "QC summary:") @@ -6851,12 +6240,12 @@ test_that("summaryStatsQc: the N filter emits its message and rollup", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) msgs <- capture_messages( res <- summaryStatsQc( ss, - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 3) + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 3) ) ) joined <- paste(msgs, collapse = "") @@ -6883,11 +6272,11 @@ test_that("summaryStatsQc: derives BETA/SE from Z+MAF+N, records it", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) res <- summaryStatsQc( ss, - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) ea <- qcInfo(res)$entryAudit[[1L]] expect_equal(ea$betaSeFromZ$nDerived, 4L) @@ -6900,11 +6289,11 @@ test_that("summaryStatsQc: clamps tiny Z-derived P and audits it", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) res <- summaryStatsQc( ss, - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) ea <- qcInfo(res)$entryAudit[[1L]] expect_true(!is.null(ea$sanityChecks$smallPClamped)) @@ -6917,11 +6306,11 @@ test_that("summaryStatsQc: early-exits below two pre-harmonization variants", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) res <- summaryStatsQc( ss, - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) ea <- qcInfo(res)$entryAudit[[1L]] expect_match(ea$earlyExit, "fewer than two variants") @@ -6940,7 +6329,7 @@ test_that("summaryStatsQc: kriging QC records its audit and rollup", { positions = seq(100L, by = 100L, length.out = 8L) )), genome = "hg19", - ldSketch = .ssQ_makeHandleVid(snp_n = 8L) + ldReference = .ssQ_makeHandleVid(snp_n = 8L) ) local_mocked_bindings( extractBlockGenotypes = .ssQ_mockExtractor(), @@ -6950,8 +6339,8 @@ test_that("summaryStatsQc: kriging QC records its audit and rollup", { res <- summaryStatsQc( ss, alleleFlipKriging = TRUE, - signalScreenArgs = SignalScreenParam(pip = 0), - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + signalScreenParam = SignalScreenParam(pip = 0), + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) ) joined <- paste(msgs, collapse = "") @@ -6987,11 +6376,16 @@ test_that("summaryStatsQc: impute assembles BETA/SE/N, median-fills N", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle(snp_n = 8L, n_samples = 60L) + ldReference = .ssQ_makeHandle(snp_n = 8L, n_samples = 60L) ) local_mocked_bindings( extractBlockGenotypes = .ssQ_mockExtractor(), - raiss = function(refPanel, knownZscores, genotypeMatrix, ...) { + .raissGenotypePath = function( + refPanel, + knownZscores, + genotypeMatrix, + p + ) { added <- refPanel[ refPanel$variant_id %in% c("rs5", "rs6"), , @@ -7009,7 +6403,7 @@ test_that("summaryStatsQc: impute assembles BETA/SE/N, median-fills N", { res <- summaryStatsQc( ss, impute = TRUE, - imputeArgs = RaissParam(flank = 500) + raissParam = RaissParam(flank = 500) ) ea <- qcInfo(res)$entryAudit[[1L]] expect_equal(ea$raissTotalVariants, 6L) @@ -7135,7 +6529,7 @@ test_that("summaryStatsQc: the rollup enumerates every removed step", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandle() + ldReference = .ssQ_makeHandle() ) # mafCutoff is measured against the panel too, so the fabricated sketch # needs a dosage source; the mock puts every variant near MAF 0.3, well @@ -7147,7 +6541,7 @@ test_that("summaryStatsQc: the rollup enumerates every removed step", { msgs <- capture_messages( res <- summaryStatsQc( ss, - sumstatsFilterArgs = SumstatsFilterParam( + sumstatsFilterParam = SumstatsFilterParam( infoCutoff = 0.5, nCutoff = 3 ), @@ -7309,35 +6703,6 @@ test_that("segmentByDist keeps a last window that clears the cutoff", { expect_equal(sort(unique(covered)), seq_along(pos)) }) -test_that("raiss multi-LD-block skips a NULL middle block, keeps the rest", { - td <- generateBlockDiagonalTestData( - seed = 11, - block_structure = "non_overlapping", - n_variants = 30 - ) - # Drop every known z-score in block 2 (var11..var20) so raissSingleMatrix - # returns NULL for it. Blocks 1 and 3 still succeed, so resultsList carries a - # NULL hole at index 2 and combineWithBoundaryCheck(accumulated, NULL) returns - # the accumulated result unchanged (sumstatsQc.R:1965). - kz <- dplyr::filter(td$known_zscores, !variant_id %in% paste0("var", 11:20)) - res <- raiss( - td$ref_panel, - kz, - ldMatrix = td$LD_matrix_blocks, - lamb = 0.01, - rcond = 0.01, - r2Threshold = 0, - minimumLd = 0, - verbose = FALSE - ) - expect_true(is.list(res)) - expect_false(is.null(res$resultNofilter)) - # Block 2 was skipped entirely, so none of its variants survive. - expect_false(any(paste0("var", 11:20) %in% res$resultNofilter$variant_id)) - # Blocks 1 and 3 (var1..10, var21..30) are present. - expect_true(all(c("var1", "var21") %in% res$resultNofilter$variant_id)) -}) - test_that("summaryStatsQc kriging QC sign-flips and keeps a bad variant", { skip_if_not( "kriging_rss" %in% getNamespaceExports("susieR"), @@ -7397,7 +6762,7 @@ test_that("summaryStatsQc kriging QC sign-flips and keeps a bad variant", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = .ssQ_makeHandleVid(snp_n = 8L, n_samples = 300L) + ldReference = .ssQ_makeHandleVid(snp_n = 8L, n_samples = 300L) ) local_mocked_bindings( extractBlockGenotypes = corrExtractor, @@ -7407,8 +6772,8 @@ test_that("summaryStatsQc kriging QC sign-flips and keeps a bad variant", { summaryStatsQc( ss, alleleFlipKriging = TRUE, - signalScreenArgs = SignalScreenParam(pip = 0), - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + signalScreenParam = SignalScreenParam(pip = 0), + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) ) ea <- qcInfo(res)$entryAudit[[1L]] @@ -7424,7 +6789,7 @@ test_that("summaryStatsQc kriging QC sign-flips and keeps a bad variant", { # ---- LD-sketch trimming to the summary-stats range / final variants ---------- -test_that(".subsetSketchToRange keeps panel variants in the entry span", { +test_that(".subsetLdRefToRange keeps panel variants in the entry span", { h <- readGenotypeHandle( test_path("test_data/test_variants"), format = "plink2" @@ -7438,7 +6803,7 @@ test_that(".subsetSketchToRange keeps panel variants in the entry span", { IRanges::IRanges(as.integer(slice$BP), width = 1L) ) S4Vectors::mcols(gr)$SNP <- slice$SNP - sub <- snpInfo(pecotmr:::.subsetSketchToRange(h, list(gr))) + sub <- snpInfo(pecotmr:::.subsetLdRefToRange(h, list(gr))) lo <- min(slice$BP) hi <- max(slice$BP) expected <- si$SNP[ @@ -7450,7 +6815,7 @@ test_that(".subsetSketchToRange keeps panel variants in the entry span", { expect_lt(nrow(sub), nrow(si)) }) -test_that(".subsetSketchToIds keeps exactly the entries' variants", { +test_that(".subsetLdRefToIds keeps exactly the entries' variants", { h <- readGenotypeHandle( test_path("test_data/test_variants"), format = "plink2" @@ -7462,19 +6827,18 @@ test_that(".subsetSketchToIds keeps exactly the entries' variants", { IRanges::IRanges(as.integer(si$BP[sel]), width = 1L) ) S4Vectors::mcols(gr)$SNP <- si$SNP[sel] - sub <- snpInfo(pecotmr:::.subsetSketchToIds(h, list(gr))) + sub <- snpInfo(pecotmr:::.subsetLdRefToIds(h, list(gr))) expect_setequal( normalizeVariantId(sub$SNP), normalizeVariantId(si$SNP[sel]) ) }) -test_that(".subsetSketchToRange / .subsetSketchToIds are NULL-safe", { - expect_null(pecotmr:::.subsetSketchToRange(NULL, list())) - expect_null(pecotmr:::.subsetSketchToIds(NULL, list())) +test_that(".subsetLdRefToRange / .subsetLdRefToIds are NULL-safe", { + expect_null(pecotmr:::.subsetLdRefToRange(NULL, list())) + expect_null(pecotmr:::.subsetLdRefToIds(NULL, list())) }) - # --------------------------------------------------------------------------- # summaryStatsQc panel filters: mafCutoff / macCutoff / imissCutoff measured # against the LD reference panel, applied before any entry is harmonized. @@ -7519,7 +6883,7 @@ test_that(".subsetSketchToRange / .subsetSketchToIds are NULL-safe", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = handle + ldReference = handle ) } @@ -7552,9 +6916,9 @@ test_that(".ssqcPrunePanel is a no-op with no cutoffs / a NULL sketch", { test_that(".ssqcPrunePanel prunes the RSE sketch's seed handle, not the view", { skip_if_not_installed("pgenlibr") - # A summaryStatsQc ldSketch is an RSE wrapping the GenotypeHandle; + # A summaryStatsQc ldReference is an RSE wrapping the GenotypeHandle; # harmonization, kriging, mismatch-QC and RAISS all read the panel through - # .ldSketchHandle() (the dosage DelayedArray's seed). Subsetting the RSE + # .ldRefHandle() (the dosage DelayedArray's seed). Subsetting the RSE # rows leaves that seed carrying the full panel, so the prune must reach # the seed -- the real-flow shape the bare-handle tests do not exercise. h <- .ssqcPanelHandle() @@ -7568,7 +6932,7 @@ test_that(".ssqcPrunePanel prunes the RSE sketch's seed handle, not the view", { list(mafCutoff = cutoff, macCutoff = 0, imissCutoff = 1), "test" )) - seed <- pecotmr:::.ldSketchHandle(pruned) + seed <- pecotmr:::.ldRefHandle(pruned) expect_setequal( as.character(snpInfo(seed)$SNP), ids[!is.na(maf) & maf >= cutoff] @@ -7586,14 +6950,14 @@ test_that("summaryStatsQc: mafCutoff drops panel-rare observed variants", { ss <- .ssqcPanelSumStats(h) out <- suppressMessages(summaryStatsQc( ss, - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0), + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0), panelFilterParam = PanelFilterParam(mafCutoff = cutoff) )) entry <- pecotmr:::.collectionEntry(out, 1) expect_equal(length(entry), sum(!is.na(maf) & maf >= cutoff)) # ... and the panel carried on the result -- the seed handle every LD # read keys off, not just the row view -- holds no sub-cutoff variant. - seed <- pecotmr:::.ldSketchHandle(ldSketch(out)) + seed <- pecotmr:::.ldRefHandle(ldReference(out)) keptMaf <- maf[match( as.character(snpInfo(seed)$SNP), as.character(snpInfo(h)$SNP) @@ -7611,7 +6975,7 @@ test_that("summaryStatsQc: macCutoff is the stricter of MAF / MAC", { mac <- ceiling(cutoff * 2 * nSamples(h)) out <- suppressMessages(summaryStatsQc( ss, - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0), + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0), panelFilterParam = PanelFilterParam(macCutoff = mac) )) entry <- pecotmr:::.collectionEntry(out, 1) @@ -7625,7 +6989,7 @@ test_that("summaryStatsQc: the panel filter is off by default", { ss <- .ssqcPanelSumStats(h) out <- suppressMessages(summaryStatsQc( ss, - sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) )) expect_equal( length(pecotmr:::.collectionEntry(out, 1)), @@ -7665,7 +7029,6 @@ test_that("summaryStatsQc validates the panel cutoffs before any panel read", { ) }) - # --------------------------------------------------------------------------- # RAISS imputation: MAF / MAC / missingness cutoffs # @@ -7710,13 +7073,18 @@ test_that("summaryStatsQc validates the panel cutoffs before any panel read", { list(dosage = dosage, refPanel = refPanel, knownZ = knownZ, obs = obs) } +# The mask as .qcRaissBuildInputs() computes it for a panel of real +# genotypes: statistics off the window's dosages, only when a cutoff is set, +# and a MAC cutoff counting the panel's samples. # @noRd .rmask_run <- function(f, ...) { + rp <- as.list(RaissParam(...)) .qcRaissTargetMask( f$refPanel, f$knownZ, - f$dosage, - list(imputeArgs = as.list(RaissParam(...))) + .qcRaissTargetStats(NULL, NULL, f$dosage, rp), + list(raissParam = rp), + nSamples = nrow(f$dosage) ) } @@ -7798,7 +7166,7 @@ test_that(".qcRaissTargetMask drops a target whose MAF is undefined", { expect_false(keep[[12]]) }) -test_that("summaryStatsQc imputeArgs cutoffs bound what RAISS imputes", { +test_that("summaryStatsQc raissParam cutoffs bound what RAISS imputes", { data(gwasSumStatsS4Example) gss <- gwasSumStatsS4Example variants <- unlist(gss) @@ -7806,7 +7174,7 @@ test_that("summaryStatsQc imputeArgs cutoffs bound what RAISS imputes", { studyName = studyName(gss), entry = list(variants[seq(1L, length(variants), by = 4L)]), genome = unique(unname(GenomeInfoDb::genome(gss))), - ldSketch = ldSketch(gss) + ldReference = ldReference(gss) ) nObserved <- sum(lengths(thin)) # The bundled toy panel imputes poorly, so the R2 gate would otherwise @@ -7816,7 +7184,7 @@ test_that("summaryStatsQc imputeArgs cutoffs bound what RAISS imputes", { out <- suppressWarnings(suppressMessages(summaryStatsQc( thin, impute = TRUE, - imputeArgs = do.call( + raissParam = do.call( RaissParam, utils::modifyList(base, list(...)) ) @@ -8091,47 +7459,45 @@ test_that("both trimmers empty the sketch for zero-variant entries", { expect_gt(nrow(h), 0L) # An empty list and a zero-range GRanges both mean "no variants". for (entries in list(list(), list(GenomicRanges::GRanges()))) { - expect_equal(nrow(.subsetSketchToRange(h, entries)), 0L) - expect_equal(nrow(.subsetSketchToIds(h, entries)), 0L) + expect_equal(nrow(.subsetLdRefToRange(h, entries)), 0L) + expect_equal(nrow(.subsetLdRefToIds(h, entries)), 0L) } }) test_that("emptying drops both axes but keeps the panel's identity", { h <- .sk_panel() - e <- .subsetSketchToRange(h, list()) + e <- .subsetLdRefToRange(h, list()) # 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(genotypeFormat(eh), genotypeFormat(hh)) - expect_equal(path(eh), path(hh)) + expect_equal(.ldRefFormat(e), .ldRefFormat(h)) + expect_equal(.ldRefSource(e)$path, .ldRefSource(h)$path) }) -test_that(".emptySketch drops the seed's variants, not just the rows", { +test_that(".emptyLdRef drops the seed, not just the rows", { # A panel carries its handle twice: as rowRanges and inside the dosage # assay's DelayedArray seed. Dropping rows alone leaves the seed holding # the whole panel, which is the weight this exists to shed. h <- .sk_panel() - e <- .emptySketch(h) + e <- .emptyLdRef(h) expect_equal(nrow(e), 0L) - expect_equal(nrow(snpInfo(.ldSketchHandle(e))), 0L) + expect_null(.panelSeed(e)) expect_lt( length(serialize(e, NULL)), length(serialize(h, NULL)) / 2 ) }) -test_that(".emptySketch is NULL-safe and idempotent", { - expect_null(.emptySketch(NULL)) - e <- .emptySketch(.sk_panel()) - expect_equal(nrow(.emptySketch(e)), 0L) +test_that(".emptyLdRef is NULL-safe and idempotent", { + expect_null(.emptyLdRef(NULL)) + e <- .emptyLdRef(.sk_panel()) + expect_equal(nrow(.emptyLdRef(e)), 0L) }) -test_that(".subsetSketchToIds keeps the panel when ids are unextractable", { +test_that(".subsetLdRefToIds keeps the panel when ids are unextractable", { # Ranges present but no SNP mcol is a different situation from zero # variants: the panel cannot be keyed, so blanking it would discard LD the # object may well reference. Stay conservative. @@ -8140,7 +7506,7 @@ test_that(".subsetSketchToIds keeps the panel when ids are unextractable", { "chr21", IRanges::IRanges(c(17513228L, 17513580L), width = 1L) ) - expect_equal(nrow(.subsetSketchToIds(h, list(gr))), nrow(h)) + expect_equal(nrow(.subsetLdRefToIds(h, list(gr))), nrow(h)) }) # =========================================================================== @@ -8188,13 +7554,13 @@ test_that("an af: key is directional AF; a maf: key is directionless", { "af" )) expect_equal(a$AF, 0.8) - expect_null(a$MAF) + expect_false("MAF" %in% names(a)) b <- suppressWarnings(.resolveSumstatCols( .afm_df("effect_allele_frequency", 0.8), .afm_cm(maf = "effect_allele_frequency"), "maf" )) - expect_null(b$AF) + expect_false("AF" %in% names(b)) expect_equal(b$MAF, 0.8) }) @@ -8207,7 +7573,7 @@ test_that("an undeclared af warns distinctly and yields no AF column", { ), "no effect-allele frequency declared" ) - expect_null(out$AF) + expect_false("AF" %in% names(out)) }) test_that("a declared-but-unusable af warns with a different message", { @@ -8383,6 +7749,7 @@ test_that("RaissParam carries every field the QC imputation path reads", { names(a), c( "lamb", + "rcond", "svdTol", "r2Threshold", "minimumLd", @@ -8394,17 +7761,16 @@ test_that("RaissParam carries every field the QC imputation path reads", { ) }) -test_that("RaissParam refuses rcond, which the QC path cannot use", { - # summaryStatsQc always hands RAISS a genotype matrix, which solves via - # .raissSvdImpute (svdTol). rcond belongs to the LD-matrix path, so it was - # advertised in the old imputeOpts default and read by nobody. - expect_error(RaissParam(rcond = 0.01), "unused argument") - expect_true("rcond" %in% names(formals(raiss))) - expect_false("rcond" %in% names(RaissParam())) +test_that("RaissParam carries rcond for an LdMatrix reference", { + # A genotype panel reaches RAISS's SVD route (svdTol); an LdMatrix + # reaches its LD-matrix route, which takes rcond. Both are forwarded, and + # each route reads its own. + expect_equal(RaissParam(rcond = 0.05)$rcond, 0.05) + expect_equal(RaissParam()$rcond, formals(raiss)$rcond) }) test_that("RaissParam fields split into raiss formals and pecotmr's own", { - forwarded <- c("lamb", "svdTol", "r2Threshold", "minimumLd") + forwarded <- c("lamb", "rcond", "svdTol", "r2Threshold", "minimumLd") expect_true(all(forwarded %in% names(formals(raiss)))) # The rest scope what RAISS is asked to impute; they are not raiss formals # and are consumed before the call. @@ -8412,15 +7778,15 @@ test_that("RaissParam fields split into raiss formals and pecotmr's own", { expect_false(any(ours %in% names(formals(raiss)))) }) -test_that("summaryStatsQc refuses a bare list for imputeArgs", { +test_that("summaryStatsQc refuses a bare list for raissParam", { data(gwasSumStatsS4Example) expect_error( - summaryStatsQc(gwasSumStatsS4Example, imputeArgs = list(flank = 500)), + summaryStatsQc(gwasSumStatsS4Example, raissParam = list(flank = 500)), "must be built with RaissParam" ) }) -test_that("an empty imputeArgs resolves to the full default bundle", { +test_that("an empty raissParam resolves to the full default bundle", { resolved <- pecotmr:::.ssqcResolveImputeArgs(list()) expect_equal(resolved, as.list(RaissParam())) # Every read site indexes this without a fallback, so a missing field @@ -8480,3 +7846,77 @@ test_that(".sumstatsCleaningResolve fills defaults an empty bundle omits", { "must be built with SumstatsCleaningParam" ) }) + + +test_that("summaryStatsQc gives one result from an LdMatrix and its panel", { + data(gwasSumStatsS4Example) + gss <- gwasSumStatsS4Example + panel <- ldReference(gss) + ld <- LdMatrix( + unname(computeLd(panel)), + variants = SummarizedExperiment::rowRanges(panel), + nSamples = ncol(panel) + ) + withLd <- GwasSumStats( + studyName = studyName(gss), + entry = list(.collectionEntry(gss, 1L)), + genome = "hg19", + ldReference = ld, + qcInfo = qcInfo(gss) + ) + viaPanel <- suppressMessages( + summaryStatsQc(gss, ldMismatchQcMethod = "slalom") + ) + viaMatrix <- suppressMessages( + summaryStatsQc(withLd, ldMismatchQcMethod = "slalom") + ) + expect_equal( + as.data.frame(unlist(viaMatrix)), + as.data.frame(unlist(viaPanel)) + ) + # The reference is trimmed to the surviving variants, still a matrix. + expect_s4_class(ldReference(viaMatrix), "LdMatrix") + expect_equal(length(ldReference(viaMatrix)), length(unlist(viaMatrix))) +}) + +test_that("DENTIST needs an LdMatrix's size; SLALOM does not", { + ld <- LdMatrix( + diag(2), + variants = data.frame(chrom = "1", pos = 1:2, A1 = "A", A2 = "G") + ) + expect_error( + .qcMismatchNSample(ld, "dentist"), + "DENTIST needs the LD reference's sample size" + ) + expect_null(.qcMismatchNSample(ld, "slalom")) +}) + +test_that("RAISS imputation in QC runs on an LdMatrix reference", { + data(gwasSumStatsS4Example) + gss <- gwasSumStatsS4Example + panel <- ldReference(gss) + ld <- LdMatrix( + unname(computeLd(panel)), + variants = SummarizedExperiment::rowRanges(panel), + nSamples = ncol(panel) + ) + entry <- .collectionEntry(gss, 1L) + thin <- GwasSumStats( + studyName = studyName(gss), + entry = list(entry[seq(1L, length(entry), by = 2L)]), + genome = "hg19", + ldReference = ld + ) + res <- suppressMessages(summaryStatsQc(thin, impute = TRUE)) + ea <- qcInfo(res)$entryAudit[[1L]] + expect_gt(ea$raissImputedVariants, 0L) + # Target filters read the LdMatrix's AF, which this one does not record. + expect_error( + suppressMessages(summaryStatsQc( + thin, + impute = TRUE, + raissParam = RaissParam(mafCutoff = 0.05) + )), + "needs allele frequencies" + ) +}) diff --git a/tests/testthat/test_tupleSelectors.R b/tests/testthat/test_tupleSelectors.R index 23f4ec354..203590bb1 100644 --- a/tests/testthat/test_tupleSelectors.R +++ b/tests/testthat/test_tupleSelectors.R @@ -545,8 +545,8 @@ test_that("chromosome paths union when they agree and abort when they clash", { mk <- function(paths) { new( "GenotypeHandle", - path = "/tmp/x.gds", - format = "gds", + path = "/tmp/x", + format = "plink2", snpInfo = data.frame( SNP = "a", CHR = "1", @@ -576,6 +576,39 @@ test_that("chromosome paths union when they agree and abort when they clash", { }) +test_that("panels read through no handle union their rows", { + # A PLINK1, VCF or GDS panel has no handle whose snpInfo could be + # widened, so the parts' assays are bound: each variant once, in genomic + # order. A panel from another file is refused, not bound. + skip_if_not_installed("PlinkMatrix") + skip_if_not_installed("pgenlibr") + stem <- test_path("test_data", "test_variants") + panel <- readGenotypes(plink1Prefix = stem) + a <- pecotmr:::.panelSubsetRows(panel, 4:8) + b <- pecotmr:::.panelSubsetRows(panel, 1:5) + pecotmr:::.ssCheckSameSource(list(a, b), "combineX") + out <- pecotmr:::.ssUnionPanels(list(a, b), character(0)) + expect_identical(rownames(out), rownames(panel)[1:8]) + expect_equal( + as.matrix(SummarizedExperiment::assay(out, "dosage")), + as.matrix(SummarizedExperiment::assay(panel, "dosage"))[1:8, ] + ) + expect_identical( + pecotmr:::.ldRefSource(out)$path, + pecotmr:::.ldRefSource(panel)$path + ) + # The same panel twice is that panel. + expect_identical(pecotmr:::.ssUnionPanels(list(a, a), character(0)), a) + expect_error( + pecotmr:::.ssCheckSameSource( + list(a, readGenotypes(plink2Prefix = stem)), + "combineX" + ), + "reference different genotype panels" + ) +}) + + # =========================================================================== # Row-payload coercion and unmerged collection slots # =========================================================================== @@ -615,7 +648,7 @@ test_that("a collection-level slot with no merge rule is refused", { contains = "RangedTupleList", representation( genome = "character", - ldSketch = "ANY", + ldReference = "ANY", surprise = "character" ) ) @@ -625,7 +658,7 @@ test_that("a collection-level slot with no merge rule is refused", { a = GenomicRanges::GRanges("chr1", IRanges::IRanges(1L, width = 1L)) ), genome = "hg38", - ldSketch = NULL, + ldReference = NULL, surprise = "boo" ) expect_error( @@ -750,3 +783,27 @@ test_that(".asAnalysisWindow normalizes strings, GRanges and multi-range input", expect_identical(GenomicRanges::start(span)[[1L]], 100L) expect_identical(GenomicRanges::end(span)[[1L]], 900L) }) + + +test_that("collections sharing one LdMatrix combine; differing ones need it", { + ids <- c("chr22:100:A:G", "chr22:200:C:T", "chr22:300:G:A") + vars <- data.frame( + chrom = "chr22", + pos = c(100L, 200L, 300L), + SNP = ids, + A1 = c("G", "T", "A"), + A2 = c("A", "C", "G") + ) + R <- matrix(c(1, 0.5, 0.2, 0.5, 1, 0.3, 0.2, 0.3, 1), 3L, 3L) + ld <- LdMatrix(R, variants = vars, nSamples = 100) + # The widest reference covering the others is the combined one. + expect_identical( + pecotmr:::.combineLdMatrixRefs(list(ld, ld[1:2]), "combine"), + ld + ) + # Two subsets neither of which covers the other cannot be unioned. + expect_error( + pecotmr:::.combineLdMatrixRefs(list(ld[1:2], ld[2:3]), "combine"), + "cover different variants" + ) +}) diff --git a/tests/testthat/test_twasWeights.R b/tests/testthat/test_twasWeights.R index 19c952c09..dc0ef350f 100644 --- a/tests/testthat/test_twasWeights.R +++ b/tests/testthat/test_twasWeights.R @@ -179,7 +179,8 @@ test_that(".twas_method_lookup: default args are set for mrash, not susie", { # susie carries NO fitting defaults: susieWeights extracts from a supplied # fit and never runs susie, so `refine` / `L` would have nothing to configure. expect_length(result$susie_weights, 0L) - expect_equal(result$mrash_weights$initPriorSd, TRUE) + # mrash keeps mr.ash's own prior grid, so only the iteration cap is set. + expect_named(result$mrash_weights, "max.iter") expect_equal(result$mrash_weights$max.iter, 100) }) @@ -656,7 +657,9 @@ test_that("learnTwasWeights resolves fits under camelCase method names", { d$X, as.numeric(d$Y), weightMethods = list(susie_weights = list()), - fittedModels = list(susie = makeFakeSusieFit(p = 10, maxNumSingleEffects = 5)) + fittedModels = list( + susie = makeFakeSusieFit(p = 10, maxNumSingleEffects = 5) + ) ) expect_true("susie" %in% class(seen)) }) @@ -677,7 +680,11 @@ test_that("learnTwasWeights runs susie + susieInf from supplied fits", { ), fittedModels = list( susie = makeFakeSusieFit(p = 10, maxNumSingleEffects = 5), - susieInf = makeFakeSusieFit(p = 10, maxNumSingleEffects = 7, inf = TRUE) + susieInf = makeFakeSusieFit( + p = 10, + maxNumSingleEffects = 7, + inf = TRUE + ) ) ) expect_equal(methodNames(result), c("susie", "susie_inf")) @@ -1064,7 +1071,7 @@ test_that("show.TwasWeights prints entry/study/context/trait/method counts", { }) -test_that("show.TwasWeights reports ldSketch when present", { +test_that("show.TwasWeights reports ldReference when present", { e <- .sh_makeTwEntry() tw <- TwasWeights( studyName = "s1", @@ -1072,10 +1079,10 @@ test_that("show.TwasWeights reports ldSketch when present", { trait = "t1", method = "lasso", entry = list(e), - ldSketch = .sh_makeGenotypeHandle() + ldReference = .sh_makeGenotypeHandle() ) out <- capture.output(show(tw)) - expect_true(any(grepl("LD sketch: gds @ /tmp/test.gds", out))) + expect_true(any(grepl("LD reference: plink2 @ /tmp/test", out))) }) # =========================================================================== @@ -1317,7 +1324,7 @@ test_that("TwasWeights: studyName returns unique study labels", { expect_setequal(studyName(tw), c("s1", "s2")) }) -test_that("TwasWeights: weights/cvResult/methodFits/ldSketch delegate per tuple", { +test_that("TwasWeights: per-tuple weights/cvResult/methodFits/ldReference", { w1 <- rnorm(4) e1 <- twasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), @@ -1335,7 +1342,7 @@ test_that("TwasWeights: weights/cvResult/methodFits/ldSketch delegate per tuple" trait = c("t1", "t1"), method = c("lasso", "enet"), entry = list(e1, e2), - ldSketch = .sh_makeGenotypeHandle() + ldReference = .sh_makeGenotypeHandle() ) expect_equal( @@ -1368,7 +1375,7 @@ test_that("TwasWeights: weights/cvResult/methodFits/ldSketch delegate per tuple" )$tag, "fitA" ) - expect_s4_class(ldSketch(tw), "RangedSummarizedExperiment") + expect_s4_class(ldReference(tw), "RangedSummarizedExperiment") }) # =========================================================================== @@ -2095,9 +2102,13 @@ test_that("the twas lookup helpers answer NULL when the token is absent", { ".rssShrinkGridWeights", "buildMrmashPriorMatrices", "penalizedRss", + ".penalizedRssPath", "lassosumRss", + ".lassosumRssPath", "sdpr", - "prsCs" + ".sdprRun", + "prsCs", + ".prsCsRun" ) hit <- new.env(parent = emptyenv()) for (f in watched) { @@ -2133,9 +2144,15 @@ test_that("the twas lookup helpers answer NULL when the token is absent", { set.seed(1) LD <- diag(p) LD[abs(row(LD) - col(LD)) == 1] <- 0.3 + ids <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) list( - LD = LD, - stat = list(bhat = rnorm(p) * 0.1, shat = rep(0.05, p), n = 500L) + ldReference = LdMatrix(`dimnames<-`(LD, list(ids, ids))), + stat = list( + b = rnorm(p) * 0.1, + seb = rep(0.05, p), + n = rep(500L, p), + variantNames = ids + ) ) } @@ -2168,12 +2185,30 @@ test_that("the recorded individual-path chains match what a fit enters", { test_that("the recorded RSS chains match what a fit enters", { fx <- .tw_rssFixture() - seen <- .tw_traceChain(scadRssWeights(fx$stat, fx$LD)) - recorded <- pecotmr:::.twasMethodChainFor("scad", "QtlSumStats") - # Every pecotmr hop the run entered must be in the recorded chain. - expect_true(all(is_in(seen, recorded))) - expect_true(is_in("penalizedRss", seen)) + recordedFor <- function(tk) { + pecotmr:::.twasMethodChainFor(tk, "QtlSumStats") + } + # Every pecotmr hop a run entered must be in the recorded chain, and the + # chain's last pecotmr hop must be one the run entered. + seen <- .tw_traceChain(scadRssWeights(fx$stat, fx$ldReference)) + expect_true(all(is_in(seen, recordedFor("scad")))) + expect_true(is_in(".penalizedRssPath", seen)) expect_true(is_in(".rssShrinkGridWeights", seen)) + seen <- .tw_traceChain(lassosumRssWeights(fx$stat, fx$ldReference)) + expect_true(all(is_in(seen, recordedFor("lasso")))) + expect_true(is_in(".lassosumRssPath", seen)) + prsCsOpts <- PrsCsOptions(nIter = 20, nBurnin = 5, thin = 1) + seen <- .tw_traceChain( + prsCsWeights(fx$stat, fx$ldReference, methodArgs = prsCsOpts) + ) + expect_equal(seen, ".prsCsRun") + expect_true(is_in(".prsCsRun", recordedFor("prsCs"))) + sdprOpts <- SdprOptions(iter = 20, burn = 5, thin = 1, verbose = FALSE) + seen <- .tw_traceChain( + sdprWeights(fx$stat, fx$ldReference, methodArgs = sdprOpts) + ) + expect_equal(seen, ".sdprRun") + expect_true(is_in(".sdprRun", recordedFor("dprGibbs"))) }) test_that("every RSS chain yields a checkable argument set", { @@ -2225,10 +2260,19 @@ test_that("the TWAS Options registry is derived from each implementation", { # restate a pairing the implementation already declares through its own # `methodArgs` default. The two paths of one method often reach different # packages, so a second table is a second thing to keep in step. - reg <- pecotmr:::.twasMethodCtors() - expect_setequal(names(reg), names(pecotmr:::.twasMethodCapabilities)) - expect_setequal(names(reg), pecotmr:::.twasConfigurableMethods()) - expect_true(all(map_lgl(reg, is.function))) + expect_setequal( + pecotmr:::.twasConfigurableMethods(), + names(pecotmr:::.twasMethodCapabilities) + ) + # Every configurable method has a constructor on each path it runs on. + for (path in c("QtlDataset", "QtlSumStats")) { + toks <- intersect( + pecotmr:::.twasConfigurableMethods(), + pecotmr:::.twasMethodsFor(path) + ) + ctors <- map(toks, pecotmr:::.twasMethodCtorFor, inputKind = path) + expect_true(all(map_lgl(ctors, is.function)), info = path) + } nameOf <- function(f) { if (is.null(f)) { @@ -2241,12 +2285,15 @@ test_that("the TWAS Options registry is derived from each implementation", { if (length(hit) > 0L) hit[[1L]] else "?" } # Spot-check the pairs the derivation must reproduce. - expect_equal(nameOf(reg$lasso), "GlmnetOptions") - expect_equal(nameOf(reg$mcp), "NcvregOptions") - expect_equal(nameOf(reg$bayesB), "BglrOptions") - # prsCs has no individual implementation, so the path-blind view falls - # back to its summary-statistics constructor rather than dropping it. - expect_equal(nameOf(reg$prsCs), "PrsCsOptions") + ctorName <- function(tk, path) { + nameOf(pecotmr:::.twasMethodCtorFor(tk, path)) + } + expect_equal(ctorName("lasso", "QtlDataset"), "GlmnetOptions") + expect_equal(ctorName("mcp", "QtlDataset"), "NcvregOptions") + expect_equal(ctorName("bayesB", "QtlDataset"), "BglrOptions") + # prsCs has no individual implementation; its one constructor is the + # summary-statistics one. + expect_equal(ctorName("prsCs", "QtlSumStats"), "PrsCsOptions") }) test_that("each method's Options constructor is resolved per input path", { diff --git a/tests/testthat/test_twasWeightsPipeline.R b/tests/testthat/test_twasWeightsPipeline.R index 2f3a1dff3..87955b570 100644 --- a/tests/testthat/test_twasWeightsPipeline.R +++ b/tests/testthat/test_twasWeightsPipeline.R @@ -22,8 +22,8 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") .tp_makeHandle <- function(snp_n = 20L, n_samples = 40L) { new( "GenotypeHandle", - path = "/tmp/tp.gds", - format = "gds", + path = "/tmp/tp", + format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), @@ -128,7 +128,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") } } -# Build a minimal FineMappingResult that satisfies .twasCheckFineMappingMethods. +# A minimal QtlFineMappingResult that satisfies .twasCheckFineMappingMethods. # Each entry stores a stub fit list under the susieFit slot; the per-tuple # loop pulls these via .twasFineMappingFits() and threads them into the # corresponding *Weights wrapper as susieFit / susieInfFit / mvsusieFit / etc. @@ -225,8 +225,8 @@ test_that("twasWeightsPipeline(QtlDataset): runs end-to-end with mocked solvers" cisWindow = 1000L, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ) ) expect_s4_class(res, "TwasWeights") @@ -276,8 +276,8 @@ test_that("twasWeightsPipeline(QtlDataset): mafCutoff/xvarCutoff overrides tight estimatePi = FALSE, verbose = 0, ..., - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() )) } vcount <- function(res) { @@ -322,14 +322,85 @@ test_that("twasWeightsPipeline(QtlDataset): contexts filter restricts the per-co cisWindow = 1000L, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ) ) expect_setequal(contexts(res), "brain") expect_equal(nrow(res), 1L) }) +# A study measured in brain and liver, on the synthetic genotypes. +.tp_twoContextStudy <- function(studyName) { + QtlDataset( + studyName = studyName, + genotypes = .tp_makeHandle(snp_n = 20L, n_samples = 40L), + phenotypes = list( + brain = .tp_makeSe(traits = c("ENSG_A", "ENSG_B"), n_samples = 40L), + liver = .tp_makeSe(traits = c("ENSG_A", "ENSG_B"), n_samples = 40L) + ), + genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) + ) +} + +test_that("twasWeightsPipeline(QtlDataset): traitId chosen per context", { + mocks <- c( + list(extractBlockGenotypes = .tp_mockExtractor()), + .tp_mockIndividualWeights() + ) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + res <- suppressMessages(twasWeightsPipeline( + .tp_twoContextStudy("A"), + methods = list(lasso = list()), + traitId = list(A = list(brain = "ENSG_B")), + cisWindow = 1000L, + estimatePi = FALSE, + verbose = 0, + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() + )) + # The grid spans every (context, trait) pair; the selection keeps + # ENSG_B alone in brain and both traits in liver, which it does not name. + expect_setequal( + paste(res$context, res$trait), + c("brain ENSG_B", "liver ENSG_A", "liver ENSG_B") + ) +}) + +test_that("twasWeightsPipeline(MultiStudy): list selections stay per study", { + mocks <- c( + list(extractBlockGenotypes = .tp_mockExtractor()), + .tp_mockIndividualWeights() + ) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mt <- MultiStudyQtlDataset( + qtlDatasets = list( + A = .tp_twoContextStudy("A"), + B = .tp_twoContextStudy("B") + ) + ) + res <- suppressMessages(twasWeightsPipeline( + mt, + methods = "lasso", + traitId = list(A = "ENSG_B"), + contexts = list(B = "brain"), + cisWindow = 1000L, + estimatePi = FALSE, + verbose = 0, + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() + )) + expect_setequal( + paste(res$study, res$context, res$trait), + c( + "A brain ENSG_B", + "A liver ENSG_B", + "B brain ENSG_A", + "B brain ENSG_B" + ) + ) +}) + test_that("twasWeightsPipeline(QtlDataset): unknown context errors", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") expect_error( @@ -338,7 +409,7 @@ test_that("twasWeightsPipeline(QtlDataset): unknown context errors", { contexts = "ghost", methods = list(lasso = list()) ), - "unknown context" + "no study has: ghost" ) }) @@ -398,7 +469,7 @@ test_that("twasWeightsPipeline(QtlDataset): RSS-only method rejected", { trait = traits, entry = entries, genome = "hg19", - ldSketch = .tp_makeHandle(snp_n = 20L), + ldReference = .tp_makeHandle(snp_n = 20L), qcInfo = if (qc) list(step1 = "ok") else list() ) } @@ -406,11 +477,21 @@ test_that("twasWeightsPipeline(QtlDataset): RSS-only method rejected", { # Mock sumstat weight methods to return zero vectors of the LD dim. .tp_mockSumstatWeights <- function() { list( - susieRssWeights = function(stat, LD, ...) rep(0, nrow(LD)), - lassosumRssWeights = function(stat, LD, ...) rep(0, nrow(LD)), - mrashRssWeights = function(stat, LD, ...) rep(0, nrow(LD)), - susieInfRssWeights = function(stat, LD, ...) rep(0, nrow(LD)), - sdprWeights = function(stat, LD, ...) rep(0, nrow(LD)) + susieRssWeights = function(stat, ldReference, ...) { + rep(0, length(stat$variantNames)) + }, + lassosumRssWeights = function(stat, ldReference, ...) { + rep(0, length(stat$variantNames)) + }, + mrashRssWeights = function(stat, ldReference, ...) { + rep(0, length(stat$variantNames)) + }, + susieInfRssWeights = function(stat, ldReference, ...) { + rep(0, length(stat$variantNames)) + }, + sdprWeights = function(stat, ldReference, ...) { + rep(0, length(stat$variantNames)) + } ) } @@ -424,7 +505,7 @@ test_that("twasWeightsPipeline(QtlSumStats): runs end-to-end with mocked solvers # Method tokens are the bare short names; the QtlSumStats dispatch # resolves them to the *Rss impl via the .twasMethodCapabilities table. # Fine-mapping methods (susie / susieInf / etc.) require a - # FineMappingResult and are covered by separate tests. + # fine-mapping result and are covered by separate tests. res <- suppressMessages(suppressWarnings( twasWeightsPipeline(ss, methods = c("mrash", "lasso"), verbose = 0) )) @@ -452,9 +533,14 @@ test_that("twasWeightsPipeline(QtlSumStats): individual-only method rejected", { test_that("twasWeightsPipeline(QtlSumStats): empty contexts/trait filter errors", { ss <- .tp_makeQtlSumStats() expect_error( - twasWeightsPipeline(ss, methods = "lasso", contexts = "ghost"), + twasWeightsPipeline(ss, methods = "lasso", traitId = "ghost"), "no entries matched" ) + # A context no study has is caught earlier, when the selection is parsed. + expect_error( + twasWeightsPipeline(ss, methods = "lasso", contexts = "ghost"), + "no study has: ghost" + ) }) test_that("twasWeightsPipeline(QtlSumStats): per-method failure surfaces as warning + skip", { @@ -464,7 +550,7 @@ test_that("twasWeightsPipeline(QtlSumStats): per-method failure surfaces as warn .tp_mockSumstatWeights() ) # Override lassosumRssWeights with the failure-producing version. - mocks$lassosumRssWeights <- function(stat, LD, ...) { + mocks$lassosumRssWeights <- function(stat, ldReference, ...) { stop("synthetic test failure") } exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) @@ -483,7 +569,7 @@ test_that("twasWeightsPipeline( trait )", { ss <- .tp_makeQtlSumStats(n_entries = 1L) # 1 context per (study, trait) - # Provide a stub FineMappingResult so the gate passes; the multivariate + # Provide a stub fine-mapping result so the gate passes; the multivariate # guard is what we want to exercise here. fmr <- .tp_makeStubFineMappingResult( studyName = "s1", @@ -499,7 +585,7 @@ test_that("twasWeightsPipeline( # =========================================================================== # Fine-mapping method gate: every fine-mapping method (susie / susieInf / -# susieAsh / mvsusie / fsusie) must be paired with a FineMappingResult. +# susieAsh / mvsusie / fsusie) must be paired with a fine-mapping result. # twasWeightsPipeline is not allowed to re-fit them from scratch. Input- # class compatibility is delegated to .fmCheckMethodCapabilities so the # rule set stays in sync with fineMappingPipeline. @@ -554,12 +640,12 @@ test_that("gate: fsusie now has a TWAS-weight extractor (accepted with FMR)", { method = "fsusie" ) # fsusie is registered in .twasFineMappingMethodAdapters (fsusieWeights), so - # the gate accepts it when a FineMappingResult is supplied ... + # the gate accepts it when a fine-mapping result is supplied ... expect_silent( pecotmr:::.twasCheckFineMappingMethods("fsusie", fmr, "QtlDataset") ) - # ... but still requires a FineMappingResult (it is a fine-mapping method and - # is not re-fit by twasWeightsPipeline). + # ... but still requires a fine-mapping result (it is a fine-mapping + # method and is not re-fit by twasWeightsPipeline). expect_error( pecotmr:::.twasCheckFineMappingMethods("fsusie", NULL, "QtlDataset"), "may not be re-fit" @@ -582,7 +668,7 @@ test_that("gate: fsusie on QtlSumStats delegates to .fmCheckMethodCapabilities", ) }) -test_that("gate: non-FineMappingResult object passed in errors", { +test_that("gate: an object that is not a fine-mapping result errors", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") expect_error( twasWeightsPipeline(qd, methods = "susie", fineMappingResult = list()), @@ -599,7 +685,7 @@ test_that("gate: unknown method tokens still error with full menu", { }) # --------------------------------------------------------------------------- -# Success: when a FineMappingResult is supplied, the fit is threaded into +# Success: when a fine-mapping result is supplied, the fit is threaded into # the corresponding *Weights wrapper via its *Fit argument. The wrappers # are mocked to verify the fit arrives and the underlying fitter is NOT # re-invoked. @@ -630,8 +716,8 @@ test_that("gate: QtlDataset + susie + fineMappingResult threads the susieFit", { cisWindow = 1000L, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ) )) expect_s4_class(res, "TwasWeights") @@ -651,11 +737,16 @@ test_that("gate: QtlSumStats + susie + fineMappingResult threads the susieRssFit fitsSeen <- 0L mocks <- list( extractBlockGenotypes = .tp_mockExtractor(), - susieRssWeights = function(stat, LD, susieRssFit = NULL, ...) { + susieRssWeights = function( + stat, + ldReference, + susieRssFit = NULL, + ... + ) { if (!is.null(susieRssFit)) { fitsSeen <<- fitsSeen + 1L } - rep(0, nrow(LD)) + rep(0, length(stat$variantNames)) } ) exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) @@ -684,9 +775,14 @@ test_that("gate: QtlSumStats + susieAsh + fineMappingResult threads the susieAsh sawFit <- FALSE mocks <- list( extractBlockGenotypes = .tp_mockExtractor(), - susieAshRssWeights = function(stat, LD, susieAshRssFit = NULL, ...) { + susieAshRssWeights = function( + stat, + ldReference, + susieAshRssFit = NULL, + ... + ) { sawFit <<- !is.null(susieAshRssFit) - rep(0, nrow(LD)) + rep(0, length(stat$variantNames)) } ) exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) @@ -706,7 +802,7 @@ test_that("gate: QtlSumStats + susieAsh + fineMappingResult threads the susieAsh test_that("gate: missing matching tuple in fineMappingResult warns and skips", { ss <- .tp_makeQtlSumStats() - # FineMappingResult has a row for a DIFFERENT (study, context, trait): + # The fine-mapping result has a row for a DIFFERENT (study, context, trait): # the gate passes (any fine-mapping fit present satisfies the object # check), but the per-tuple lookup finds nothing and warns. fmr <- .tp_makeStubFineMappingResult( @@ -776,8 +872,8 @@ test_that("twasWeightsPipeline( cisWindow = 1000L, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ) )) expect_s4_class(res, "TwasWeights") @@ -813,8 +909,8 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash multivariate path with 2 tra cisWindow = 1000L, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ) )) expect_s4_class(res, "TwasWeights") @@ -876,8 +972,8 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the cisWindow = 1000L, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ) )) fit <- methodFits( @@ -915,7 +1011,7 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the trait = rep("t1", n), entry = entries, genome = "hg19", - ldSketch = .tp_makeHandle(snp_n = 20L), + ldReference = .tp_makeHandle(snp_n = 20L), qcInfo = list(step1 = "ok") ) } @@ -931,16 +1027,21 @@ test_that("twasWeightsPipeline(QtlSumStats): mvsusie multivariate path returns o shapesSeen <- list() mocks <- list( extractBlockGenotypes = .tp_mockExtractor(), - mvsusieRssWeights = function(stat, LD, mvsusieRssFit = NULL, ...) { + mvsusieRssWeights = function( + stat, + ldReference, + mvsusieRssFit = NULL, + ... + ) { shapesSeen[[length(shapesSeen) + 1L]] <<- list( Zdim = dim(stat$z), - LDdim = dim(LD), + nVariants = length(stat$variantNames), ctxNames = colnames(stat$z), sawFit = !is.null(mvsusieRssFit) ) matrix( 0, - nrow = nrow(LD), + nrow = length(stat$variantNames), ncol = ncol(stat$z), dimnames = list(stat$variantNames, colnames(stat$z)) ) @@ -973,7 +1074,7 @@ test_that("twasWeightsPipeline(QtlSumStats): mr.mash multivariate solver failure ss <- .tp_makeMultiCtxQtlSumStats(contexts = c("c1", "c2")) mocks <- list( extractBlockGenotypes = .tp_mockExtractor(), - mrmashRssWeights = function(stat, LD, ...) { + mrmashRssWeights = function(stat, ldReference, ...) { stop("synthetic multivariate failure") } ) @@ -1029,8 +1130,8 @@ test_that("twasWeightsPipeline(QtlDataset): full cache hit avoids all weight fit estimatePi = FALSE, twasWeights = cached, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ) ) expect_s4_class(res, "TwasWeights") @@ -1075,8 +1176,8 @@ test_that("twasWeightsPipeline(QtlDataset): partial cache hit fits only missing estimatePi = FALSE, twasWeights = cached, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ) ) expect_setequal(methodNames(res), c("lasso", "enet")) @@ -1099,9 +1200,9 @@ test_that("twasWeightsPipeline(QtlSumStats): cache hit on a per-tuple basis", { list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockSumstatWeights() ) - mocks$lassosumRssWeights <- function(stat, LD, ...) { + mocks$lassosumRssWeights <- function(stat, ldReference, ...) { rssCalls <<- rssCalls + 1L - rep(0, nrow(LD)) + rep(0, length(stat$variantNames)) } exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( @@ -1209,8 +1310,8 @@ test_that("twasWeightsPipeline: mr.mash and mvSuSiE fit side by side", { cisWindow = 1000L, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ) )) expect_s4_class(res, "TwasWeights") @@ -1907,8 +2008,8 @@ test_that(".twasCheckMultivariateY: mvsusie/mrmash error with single trait, sing ) gh <- new( "GenotypeHandle", - path = "/tmp/x.gds", - format = "gds", + path = "/tmp/x", + format = "plink2", snpInfo = data.frame(), nSamples = 0L, sampleIds = character(), @@ -1918,7 +2019,7 @@ test_that(".twasCheckMultivariateY: mvsusie/mrmash error with single trait, sing studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = gh + ldReference = gh ) } @@ -1944,8 +2045,8 @@ test_that(".twasAssertQcd: passes when qcInfo is populated", { ) gh <- new( "GenotypeHandle", - path = "/tmp/x.gds", - format = "gds", + path = "/tmp/x", + format = "plink2", snpInfo = data.frame(), nSamples = 0L, sampleIds = character(), @@ -1955,7 +2056,7 @@ test_that(".twasAssertQcd: passes when qcInfo is populated", { studyName = "g1", entry = list(gr), genome = "hg19", - ldSketch = gh, + ldReference = gh, qcInfo = list(step1 = "ok") ) expect_silent(pecotmr:::.twasAssertQcd(ss)) @@ -1969,8 +2070,8 @@ test_that(".twasAssertQcd: passes when qcInfo is populated", { .gsd_makeHandle <- function(snp_n = 2L) { new( "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", + path = "/tmp/sketch", + format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), CHR = rep("1", snp_n), @@ -1998,7 +2099,7 @@ test_that(".twasAssertQcd: passes when qcInfo is populated", { studyName = "G1", entry = list(gr), genome = "hg19", - ldSketch = .gsd_makeHandle(snp_n), + ldReference = .gsd_makeHandle(snp_n), qcInfo = list(prebuilt = "synthetic") ) } @@ -2177,7 +2278,7 @@ test_that(".twasFineMappingFits: NULL input returns an empty list", { expect_equal(out, list()) }) -test_that(".twasFineMappingFits: non-FineMappingResult input errors", { +test_that(".twasFineMappingFits: refuses a non-result input", { expect_error( pecotmr:::.twasFineMappingFits( "not_a_result", @@ -2371,46 +2472,6 @@ test_that(".twasNormalizeCharMethods: fine-mapping-only tokens skip lookup", { expect_equal(res$methodList[["fsusie_weights"]], list()) }) -test_that(".twasMergedEntryForRow gathers one key across regions", { - data(twasWeightsExample) - tw <- twasWeightsExample - base <- data.frame( - study = as.character(tw$study), - context = as.character(tw$context), - trait = as.character(tw$trait), - method = as.character(tw$method), - stringsAsFactors = FALSE - ) - m <- pecotmr:::.twasMergedEntryForRow(1L, base, list(tw, tw), c("rA", "rB")) - expect_s4_class(m, "TwasWeightsRow") - expect_equal(names(methodFits(m)), c("rA", "rB")) - # Same table twice: the merged entry carries both regions' variants. - one <- pecotmr:::.twasMergedEntryForRow(1L, base, list(tw), "rA") - expect_equal( - length(pecotmr:::.twrPartsVariantIds(m)), - 2L * length(pecotmr:::.twrPartsVariantIds(one)) - ) -}) - -test_that(".twasMergedEntryForRow returns NULL when no region matches", { - data(twasWeightsExample) - bad <- data.frame( - study = "nope", - context = "x", - trait = "y", - method = "z", - stringsAsFactors = FALSE - ) - expect_null( - pecotmr:::.twasMergedEntryForRow( - 1L, - bad, - list(twasWeightsExample), - "rA" - ) - ) -}) - test_that("twasWeightsPipeline(QtlDataset): region + cisWindow is rejected", { qd <- .tp_makeQtlDataset(traits = "ENSG_A") expect_error( @@ -2446,8 +2507,8 @@ test_that("twasWeightsPipeline(QtlDataset): jointRegions=FALSE concatenates per- jointRegions = FALSE, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() )) expect_s4_class(res, "TwasWeights") # 1 ctx x 1 trait x 1 method -> a single merged row. @@ -2485,8 +2546,8 @@ test_that("twasWeightsPipeline(QtlDataset): jointRegions=TRUE fits one concatena jointRegions = TRUE, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() )) expect_equal(nrow(res), 1L) w <- weights( @@ -2533,8 +2594,8 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash jointRegions=FALSE concatena jointRegions = FALSE, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ))) expect_s4_class(res, "TwasWeights") # 2 contexts x 2 traits = 4 rows, each with weights concatenated over regions. @@ -3007,17 +3068,33 @@ test_that("ensembleWeights: twasWeightList non-list and dimension-mismatch warni # twasWeightsPipeline(QtlDataset): remaining branches # ----------------------------------------------------------------------------- -test_that("twasWeightsPipeline(QtlDataset): fitFullData=FALSE without CV errors", { +test_that("QtlDataset: CrossValidationParam(fitFullData) reaches the engine", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + cap <- new.env(parent = emptyenv()) + local_mocked_bindings( + .twasQdsRunGrid = function(grid, marker, ...) { + cap$marker <- marker + abort("captured") + }, + .package = "pecotmr" + ) expect_error( twasWeightsPipeline( qd, methods = list(lasso = list()), - fitFullData = FALSE, - crossValidationArgs = CrossValidationParam(folds = 0) + cisWindow = 1000L, + verbose = 0, + crossValidationParam = CrossValidationParam( + folds = 2, + fitFullData = FALSE + ) ), - "fitFullData = FALSE requires cross-validation" + "captured" ) + cfg <- pecotmr:::.jpConfig(cap$marker) + expect_false(cfg$crossValidationParam$fitFullData) + # One home for the setting: the marker no longer carries a second copy. + expect_null(cfg$fitFullData) }) test_that("twasWeightsPipeline(QtlDataset): mashPrior with no mrmash warns and is ignored", { @@ -3038,8 +3115,8 @@ test_that("twasWeightsPipeline(QtlDataset): mashPrior with no mrmash warns and i cisWindow = 1000L, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() )), "not among `methods`" ) @@ -3070,8 +3147,8 @@ test_that("twasWeightsPipeline(QtlDataset): mashPrior full prior is threaded int cisWindow = 1000L, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ))) expect_identical(captured, ddpm) }) @@ -3102,8 +3179,8 @@ test_that("twasWeightsPipeline(QtlDataset): jointSpec mr.mash + univariate lasso cisWindow = 1000L, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ))) expect_s4_class(res, "TwasWeights") expect_true("mrmash" %in% as.character(res$method)) # from jointResult @@ -3127,8 +3204,8 @@ test_that("twasWeightsPipeline(QtlDataset): region selects overlapping traits", region = region, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ))) expect_setequal(traitNames(res), "ENSG_A") # only the overlapping gene }) @@ -3144,7 +3221,9 @@ test_that("twasWeightsPipeline(QtlSumStats): NULL methods uses the default RSS p !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), - prsCsWeights = function(stat, LD, ...) rep(0, nrow(LD)) + prsCsWeights = function(stat, ldReference, ...) { + rep(0, length(stat$variantNames)) + } ), # .tp_mockSumstatWeights() already mocks sdprWeights. Passing a # binding to local_mocked_bindings() twice makes it record the @@ -3212,9 +3291,10 @@ test_that("twasWeightsPipeline(QtlSumStats): multivariate mr.mash returns a colu !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), - mrmashRssWeights = function(stat, LD, ...) { + mrmashRssWeights = function(stat, ldReference, ...) { k <- if (is.matrix(stat$z)) ncol(stat$z) else 1L - matrix(0, nrow(LD), k, dimnames = list(rownames(LD), NULL)) + ids <- stat$variantNames + matrix(0, length(ids), k, dimnames = list(ids, NULL)) } ), .tp_mockSumstatWeights(), @@ -3230,7 +3310,7 @@ test_that("twasWeightsPipeline(QtlSumStats): multivariate mr.mash returns a colu test_that("twasWeightsPipeline(QtlSumStats): fine-mapping method absent from fineMappingResult errors", { ss <- .tp_makeQtlSumStats(n_entries = 2L) - # FineMappingResult that does NOT contain an mvsusie fit (only susie). + # A fine-mapping result that does NOT contain an mvsusie fit (only susie). fmr <- .tp_makeStubFineMappingResult( studyName = "s1", contexts = "c1", @@ -3262,7 +3342,7 @@ test_that("twasWeightsPipeline(QtlSumStats): fine-mapping method absent from fin test_that("twasWeightsPipeline(MultiStudyQtlDataset): per-study options are not dropped", { # residualization and fit retention were declared on the multi-study - # method and never reached .twasMsDriver's config, and the + # method and never reached .twasMsCfg's config, and the # QtlDataset-only options rode `...` into the embedded QtlSumStats call. cap <- new.env(parent = emptyenv()) local_mocked_bindings( @@ -3282,20 +3362,83 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): per-study options are not cisWindow = 1000L, verbose = 0, estimatePi = FALSE, - fitFullData = FALSE, + usePCA = TRUE, + nPCs = 3L, + weightsDataType = "rnaseq", fitRetention = "none", - residualizationArgs = ResidualizationParam( + residualizationParam = ResidualizationParam( residualizeGenotype = FALSE ), - crossValidationArgs = CrossValidationParam(folds = 0) + crossValidationParam = CrossValidationParam( + folds = 2, + fitFullData = FALSE + ) ))), "no entries produced weights" ) expect_false(cap$cfg$estimatePi) - expect_false(cap$cfg$fitFullData) + expect_true(cap$cfg$usePCA) + expect_equal(cap$cfg$nPCs, 3L) + expect_equal(cap$cfg$weightsDataType, "rnaseq") + expect_false(cap$cfg$crossValidationParam$fitFullData) # "none" is provably not the default, and lasso can honour it. expect_equal(cap$cfg$fitRetention, "none") - expect_false(cap$cfg$residualizationArgs$residualizeGenotype) + expect_false(cap$cfg$residualizationParam$residualizeGenotype) +}) + +test_that("MultiStudyQtlDataset: components get fitRetention as asked", { + # .twasRetentionEnum() once tested isTRUE() on this enum, so every + # component ran with "none" whatever the caller asked for. The test above + # could not see it: it inspects the record, and it asks for "none". + cap <- new.env(parent = emptyenv()) + local_mocked_bindings( + twasWeightsPipeline = function(data, ...) { + cap$args <- list(...) + NULL + }, + .package = "pecotmr" + ) + # Real components: each worker first takes its own share of the + # selection, which needs the study it is working on. + qd <- .tp_makeQtlDataset() + ss <- .tp_makeQtlSumStats() + for (level in c("slim", "none", "full")) { + cfg <- list( + methods = "lasso", + fitRetention = level, + usePCA = TRUE, + nPCs = 3L, + weightsDataType = "rnaseq" + ) + pecotmr:::.twasPerStudy(qd, cfg) + expect_equal(cap$args$fitRetention, level) + expect_true(cap$args$usePCA) + expect_equal(cap$args$nPCs, 3L) + expect_equal(cap$args$weightsDataType, "rnaseq") + pecotmr:::.twasSumStats(ss, cfg) + expect_equal(cap$args$fitRetention, level) + expect_equal(cap$args$weightsDataType, "rnaseq") + } +}) + +test_that("MultiStudyQtlDataset takes every component argument", { + # The MultiStudy method recurses into its QtlDataset and QtlSumStats + # components, so an argument either takes but the MultiStudy method lacks + # cannot reach them at all -- usePCA / nPCs went missing exactly this way. + # The record handed to the components must carry each of them too; the + # cfg-forwarding test in test_fineMappingPipeline.R checks the last leg, + # record -> component. + ms <- .methodFormalNames("twasWeightsPipeline", "MultiStudyQtlDataset") + comp <- union( + .methodFormalNames("twasWeightsPipeline", "QtlDataset"), + .methodFormalNames("twasWeightsPipeline", "QtlSumStats") + ) + expect_equal(setdiff(comp, ms), character(0)) + expect_equal(setdiff(ms, comp), character(0)) + expect_equal( + setdiff(ms, c(.cfgFieldNames(".twasMsCfg"), "jointSpecification")), + character(0) + ) }) test_that("twasWeightsPipeline(MultiStudyQtlDataset): a misspelled option errors", { @@ -3327,8 +3470,8 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): recurses into components a cisWindow = 1000L, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ))) expect_s4_class(res, "TwasWeights") expect_setequal(as.character(res$study), c("study1", "s1")) # both phases @@ -3397,8 +3540,8 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): jointSpec mr.mash + univar cisWindow = 1000L, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ))) expect_s4_class(res, "TwasWeights") expect_true("mrmash" %in% as.character(res$method)) @@ -3497,14 +3640,15 @@ test_that("twasWeightsPipeline( trait = c("t1", "t1", "t2"), entry = entries, genome = "hg19", - ldSketch = .tp_makeHandle(snp_n = 20L), + ldReference = .tp_makeHandle(snp_n = 20L), qcInfo = list(step1 = "ok") ) local_mocked_bindings( extractBlockGenotypes = .tp_mockExtractor(), - mrmashRssWeights = function(stat, LD, ...) { + mrmashRssWeights = function(stat, ldReference, ...) { k <- if (is.matrix(stat$z)) ncol(stat$z) else 1L - matrix(0, nrow(LD), k, dimnames = list(rownames(LD), NULL)) + ids <- stat$variantNames + matrix(0, length(ids), k, dimnames = list(ids, NULL)) }, .package = "pecotmr" ) @@ -3814,6 +3958,26 @@ test_that("twasWeightsPipeline(QtlSumStats) drops panel-rare variants", { expect_lt(tight, loose) }) +test_that("twasWeightsPipeline(QtlSumStats) fits PRS-CS and SDPR", { + # Unmocked: both read the entry's z. They used to read a `b` this path + # never supplies, so every entry failed with a warning. + ss <- .twrssf_qcd() + res <- suppressMessages(twasWeightsPipeline( + ss, + methods = list( + prsCs = PrsCsOptions(nIter = 40, nBurnin = 10, thin = 1, seed = 1), + dprGibbs = SdprOptions( + iter = 40, + burn = 10, + thin = 1, + verbose = FALSE + ) + ), + verbose = 0 + )) + expect_setequal(methodNames(res), c("prsCs", "dprGibbs")) +}) + test_that("twasWeightsPipeline RSS cutoffs match .panelVariantFilter", { # Exactly the variants the shared filter names: no more (something else is # filtering) and no fewer (the cutoff silently did nothing). @@ -3830,7 +3994,7 @@ test_that("twasWeightsPipeline RSS cutoffs match .panelVariantFilter", { expect_equal( .twrssf_n(ss, mafCutoff = cut), length(.panelVariantFilter( - ldSketch(ss), + ldReference(ss), ids, PanelFilterParam(mafCutoff = cut) )), @@ -3841,7 +4005,7 @@ test_that("twasWeightsPipeline RSS cutoffs match .panelVariantFilter", { test_that("twasWeightsPipeline RSS treats MAC as a MAF equivalent", { ss <- .twrssf_qcd() - nSamp <- ncol(ldSketch(ss)) + nSamp <- ncol(ldReference(ss)) expect_equal( .twrssf_n(ss, macCutoff = 0.1 * 2 * nSamp), .twrssf_n(ss, mafCutoff = 0.1) @@ -3854,9 +4018,9 @@ test_that("twasWeightsPipeline RSS honours a missingness cutoff", { expect_equal(.twrssf_n(ss, imissCutoff = 1), sum(lengths(ss))) }) -test_that(".twasQssUnivariateFitCtx keeps z, ids and LD aligned", { +test_that(".twasQssUnivariateFitCtx keeps z, ids and LD reference aligned", { ss <- .twrssf_qcd() - sketch <- ldSketch(ss) + sketch <- ldReference(ss) args <- list(ss, ss$study[[1L]], ss$context[[1L]], ss$trait[[1L]], sketch) plain <- exec(pecotmr:::.twasQssUnivariateFitCtx, !!!args) cut <- suppressMessages(exec( @@ -3865,11 +4029,17 @@ test_that(".twasQssUnivariateFitCtx keeps z, ids and LD aligned", { cutoffs = list(mafCutoff = 0.2, macCutoff = 0, imissCutoff = 1) )) expect_lt(length(cut$variantIds), length(plain$variantIds)) - # z, the stored variant names and the LD matrix all agree on the set. + # z, the stored variant names and the LD reference all agree on the set: + # the in-memory reference block holds exactly the kept variants, with its + # dosage realized once for every method fitted to it. expect_equal(length(cut$stat$z), length(cut$variantIds)) expect_equal(cut$stat$variantNames, cut$variantIds) - expect_equal(nrow(cut$ldMat), length(cut$variantIds)) - expect_equal(rownames(cut$ldMat), cut$variantIds) + expect_equal(nrow(cut$ldReference), length(cut$variantIds)) + expect_true(is.matrix( + SummarizedExperiment::assay(cut$ldReference, "dosage") + )) + R <- pecotmr:::.ldFromRef(cut$ldReference, cut$variantIds, "test") + expect_equal(rownames(R), cut$variantIds) keep <- is_in(plain$variantIds, cut$variantIds) expect_equal(cut$stat$z, plain$stat$z[keep]) }) @@ -3945,27 +4115,6 @@ test_that("mrmash is stripped from either shape, leaving others intact", { expect_equal(g(42), 42) }) -test_that("a region lacking a tuple contributes no entry for it", { - # NULL, not an empty row: a region that never fitted the tuple must not - # dilute the merged weights with zeros. - data(twasWeightsExample) - tw <- twasWeightsExample - key <- c( - as.character(tw$study)[[1L]], - as.character(tw$context)[[1L]], - as.character(tw$trait)[[1L]], - as.character(tw$method)[[1L]] - ) - expect_s4_class( - pecotmr:::.twasEntryMatchingKey(tw, key), - "TwasWeightsRow" - ) - expect_null( - pecotmr:::.twasEntryMatchingKey(tw, c("nope", "x", "y", "z")) - ) -}) - - # =========================================================================== # Merging per-region and joint results # =========================================================================== @@ -4073,7 +4222,7 @@ test_that(".twasQssMultivariateFitOne promotes vector weights to a matrix", { test_that(".twasQssAssemble passes the joint result through alone", { jr <- "SENTINEL_JOINT" expect_identical( - pecotmr:::.twasQssAssemble(list(), jr, ldSketch = NULL), + pecotmr:::.twasQssAssemble(list(), jr, ldReference = NULL), jr ) }) @@ -4104,14 +4253,17 @@ test_that(".twasMsJointPhase aborts when only mrmash asked and it fails", { ) }) -test_that(".twasRunMultivariateGrid returns NULL when every region is empty", { +test_that(".twasRunJointSpecGrid returns NULL when every region is empty", { local_mocked_bindings( - .twasMvGridRegion = function(...) NULL, + .twasJointSpecRegion = function(...) NULL, .twasRegionLabel = function(x) "rX", .package = "pecotmr" ) expect_null( - pecotmr:::.twasRunMultivariateGrid( + pecotmr:::.twasRunJointSpecGrid( + spec = list(list(axes = "context", scope = NULL)), + tokens = "mrmash", + contexts = NULL, traits = "T1", marker = NULL, ctx = list(xRegions = list(1, 2)) @@ -4283,28 +4435,89 @@ test_that("each path takes that path's own constructor", { }) test_that("twasWeightsPipeline: fitRetention='full' says so when unhonourable", { - # Only the mr.mash engines distinguish the levels; for every other - # method "full" was silently indistinguishable from "slim". + # Few methods distinguish the levels; for every other method "full" was + # silently indistinguishable from "slim". On individual-level data only + # mr.mash does. expect_error( twasWeightsPipeline( .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A"), methods = "lasso", fitRetention = "full" ), - "only honoured by the mr.mash methods" + "honoured on QtlDataset input only by mrmash" ) # A mixed run warns and proceeds -- mr.mash honours "full", lasso does # not. Asserted on the rule itself: driving it through the pipeline would # also need mr.mash mocked, which tests the mock rather than the rule. + warnFull <- pecotmr:::.twasWarnUnretainableDetail expect_warning( - pecotmr:::.twasWarnUnretainableDetail("full", c("lasso", "mrmash")), + warnFull("full", c("lasso", "mrmash"), "QtlDataset"), "lasso retain their usual fit" ) - expect_silent(pecotmr:::.twasWarnUnretainableDetail("full", "mrmash")) - expect_silent(pecotmr:::.twasWarnUnretainableDetail("slim", "lasso")) - expect_silent(pecotmr:::.twasWarnUnretainableDetail("none", "lasso")) + expect_silent(warnFull("full", "mrmash", "QtlDataset")) + expect_silent(warnFull("slim", "lasso", "QtlDataset")) + expect_silent(warnFull("none", "lasso", "QtlDataset")) + # On summary statistics the shrinkage-grid methods keep their candidate + # coefficients at "full"; PRS-CS keeps the same fit either way. + expect_silent(warnFull("full", c("lasso", "scad"), "QtlSumStats")) + expect_warning( + warnFull("full", c("lasso", "prsCs"), "QtlSumStats"), + "prsCs retain their usual fit" + ) + expect_error( + warnFull("full", "prsCs", "QtlSumStats"), + "honoured on QtlSumStats input only by" + ) # Tokens unknown yet (methods = NULL) defers rather than guessing. - expect_silent(pecotmr:::.twasWarnUnretainableDetail("full", NULL)) + expect_silent(warnFull("full", NULL, "QtlDataset")) +}) + +test_that("twasWeightsPipeline(QtlSumStats) hands its fitRetention down", { + # A weight function taking fitRetention receives the run's level -- + # "none" too, which the fine-mapping adapters here need told -- unless + # the method sets its own; the fit it returns is kept on the row. + ss <- .tp_makeQtlSumStats() + seen <- new.env(parent = emptyenv()) + local_mocked_bindings( + extractBlockGenotypes = .tp_mockExtractor(), + lassosumRssWeights = function( + stat, + ldReference, + fitRetention = "none", + ... + ) { + seen$level <- fitRetention + w <- rep(0, length(stat$variantNames)) + if (identical(fitRetention, "none")) { + return(w) + } + `attr<-`(w, "fit", list(level = fitRetention)) + }, + .package = "pecotmr" + ) + run <- function(...) { + suppressMessages(suppressWarnings( + twasWeightsPipeline(ss, verbose = 0, ...) + )) + } + fitOf <- function(res) { + methodFits( + res, + studyName = "s1", + context = "c1", + trait = "t1", + method = "lasso" + ) + } + slim <- run(methods = "lasso") + expect_identical(seen$level, "slim") + expect_identical(fitOf(slim), list(level = "slim")) + none <- run(methods = "lasso", fitRetention = "none") + expect_identical(seen$level, "none") + expect_null(fitOf(none)) + own <- run(methods = list(lasso = list(fitRetention = "full"))) + expect_identical(seen$level, "full") + expect_identical(fitOf(own), list(level = "full")) }) test_that("twasWeightsPipeline: fitRetention rejects an unknown level", { @@ -4323,8 +4536,8 @@ test_that("twasWeightsPipeline(QtlDataset): residualization reaches the fit", { # take, so every QtlDataset run used the default regardless of the ask. cap <- new.env(parent = emptyenv()) local_mocked_bindings( - .fmResidGeno = function(x, residualizationArgs, ...) { - cap$geno <- residualizationArgs + .fmResidGeno = function(x, residualizationParam, ...) { + cap$geno <- residualizationParam matrix( 0, nrow = 2, @@ -4340,8 +4553,8 @@ test_that("twasWeightsPipeline(QtlDataset): residualization reaches the fit", { methods = "lasso", cisWindow = 1000L, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - residualizationArgs = ResidualizationParam( + crossValidationParam = CrossValidationParam(folds = 0), + residualizationParam = ResidualizationParam( residualizeGenotype = FALSE ) )), @@ -4374,8 +4587,8 @@ test_that("twasWeightsPipeline(QtlDataset): usePCA adds top-PC rows", { verbose = 0, usePCA = usePCA, nPCs = 2L, - crossValidationArgs = CrossValidationParam(folds = 0), - ensembleArgs = EnsembleParam() + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() ))) } plain <- run(FALSE) @@ -4471,10 +4684,11 @@ test_that("twasWeightsPipeline: multivariate resume is all-or-nothing", { !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), - mrmashRssWeights = function(stat, LD, ...) { + mrmashRssWeights = function(stat, ldReference, ...) { calls$n <- calls$n + 1L k <- if (is.matrix(stat$z)) ncol(stat$z) else 1L - matrix(0, nrow(LD), k, dimnames = list(rownames(LD), NULL)) + ids <- stat$variantNames + matrix(0, length(ids), k, dimnames = list(ids, NULL)) } ), .tp_mockSumstatWeights(), @@ -4516,7 +4730,7 @@ test_that("twasWeightsPipeline: multivariate resume is all-or-nothing", { test_that(".ensembleAssertCv reports the fold count it actually saw", { # The message interpolated `crossValidation$folds`, but the formal is - # `crossValidationArgs` -- so firing the assertion raised glue's own + # `crossValidationParam` -- so firing the assertion raised glue's own # "failed to evaluate" instead of the actionable message. Error paths # are where this hides: the condition was right, only the report was not. expect_error( @@ -4566,7 +4780,7 @@ test_that("twasWeightsPipeline(QtlDataset) records the standardized scale", { cisWindow = 1000L, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0) + crossValidationParam = CrossValidationParam(folds = 0) ))) # Derived, not declared: genotypes are standardized on the way to every # fitter, so there is nothing for a caller to say. @@ -4613,8 +4827,8 @@ test_that("the TWAS genotype scale also comes from the accessor", { cisWindow = 1000L, estimatePi = FALSE, verbose = 0, - crossValidationArgs = CrossValidationParam(folds = 0), - residualizationArgs = ResidualizationParam(...) + crossValidationParam = CrossValidationParam(folds = 0), + residualizationParam = ResidualizationParam(...) ))) unique(as.logical(S4Vectors::mcols(res)$standardized)) } @@ -4628,3 +4842,118 @@ test_that("no TWAS pipeline takes a standardizeGenotypes argument", { names(formals(pecotmr:::.twasPipelineQtlDataset)) )) }) + +# ---- joint fits receive the caller's settings ------------------------------ + +test_that("QtlDataset: explicit joint fits get every caller setting", { + # The explicit-joint dispatch built its own pipeline record -- default + # cross-validation, no fitRetention -- and handed the engine neither the + # residualization settings nor the per-method options. + cap <- new.env(parent = emptyenv()) + .captureJointEngine(cap) + rp <- ResidualizationParam(scaleResiduals = FALSE) + expect_error( + suppressMessages(twasWeightsPipeline( + .tp_makeQtlDataset(contexts = c("brain", "liver")), + methods = list(mrmash = list(max_iter = 5)), + traitId = "ENSG_A", + cisWindow = 1000L, + jointSpecification = "context", + residualizationParam = rp, + crossValidationParam = CrossValidationParam( + folds = 2, + fitFullData = FALSE + ), + fitRetention = "full", + weightsDataType = "rnaseq", + seed = 7L + )), + "no joint fits produced" + ) + ind <- .capturedCall(cap, "individual") + expect_identical(ind$args$residualizationParam, rp) + expect_equal(ind$config$crossValidationParam$folds, 2) + expect_false(ind$config$crossValidationParam$fitFullData) + expect_equal(ind$config$fitRetention, "full") + expect_equal(ind$config$dataType, "rnaseq") + # Honest now that the setting reaches the fit. + expect_false(ind$config$standardized) + expect_equal(ind$args$methodList$mrmash_weights$max_iter, 5) +}) + +test_that("QtlSumStats: joint fits get fitRetention and the mr.mash options", { + cap <- new.env(parent = emptyenv()) + .captureJointEngine(cap) + expect_error( + suppressMessages(twasWeightsPipeline( + .tp_makeMultiCtxQtlSumStats(), + methods = list(mrmash = list(max_iter = 5)), + jointSpecification = "context", + fitRetention = "full", + weightsDataType = "rnaseq" + )), + "no joint fits produced" + ) + ss <- .capturedCall(cap, "sumstats") + expect_equal(ss$config$fitRetention, "full") + expect_equal(ss$config$dataType, "rnaseq") + expect_equal(ss$args$methodArgs$mrmash$max_iter, 5) +}) + +test_that("MultiStudyQtlDataset: joint fits get every caller setting", { + cap <- new.env(parent = emptyenv()) + .captureJointEngine(cap) + rp <- ResidualizationParam(scaleResiduals = FALSE) + expect_error( + suppressMessages(twasWeightsPipeline( + .tp_makeMultiStudy(), + methods = list(mrmash = list(max_iter = 5)), + cisWindow = 1000L, + jointSpecification = "context", + residualizationParam = rp, + crossValidationParam = CrossValidationParam(folds = 2), + genotypeFilterParam = GenotypeFilterParam(mafCutoff = 0.05), + fitRetention = "full", + weightsDataType = "rnaseq", + seed = 7L + )), + "no joint fits produced" + ) + ind <- .capturedCall(cap, "individual") + expect_identical(ind$args$residualizationParam, rp) + expect_equal(ind$config$crossValidationParam$folds, 2) + expect_equal(ind$config$fitRetention, "full") + expect_equal(ind$config$dataType, "rnaseq") + expect_equal(ind$args$methodList$mrmash_weights$max_iter, 5) + expect_equal(mafCutoff(ind$data), 0.05) + ss <- .capturedCall(cap, "sumstats") + expect_equal(ss$config$fitRetention, "full") + expect_equal(ss$config$dataType, "rnaseq") + expect_equal(ss$args$methodArgs$mrmash$max_iter, 5) +}) + + +test_that("refuses full-data weights from a CV-only fineMappingResult", { + # A fine-mapping-derived weight is read off the fine-mapping fit, which a + # cross-validation-only row does not have; a cross-validation-only TWAS + # run needs only the folds, which the row does carry. + cv <- list(samplePartition = data.frame(Sample = "s1", Fold = 1L)) + fmr <- QtlFineMappingResult( + studyName = "s", + context = "c", + trait = "t", + method = "susie", + entry = list(pecotmr:::.fmCvOnlyRow(cv)) + ) + expect_error( + pecotmr:::.twasCheckFineMappingMethods("susie", fmr, "QtlDataset"), + "cross-validation-only" + ) + expect_silent(pecotmr:::.twasCheckFineMappingMethods( + "susie", + fmr, + "QtlDataset", + cvFolds = 3, + fitFullData = FALSE + )) +}) diff --git a/tests/testthat/test_variantId.R b/tests/testthat/test_variantId.R index b587414d0..1f90fc786 100644 --- a/tests/testthat/test_variantId.R +++ b/tests/testthat/test_variantId.R @@ -661,6 +661,12 @@ test_that("canonChrom normalizes prefixes, case, and synonyms to strings", { ) # never coerces to integer -- non-autosomes survive expect_type(pecotmr:::canonChrom("chrX"), "character") + # A zero-padded number (UK Biobank's BGEN files write 01) is the same + # chromosome; a lone 0 and non-numeric labels keep their zeros. + expect_equal( + pecotmr:::canonChrom(c("01", "chr01", "001", "10", "0", "023")), + c("1", "1", "1", "10", "0", "X") + ) }) test_that("parseVariantId keeps non-autosomal chromosomes as strings", { diff --git a/vignettes/coloc-pipeline.Rmd b/vignettes/coloc-pipeline.Rmd index 6ed6231e6..62f99d92f 100644 --- a/vignettes/coloc-pipeline.Rmd +++ b/vignettes/coloc-pipeline.Rmd @@ -70,7 +70,7 @@ window used in the res <- colocPipeline( qtlFineMappingResult = qtlFmr, gwasInput = gwasSumStatsS4Example, - gwasFineMappingArgs = GwasFineMappingParam(methods = "susie") + gwasFineMappingParam = GwasFineMappingParam(methods = "susie") ) res ``` @@ -87,8 +87,9 @@ res2 <- colocPipeline( attr(res2, "gwasFineMapping") ``` -If the QTL `FineMappingResult` has an LD sketch because it was run on summary -statistics it must match the LD sketch for the `GWASSumStats`. +If the `QtlFineMappingResult` has an LD reference because it was run on +summary statistics, it must be the same LD reference as the `GwasSumStats` +carries. ## QTL FMR + pre-computed GWAS FMR @@ -122,7 +123,7 @@ included. Two opt-in filters can adjust this: colocPipeline( qtlFineMappingResult = qtlFmr, gwasInput = gwasSumStatsS4Example, - lbfFilterArgs = ColocLbfFilterParam( + colocLbfFilterParam = ColocLbfFilterParam( secondary = 0.5, # 50% CS concentration filter concentration = 0.5 ) @@ -198,14 +199,14 @@ colocPipeline( colocPipeline( qtlFineMappingResult = qtlFmr, gwasInput = gwasSumStatsS4Example, - lbfFilterArgs = ColocLbfFilterParam( + colocLbfFilterParam = ColocLbfFilterParam( filterLbfCs = FALSE, secondary = NULL, # e.g. 0.5 concentration = 0.5, priorTol = 1e-9 ), priors = ColocPriorParam(p1 = 1e-4, p2 = 1e-4, p12 = 5e-6), - gwasFineMappingArgs = GwasFineMappingParam( # inline GWAS FM when needed + gwasFineMappingParam = GwasFineMappingParam( # inline GWAS FM when needed methods = "susie", credibleSetParam = CredibleSetParam(coverage = 0.95) ), diff --git a/vignettes/colocboost-pipeline.Rmd b/vignettes/colocboost-pipeline.Rmd index 69b8fe26f..422af3cc0 100644 --- a/vignettes/colocboost-pipeline.Rmd +++ b/vignettes/colocboost-pipeline.Rmd @@ -34,7 +34,7 @@ layered on top. It accepts inputs from the QTL input classes: GWAS input (optional) is always a `GwasSumStats`, passed as the separate `gwasSumStats` argument. `colocboostPipeline()` does **not** -accept a `FineMappingResult` for either side — colocboost runs its own +accept a fine-mapping result for either side — colocboost runs its own variable selection. ```{r load-packages} @@ -111,7 +111,7 @@ names(res3$separate_gwas) ## Sumstats-only colocalization A `QtlSumStats` input goes through the same dispatch with no -individual-level data needed; the LD comes from the `ldSketch` +individual-level data needed; the LD comes from the `ldReference` genotype panel carried on the collection. ```{r sumstats} diff --git a/vignettes/constructing-qtl-datasets.Rmd b/vignettes/constructing-qtl-datasets.Rmd index 38341d6ff..49e2c86ae 100644 --- a/vignettes/constructing-qtl-datasets.Rmd +++ b/vignettes/constructing-qtl-datasets.Rmd @@ -46,7 +46,7 @@ Alongside them the object keeps a `colData` naming every sample and a need not share a sample set — plus its own slots: * `study` — study identifier (length-1 character). -* `genotypes` — the genotype panel (a lazy PLINK1/PLINK2/VCF/GDS source, +* `genotypes` — the genotype panel (a lazy PLINK1/PLINK2/VCF/GDS/BGEN source, read with `readGenotypes()`) that the dosage assay reads through. * QC thresholds — `mafCutoff`, `macCutoff`, `xvarCutoff`, `imissCutoff`, `keepIndel`, `keepVariants`, `scaleResiduals`. Stored as **lazy** filters, @@ -276,7 +276,8 @@ names(qtlDatasets(msdManual)) ``` To attach a summary-only study, pass a `QtlSumStats` object to the `sumStats` -argument. manifest form, supply `sumStatsManifest`, `genome`, and `ldSketch`). +argument. For the manifest form, supply `sumStatsManifest`, `genome`, and +`ldReference`. ## Excluding related samples diff --git a/vignettes/constructing-sumstats.Rmd b/vignettes/constructing-sumstats.Rmd index cf913147b..9ce9a8b80 100644 --- a/vignettes/constructing-sumstats.Rmd +++ b/vignettes/constructing-sumstats.Rmd @@ -37,9 +37,11 @@ dosage-counted allele), `A2` (other allele), `Z`, `N`; optionally `MAF`, stored in slots, not columns: * `genome` — the build label (e.g. `"GRCh38"`). -* `ldSketch` — a genotype panel (a `RangedSummarizedExperiment`, as returned - by `readGenotypes()`) giving the LD reference used for QC and downstream - analyses. +* `ldReference` — the LD reference used for QC and downstream analyses: a + genotype panel (a `RangedSummarizedExperiment`, as returned by + `readGenotypes()`), a `GenotypeMixture`, or an `LdMatrix` holding a + correlation matrix you built (see the + [LD reference vignette](ld-infrastructure.html)). Optional per-row columns: `varY` (phenotype variance) and, for case/control GWAS, `nCase` / `nControl`. @@ -74,7 +76,7 @@ genoPrefix <- sub( "", system.file("extdata", "toy_ref.bed", package = "pecotmr") ) -ldSketch <- readGenotypes(plink1Prefix = genoPrefix) +ldReference <- readGenotypes(plink1Prefix = genoPrefix) # Five real toy_ref chr22 sites (positions and alleles taken from the panel). sumstatsDf <- data.frame( @@ -102,9 +104,9 @@ readr::write_tsv(sumstatsDf, gwasTsv) ## GwasSumStats from a manifest -The GWAS manifest has **one row per study**. `genome` and `ldSketch` are +The GWAS manifest has **one row per study**. `genome` and `ldReference` are collection-level, so they are supplied as arguments (or as constant -`genome` / `ldSketchPath` columns). +`genome` / `ldReferencePath` columns). | Column | Required | Meaning | |---|---|---| @@ -113,7 +115,7 @@ collection-level, so they are supplied as arguments (or as constant | `columnMapping` (alias `column_mapping`) | no | YAML column map (see below) | | `nCase` / `nControl` | no | case / control counts | | `varY` | no | phenotype variance | -| `genome`, `ldSketchPath` | single-valued | may instead be arguments | +| `genome`, `ldReferencePath` | single-valued | may instead be arguments | ```{r gwas-from-manifest} gwasManifest <- data.frame( @@ -125,13 +127,13 @@ gwasManifest <- data.frame( gws <- loadGwasSumStatsFromManifest( gwasManifest, genome = "GRCh38", - ldSketch = ldSketch + ldReference = ldReference ) gws S4Vectors::mcols(gws[[1]]) ``` -The `ldSketch` argument also accepts a path/prefix or a chromosome-sharded +The `ldReference` argument also accepts a path/prefix or a chromosome-sharded `genoMeta` specification (see `?readGenotypes`), so a genome-wide reference can be supplied as a `#chr,path` meta file rather than a single panel. @@ -139,7 +141,7 @@ be supplied as a `#chr,path` meta file rather than a single panel. The loader is a wrapper over the `GwasSumStats()` constructor. Built by hand, the pattern is: make one `GRanges` per study with the required `mcols`, then -call the constructor with the shared `genome` and `ldSketch`. +call the constructor with the shared `genome` and `ldReference`. ```{r gwas-manual} entry <- GenomicRanges::GRanges( @@ -158,7 +160,7 @@ gwsManual <- GwasSumStats( studyName = "MyGWAS", entry = list(entry), genome = "GRCh38", - ldSketch = ldSketch + ldReference = ldReference ) gwsManual ``` @@ -178,7 +180,7 @@ points at a sumstats file for that trait. | `trait` (alias `gene_id`) | yes | molecular trait id | | `sumStatsPath` (alias `path`) | yes | sumstats file for this trait | | `columnMapping`, `varY` | no | as for GWAS | -| `genome`, `ldSketchPath` | single-valued | may instead be arguments | +| `genome`, `ldReferencePath` | single-valued | may instead be arguments | ```{r qtl-from-manifest} qtlManifest <- data.frame( @@ -192,7 +194,7 @@ qtlManifest <- data.frame( qts <- loadQtlSumStatsFromManifest( qtlManifest, genome = "GRCh38", - ldSketch = ldSketch + ldReference = ldReference ) qts ``` @@ -206,7 +208,7 @@ qtsManual <- QtlSumStats( trait = "ENSG00000001", entry = list(entry), genome = "GRCh38", - ldSketch = ldSketch + ldReference = ldReference ) qtsManual ``` @@ -242,7 +244,7 @@ rownames(b) <- rownames(shat) <- rownames(z) contexts(qtlSumStatsFromBetaMatrix(b, shat, studyName = "demo")) ``` -Both default `ldSketch = NULL`, giving an LD-free collection. That is fine +Both default `ldReference = NULL`, giving an LD-free collection. That is fine for [mash](mash-pipeline.html), which never needs LD, but any RSS method does — supply a panel if the result is headed for fine-mapping or TWAS-weight learning. @@ -288,7 +290,7 @@ gwsMapped <- loadGwasSumStatsFromManifest( columnMapping = mapPath ), genome = "GRCh38", - ldSketch = ldSketch + ldReference = ldReference ) length(gwsMapped[[1]]) ``` @@ -316,7 +318,7 @@ Rsamtools::indexTabix(gz, seq = 1L, start = 2L, end = 2L, comment = "#") gwsRegion <- loadGwasSumStatsFromManifest( data.frame(study = "MyGWAS", sumStatsPath = gz), genome = "GRCh38", - ldSketch = ldSketch, + ldReference = ldReference, region = "22:14560000-14565000" ) length(gwsRegion[[1]]) # only the two variants in the region @@ -378,7 +380,7 @@ writeLines(vcfLines, vcfPath) gwsVcf <- loadGwasSumStatsFromManifest( data.frame(study = "MyGWAS", sumStatsPath = vcfPath), genome = "GRCh38", - ldSketch = ldSketch + ldReference = ldReference ) S4Vectors::mcols(gwsVcf[[1]])[, c("SNP", "A1", "A2", "Z", "N")] ``` diff --git a/vignettes/ctwas-pipeline.Rmd b/vignettes/ctwas-pipeline.Rmd index a30d7f05b..d30dada2d 100644 --- a/vignettes/ctwas-pipeline.Rmd +++ b/vignettes/ctwas-pipeline.Rmd @@ -19,13 +19,6 @@ knitr::opts_chunk$set( fig.height = 4.5, eval = hasCtwas ) -# cTWAS narrates each step through the logging package, which writes to -# stdout rather than as messages, so knitr cannot filter it. Quieten it here -# to keep the output readable -- in your own session the log is worth -# watching, since it reports region counts and EM convergence. -if (hasCtwas) { - logging::setLevel("WARN") -} ``` ```{r ctwas-missing, echo=FALSE, eval=!hasCtwas, results="asis"} @@ -95,7 +88,7 @@ blocks <- GenomicRanges::GRanges( gwasSumStats <- loadGwasSumStatsFromManifest( manifest = data.frame(study = "gwas1", sumStatsPath = gwasTsv), genome = "hg38", - ldSketch = ldStem, + ldReference = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks ) @@ -113,7 +106,7 @@ data(ctwasWeightsExample) res <- ctwasPipeline( gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample), - ctwasPriorArgs = CtwasPriorParam( + ctwasPriorParam = CtwasPriorParam( thin = 1, niterPrefit = 3, niter = 10, @@ -180,7 +173,7 @@ ctwasPipeline( gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample), fineMappingResult = fmr, - variantPruningArgs = VariantPruningParam( + variantPruningParam = VariantPruningParam( weightCutoff = 1e-4, maxVariants = 1000, csMinCor = 0.8, @@ -248,7 +241,7 @@ inputs <- assembleCtwasInputs( ) est <- estCtwasGroupPriors( inputs, - ctwasPriorArgs = CtwasPriorParam( + ctwasPriorParam = CtwasPriorParam( thin = 1, niterPrefit = 3, niter = 10, @@ -309,7 +302,7 @@ merged <- mergeCtwasBoundaryRegions( ) ``` -`ctwasPipeline(boundaryMergeArgs = BoundaryMergeParam(enabled = TRUE))` does +`ctwasPipeline(boundaryMergeParam = BoundaryMergeParam(enabled = TRUE))` does the same thing inline, with `mergePipThresh` / `mergeFilterCs` / `mergeMaxSNP` forwarding to those arguments. It is off by default because it only matters when a @@ -325,15 +318,15 @@ ctwasPipeline( maxNumSingleEffects = 5, ncore = 1, keepSnps = FALSE, - ctwasPriorArgs = CtwasPriorParam( + ctwasPriorParam = CtwasPriorParam( thin = 0.1, niterPrefit = 3, niter = 30, varStructure = "shared_type", fallbackToPrefit = FALSE ), - variantPruningArgs = VariantPruningParam(), - boundaryMergeArgs = BoundaryMergeParam(enabled = FALSE) + variantPruningParam = VariantPruningParam(), + boundaryMergeParam = BoundaryMergeParam(enabled = FALSE) ) ``` diff --git a/vignettes/fine-mapping.Rmd b/vignettes/fine-mapping.Rmd index 7d9fa1e15..8c8b74ec8 100644 --- a/vignettes/fine-mapping.Rmd +++ b/vignettes/fine-mapping.Rmd @@ -35,8 +35,9 @@ Method arguments are the same across input classes; `fineMappingPipeline()` routes `methods = "susie"` to `susieR::susie` for individual-level data and to `susieR::susie_rss` for summary-statistics inputs automatically. -The output is always a `FineMappingResult` (a `GRangesList`-subclass -collection, one element per fine-mapped tuple). +The output is a `QtlFineMappingResult` (a `GwasFineMappingResult` for +`GwasSumStats` input): a `GRangesList`-subclass collection, one element per +fine-mapped tuple. ```{r load-packages} library(pecotmr) @@ -140,7 +141,7 @@ fmrSs <- fineMappingPipeline(qtlSumStatsExample, methods = "susie") fmrSs ``` -The `QtlSumStats` collection carries an `ldSketch` genotype panel; the +The `QtlSumStats` collection carries an `ldReference` genotype panel; the pipeline pulls the per-region LD from there automatically. ## GWAS summary-statistics fine-mapping @@ -190,22 +191,30 @@ fineMappingPipeline( ## Joint multi-context / multi-trait fits -`jointSpecification` triggers the dispatch for cross-axis joint -methods (`mvsusie` for cross-context, `mvsusie` or `fsusie` for multi-trait): +The joint methods (`mvsusie`, `fsusie`) fit across traits when the input +has two or more, else across contexts. To choose the axes yourself, pass a +`jointSpecification`: a character vector of axes, or +`list(axes = , scope = )` to limit the fit to listed studies, contexts or +traits: ```{r fm-joint, eval=FALSE} +# `qd`: a QtlDataset whose traits are measured in brain, liver and more. fineMappingPipeline( - multiStudyQtlDatasetExample, + qd, methods = "mvsusie", - jointSpecification = list(axis = "context", contexts = c("brain", "liver")) + jointSpecification = list(list( + axes = "context", + scope = list(context = c("brain", "liver")) + )) ) ``` -See `?jointSpecification` for the specification grammar. +The `jointSpecification` argument in `?fineMappingPipeline` gives the full +grammar, including the `study` axis for summary statistics. ## Reading the result -`FineMappingResult` is a `GRangesList` subclass, one element per +`QtlFineMappingResult` is a `GRangesList` subclass, one element per `(study, context, trait, method)` tuple. The element is the fitted variant set as a `GRanges`, so the result is addressable by genomic range as well as by tuple; the tuple itself and the per-tuple payloads live in `mcols()`, @@ -289,7 +298,7 @@ Two are worth calling out: so that fine-mapping weights are contributed to the TWAS ensemble weights model alongside regularized regression methods. - Run the full [`causalInferencePipeline`](twas-zscore.html) (TWAS + MR) with - a `FineMappingResult` and `GwasSumStats`. + a `QtlFineMappingResult` and `GwasSumStats`. # Session info diff --git a/vignettes/heritability.Rmd b/vignettes/heritability.Rmd index a2834e568..4e2d93c65 100644 --- a/vignettes/heritability.Rmd +++ b/vignettes/heritability.Rmd @@ -47,9 +47,14 @@ data(ldScoreExample, ldEigenExample) ldScoreExample ``` -Both bundled references describe the same 1300 variants across 14 chr22 LD -blocks, taken from the de-identified `protocol_example` panel, so the four -methods can be compared on one dataset. +Both bundled references describe the same `r length(ldScoreExample)` +variants across `r length(ldBlocks(ldScoreExample))` chr22 LD blocks, so the +four methods can be compared on one dataset. Their LD is that of a reference +panel of `r ldPanelNSamples(ldScoreExample)` people simulated from the chr22 +LD of the de-identified `protocol_example` panel. That panel itself is a +sketch of 60 people: far too few for these estimators, which correct for the +noise in a reference's LD, so the examples carry the LD of a large panel +drawn from it instead (`inst/scripts/build_h2_examples.R`). ## Variants must line up @@ -93,7 +98,7 @@ gwas <- GwasSumStats( studyName = "trait1", entry = list(gr), genome = unique(unname(GenomeInfoDb::genome(ldScoreExample))), - ldSketch = readGenotypes( + ldReference = readGenotypes( system.file("extdata", "toy_ref.bed", package = "pecotmr") ) ) @@ -137,9 +142,9 @@ a negative partitioned heritability. One deliberate difference: LDER here clamps negative eigenvalues before forming its regression weights. A real, rank-deficient LD block decomposes -with a tail of tiny negative values that are floating-point noise, and -upstream takes `sqrt()` of the resulting negative weight and aborts. The -clamp changes nothing wherever upstream runs. +with a tail of tiny negative values that are floating-point noise, and the +original LDER implementation takes `sqrt()` of the resulting negative weight +and aborts. The clamp changes nothing wherever the original runs. [ldsc]: https://github.com/bulik/ldsc [hdl]: https://github.com/zhenin/HDL @@ -153,11 +158,11 @@ variance. Once the reference is small relative to the GWAS, that term outgrows the signal, the modelled variance is driven to its floor across most eigen-directions, and the optimiser walks the intercept out to the top of its range — returning a number that reflects that bound rather than the -data. At `N = 1e5` against this reference (`nRef` = -`r ldPanelNSamples(ldEigenExample)`) it drifts to about 0.56 for a true 0.4 and -warns that the fit sits on a bound. At the `N = 1e4` used here it is -comfortably inside its range. If HDL disagrees sharply with the others, -check for that warning and compare `nSamples()` against `ldPanelNSamples()`. +data. This reference's `r ldPanelNSamples(ldEigenExample)` people are plenty: +even at `N = 1e5` HDL recovers about 0.40 for a true 0.4. Against a +1,000-person panel at that `N` it drifts to about 0.57 and warns that the fit +sits on a bound. If HDL disagrees sharply with the others, check for that +warning and compare `nSamples()` against `ldPanelNSamples()`. A standard error of zero, or an estimate pinned at a boundary, almost always means the reference is too small rather than that the trait has no @@ -167,26 +172,34 @@ more; `estimateH2()` refuses a single-block reference outright. ## Building an LD reference The bundled references were built with `buildLdEigen()` / `buildLdScore()`, -which turn already-loaded LD into the statistic each estimator needs. Load -the LD **per block** — loading a whole region at once returns one dense -matrix, which is one block, and one block has no jackknife. +which turn an LD reference into the statistic each estimator needs. The +reference comes **per LD block**: a genotype panel together with the blocks +to cut it into, or one `LdMatrix` per block. One block has no jackknife. ```{r build-ref, eval=FALSE} -metaPath <- "/path/to/ld_meta_file.tsv" -blocks <- read.delim(metaPath, check.names = FALSE) -regions <- sprintf("chr22:%d-%d", blocks$start, blocks$end) +panel <- readGenotypes(plink2Prefix = "/path/to/reference.chr22") +blocks <- read.delim("/path/to/ld_blocks.tsv") # chrom, start, end -ldList <- lapply(regions, function(r) loadLdMatrix(metaPath, region = r)) +ldEigen <- buildLdEigen(panel, ldBlocks = blocks, genome = "hg38") +ldScore <- buildLdScore(panel, ldBlocks = blocks, genome = "hg38") -ldEigen <- buildLdEigen(ldList, genome = "hg38") -ldScore <- buildLdScore(ldList, genome = "hg38") +# Or from LD matrices you built, one LdMatrix per block: +ldScore <- buildLdScore(list(ldBlock1, ldBlock2, ldBlock3), genome = "hg38") ``` -`nRef` and the genome build default to what the loaded LD records. +`nSamples` (the reference panel size) and the genome build default to what +the reference records: a panel's sample count (for a stochastic sketch, the +effective size of its LD), or the `nSamples` of each `LdMatrix`. The panel +size matters beyond HDL: LD scores sum ldsc's unbiased r², +`r^2 - (1 - r^2) / (n - 2)`, so `n` should be the number of samples the LD +was estimated from. `buildLdScore(keepLdMatrices = FALSE)` drops the per-block matrices, which shrinks the object by roughly an order of magnitude — but only unstratified `"sldsc"` can use the result, since `"gldsc"` and stratified `"sldsc"` both -form their per-annotation scores from those matrices. +form their per-annotation scores from each block's LD. An `LdScore` or +`LdEigen` built from a genotype panel stores none of it: it keeps the panel +and reads each block's LD when an estimator reaches that block, so every +method runs on it while only one block's LD is in memory at a time. ## Stratified estimation and enrichment @@ -218,7 +231,7 @@ gwasStrat <- GwasSumStats( studyName = "trait1", entry = list(gr), genome = unique(unname(GenomeInfoDb::genome(ldScoreExample))), - ldSketch = readGenotypes( + ldReference = readGenotypes( system.file("extdata", "toy_ref.bed", package = "pecotmr") ) ) @@ -250,9 +263,10 @@ as.data.frame(stratifiedHeritabilityEnrichment(strat))[, c( `enrichment` is the proportion of heritability divided by the proportion of variants: above 1 means the annotation carries more heritability than its -share of the genome. The simulated truth here is 3, and the estimate is -directionally right but attenuated — again a consequence of the reference's -size rather than of the annotation. +share of the genome. The simulated truth here is 1.5 — three times the +per-variant heritability on half the variants puts 75% of it in `annotA` — +and the estimate is directionally right but attenuated, again a consequence +of the reference's size rather than of the annotation. Annotations come from files via `readAnnotations()`, which reads BED, BigWig and LDSC `.annot` formats at a given set of variant positions: @@ -357,10 +371,12 @@ scores <- computeLdScores(ldEigenExample) head(round(as.vector(scores[, 1]), 3)) ``` -This is the same quantity `buildLdScore()` stores, reconstructed from the -eigendecomposition — `sum_i V[j,i]^2 d[i]^2` rather than `sum_k r^2_jk`. -The two agree, which is worth knowing when you have one object and need the -other's input. +This is the same quantity `buildLdScore()` stores: each variant's sum, over +its block, of ldsc's unbiased r² rather than the raw sample r², which +overstates LD on a finite panel. From an `LdEigen` the raw sum comes out of +the eigendecomposition as `sum_i V[j,i]^2 d[i]^2`, and the correction applies +to that sum exactly, so the two agree — worth knowing when you have one +object and need the other's input. ## Bridging the two tracks diff --git a/vignettes/ld-infrastructure.Rmd b/vignettes/ld-infrastructure.Rmd index b835208fa..5c2a20e75 100644 --- a/vignettes/ld-infrastructure.Rmd +++ b/vignettes/ld-infrastructure.Rmd @@ -24,104 +24,141 @@ knitr::opts_chunk$set( Almost everything else in pecotmr needs LD. Fine-mapping from summary statistics needs it, RSS weight learning needs it, colocalization needs it, and the heritability estimators are built on nothing else. The pipelines -handle it for you, so this vignette is about the layer underneath: loading -LD for a region, computing it from genotypes, checking it is usable, and -reducing a variant set that is too correlated to model. +handle it for you, so this vignette is about the layer underneath: the two +kinds of LD reference pecotmr reads LD from, computing LD from genotypes, +checking it is usable, and reducing a variant set that is too correlated to +model. ```{r load-packages} library(pecotmr) -ldMeta <- system.file( - "extdata", - "ld_reference", - "ld_meta_file.tsv", - package = "pecotmr" -) ``` -An LD reference is described by a **meta file**: one row per LD block, giving -the block's coordinates and the path to the genotype or correlation data -backing it. +## Two kinds of LD reference -```{r meta} -read.delim(ldMeta, check.names = FALSE) -``` +Every pipeline reads LD from one place: the `ldReference` of the collection +it is given. That reference is one of two things (or a mixture of either, +below). -Paths are relative to the meta file, so a reference directory can be moved -without rewriting it. +- A **genotype panel**, read lazily from disk with `readGenotypes()`. LD is + computed on demand for whichever variants a step needs, so a panel far + larger than any one region costs nothing until it is read. It is the same + structure a `QtlDataset` holds its genotypes in. +- An **`LdMatrix`**: a correlation matrix you built, held in memory. pecotmr + does not read pre-computed LD from disk; read the matrix with whatever + suits its format and wrap it. -## Loading LD for a region +### A genotype panel -`loadLdMatrix()` returns an `LdData` — a `GRanges` of the variants plus the -correlation matrix, or the genotypes to compute it from: +```{r panel} +panel <- readGenotypes( + plink2Prefix = file.path( + system.file("extdata", "ld_reference", "chr22", package = "pecotmr"), + "protocol_example.LD.chr22" + ) +) +panel +``` -```{r load} -region <- "chr22:10000000-19000000" -ld <- loadLdMatrix(ldMeta, region = region) -ld -R <- ldMatrix(ld) -dim(R) +The bundled panel is a *stochastic LD sketch*: 1,000 pseudo-samples +projected from 60 real people, which reproduces their LD without carrying +their genotypes. pecotmr recognises one by its `.afreq` sidecar and records +the real sample size and allele frequencies on the panel when it is read, +because the projected dosages say nothing about either: + +```{r panel-sketch} +S4Vectors::metadata(panel)$ldProjection +head(SummarizedExperiment::rowRanges(panel)$AF) ``` -Whether a correlation matrix or a genotype handle comes back depends on the -source. `returnGenotype = "auto"` (the default for genotype sources) returns -dosages and computes `R` on demand, which matters because a dense matrix for -a large region is far bigger than the genotypes it came from. +A MAC cutoff or DENTIST's truncation rank counts the 60 real samples, and +ldsc's unbiased \(r^2\) and HDL use the effective size of the sketch's LD, +\(1 / (1/60 + 1/1000) \approx 57\). Neither is the 1,000 columns. -`variantInfo()` gives the variants as a plain `GRanges`, which is what you -need to align summary statistics against the panel: +`computeLd()` correlates any subset of a panel's variants: -```{r variant-info} -head(variantInfo(ld), 3) +```{r panel-ld} +R <- computeLd(panel) +dim(R) ``` -**A region is not a block.** Loading a whole region returns one dense matrix -covering it. To get one matrix per LD block — which the block jackknife in -[heritability estimation](heritability.html) requires — address the blocks -individually. +A panel can also be reached through an LD meta file: one row per chromosome +or block, giving its coordinates and the genotype files behind it, with +paths relative to the meta file. `readGenotypes(ldMeta = , region = )` opens +the row covering a region. -`region` also takes a vector, returning one `LdData` per entry — which is -how you get per-block LD without writing the loop yourself: +### An LdMatrix -```{r multi-region} -blocks <- read.delim(ldMeta, check.names = FALSE) -ldList <- loadLdMatrix( - ldMeta, - region = sprintf("chr22:%d-%d", blocks$start, blocks$end) -) -length(ldList) +```{r ldmatrix} +ld <- LdMatrix(R, nSamples = 57) +ld ``` -### Sources without coordinates +The matrix's dimnames here are `chrom:pos:A2:A1` ids, so the variants are +parsed from them; otherwise pass `variants`, a `GRanges` or a data frame with +`chrom`, `pos`, `A1` and `A2` (and optionally `SNP` and `AF`). Correlations +must be signed by the dosage of `A1`. `nSamples` is the number of samples the +LD was estimated from, and `AF`, the frequency of `A1`, is what the +frequency filters and cTWAS's weight scaling read. -An LD meta file carries coordinates, so its blocks are addressed by `region`. -Other sources have no coordinates and are addressed by `block` index instead: +`LdMatrix()` checks the matrix's shape and labels, its unit diagonal, that +its entries lie in \([-1, 1]\), and its symmetry. It does not check positive +semi-definiteness, which costs an eigendecomposition; `checkLd()` below does. -- an **`ldInfo` table** — an `LD_file` column and optionally `SNP_file`, the - shape cTWAS's `LD_map` uses -- a **matrix** already in memory, or a list of them +A matrix has no genotypes, so the steps that need them work differently: -```{r by-block} -R2 <- computeLd(matrix(rnorm(100 * 10), 100, 10)) -loadLdMatrix(R2, block = 1) +| Step | With an `LdMatrix` | +|---|---| +| LD for any variant set | read from the matrix | +| MAF / MAC filters, cTWAS scaling | need `AF` (and `nSamples` for MAC) | +| DENTIST, ldsc's unbiased \(r^2\), HDL | need its `nSamples` | +| Missingness filter | refused: there are no genotypes to be missing | +| RAiSS | inverts the matrix instead of the genotype SVD | + +### Mixtures of LD references + +Summary statistics meta-analysed across ancestries are correlated through +the weighted average of the cohorts' LD. `LdMatrix()` builds that average +from one `LdMatrix` per cohort, matching the components by position and +allele and keeping the variants they all cover: + +```{r mixture} +half <- seq_len(ncol(panel) / 2) +ldA <- LdMatrix(computeLd(panel[, half]), nSamples = 30) +ldB <- LdMatrix(computeLd(panel[, -half]), nSamples = 30) +LdMatrix(list(ldA, ldB), mixtureWeights = c(0.7, 0.3)) ``` -Supplying both `region` and `block`, or neither, is an error — the source -determines which one applies. +The weights are typically each cohort's share of the GWAS sample size. -### Options +`GenotypeMixture()` builds the same average from genotype panels, but +lazily: the panels stay on disk and are read only for the variants a step +asks about, so each keeps answering for its own samples. A frequency or +missingness filter judges every panel on its own and drops a variant that +fails in any of them. The mixture is a `MultiAssayExperiment` with one +experiment per cohort, so the panels are named after their cohorts, and +`experiments()` and `sampleMap()` show what it holds. -| Argument | Effect | -|---|---| -| `returnGenotype` | `"auto"` gives dosages for genotype sources, `R` for pre-computed | -| `dropMonomorphic` | drop variants with no variation | -| `materializeGenotypes` | read dosages once and keep them, so later access does no file I/O | -| `maxVariants` / `seed` | randomly thin oversized blocks, reproducibly | +```{r genotype-mixture} +GenotypeMixture( + list(EUR = panel[, half], AFR = panel[, -half]), + mixtureWeights = c(EUR = 0.7, AFR = 0.3) +) +``` + +### Using a reference -```{r options} -thinned <- loadLdMatrix(ldMeta, region = region, maxVariants = 50, seed = 1) -length(thinned) +Either kind goes in the same slot, and from there every step reads it the +same way: + +```{r use, eval=FALSE} +gwas <- GwasSumStats(..., ldReference = panel) # or ldReference = ld ``` +When two collections meet in one pipeline — a QTL and a GWAS side in +colocalization, say — their references must be the same: two panels must +share their samples and allele coding, two `LdMatrix` objects must agree on +the LD they share, and a panel never matches a matrix. + ## Computing LD from genotypes `computeLd()` takes a dosage matrix and returns the correlation matrix: diff --git a/vignettes/rss-qc.Rmd b/vignettes/rss-qc.Rmd index 682ec0a8c..b6e120482 100644 --- a/vignettes/rss-qc.Rmd +++ b/vignettes/rss-qc.Rmd @@ -57,7 +57,7 @@ make these objects. In this example the object is `GwasSumStats` object called ```{r run-qc, eval=FALSE} gws_qcd <- summaryStatsQc( gws, - sumstatsFilterArgs = SumstatsFilterParam( + sumstatsFilterParam = SumstatsFilterParam( removeIndels = FALSE, removeStrandAmbiguous = TRUE, infoCutoff = 0, # 0 = off; > 0 requires INFO column @@ -69,7 +69,7 @@ gws_qcd <- summaryStatsQc( skipRegion = NULL, # e.g. MHC "chr6:25000000-35000000" ldMismatchQcMethod = "slalom", # "none", "slalom", "dentist" alleleFlipKriging = FALSE, # opt-in pre-SLALOM LD-consistency check - impute = FALSE, # RAISS imputation against ldSketch + impute = FALSE, # RAISS imputation against ldReference matchMinProp = 0 ) ``` @@ -81,7 +81,7 @@ accessible via `qcInfo()`: ```{r inspect-qcinfo, eval=FALSE} qc <- qcInfo(gws_qcd) str(qc$entryAudit[[1]]) # per-entry counts: variantsIn, mungeSumstatsDropped, -# keepVariantsDropped, skipRegionDropped, matchedAgainstSketch, +# keepVariantsDropped, skipRegionDropped, matchedAgainstLdReference, # krigingOutliersDropped, ldMismatchOutliersDropped, ... qc$options # the curated knobs you passed (frozen for provenance) ``` @@ -196,9 +196,9 @@ It uses `susieR`'s kriging RSS diagnostic: the `qcInfo` audit as `krigingOutliersDropped`. Because it needs a per-region LD matrix and the kriging diagnostic, this is an -**RSS-only** check: it draws `R` from the collection's `ldSketch` and requires -a `susieR` that exports `kriging_rss()` / `estimate_s_rss()` (otherwise it -errors — which is why it is off by default). +**RSS-only** check: it draws `R` from the collection's `ldReference` and +requires a `susieR` that exports `kriging_rss()` / `estimate_s_rss()` +(otherwise it errors — which is why it is off by default). The same diagnostic is exposed standalone as `krigingOutlierQc()` when you want to inspect the per-variant predicted z, residual, statistic, and p-value @@ -266,7 +266,7 @@ flagged variants from the surviving ones, pair SLALOM with **RAISS** (a LD-regression imputer). `summaryStatsQc(ldMismatchQcMethod = "slalom", impute = TRUE)` does this for you. The standalone version is exposed as `raiss()`; the -full set of RAISS knobs lives under the `imputeArgs` argument to +full set of RAISS knobs lives under the `raissParam` argument to `summaryStatsQc()`, built with `RaissParam()`: ```{r raiss-args, eval=FALSE} @@ -274,7 +274,7 @@ gws_qcd <- summaryStatsQc( gws, ldMismatchQcMethod = "slalom", impute = TRUE, - imputeArgs = RaissParam( + raissParam = RaissParam( r2Threshold = 0.6, minimumLd = 5, lamb = 0.01, diff --git a/vignettes/twas-weights.Rmd b/vignettes/twas-weights.Rmd index 54fe5be36..fb30b2549 100644 --- a/vignettes/twas-weights.Rmd +++ b/vignettes/twas-weights.Rmd @@ -95,13 +95,13 @@ length(variantIds(entry)) The posterior effect estimates of SuSiE fine-mapping models are themselves a set of per-variant weight estimates. When you pass an existing -`FineMappingResult` to `twasWeightsPipeline()`, the trimmed susie fit for each -matching `(study, context, trait)` tuple is added to the ensemble as an +`QtlFineMappingResult` to `twasWeightsPipeline()`, the trimmed susie fit for +each matching `(study, context, trait)` tuple is added to the ensemble as an additional weights row instead of being re-fit. The same holds under cross-validation: each fold needs a fit trained on that fold's rows, and the weights pipeline will not produce one. Run the -fine-mapping with `crossValidation` so those per-fold fits travel with the +fine-mapping with `crossValidationParam` so those per-fold fits travel with the result — requesting a fine-mapping method under cross-validation without them is an error. That fold partition then governs the whole run: every other weight @@ -115,7 +115,7 @@ fmr <- fineMappingPipeline( qtlDatasetExample, methods = "susie", cisWindow = 1e6, - crossValidationArgs = CrossValidationParam(folds = 3) + crossValidationParam = CrossValidationParam(folds = 3) ) tw2 <- twasWeightsPipeline( qtlDatasetExample, @@ -153,7 +153,7 @@ twasWeightsPipeline( methods = c("lasso", "enet", "ridge", "mrash") ) -# Add a fine-mapping susie row by providing the FineMappingResult. +# Add a fine-mapping susie row by providing the QtlFineMappingResult. fmr <- fineMappingPipeline( qtlDatasetExample, methods = "susie", @@ -174,8 +174,11 @@ twSs <- twasWeightsPipeline(qtlSumStatsExample, methods = "lasso") twSs ``` -The RSS path uses the `ldSketch` genotype panel inside the -`QtlSumStats` collection to compute LD as needed. The same +The RSS path uses the `ldReference` genotype panel inside the +`QtlSumStats` collection to compute LD as needed. The same rule holds for +fine-mapping methods here: they are not re-fit, so run +`fineMappingPipeline()` on the `QtlSumStats` first and pass its result as +`fineMappingResult`. ## Multivariate (multi-context) weights @@ -190,14 +193,20 @@ twasWeightsPipeline( ) ``` -For an explicit cross-context joint fit driven by a -`jointSpecification`: +To choose the axes yourself, pass a `jointSpecification`: a character +vector of axes, or `list(axes = , scope = )` to limit the fit to listed +studies, contexts or traits. The `jointSpecification` argument in +`?twasWeightsPipeline` gives the full grammar. ```{r joint, eval=FALSE} +# `qd`: a QtlDataset whose traits are measured in brain, liver and more. twasWeightsPipeline( - multiStudyQtlDatasetExample, + qd, methods = "mrmash", - jointSpecification = list(axis = "context", contexts = c("brain", "liver")) + jointSpecification = list(list( + axes = "context", + scope = list(context = c("brain", "liver")) + )) ) ``` @@ -230,7 +239,7 @@ The families, and the `methods =` name each answers to: | Penalized regression | `lasso`, `enet`, `mcp`, `scad`, `l0learn` | `lassoWeights()`, `enetWeights()`, … | | Bayesian alphabet | `bayesA` … `bayesR`, `bLasso` | `bayesAWeights()`, `bLassoWeights()`, … | | Dirichlet process regression | `dprVb`, `dprGibbs`, `dprAdaptiveGibbs` | `dprVbWeights()`, `dprGibbsWeights()`, … | -| External PRS methods | `prsCs` (sumstats input only) | `prsCs()`, `sdpr()`, `lassosumRss()` | +| PRS-CS | `prsCs` (sumstats input only) | `prsCsWeights()` | | mr.mash / mr.ash | `mrmash`, `mrash` | `mrmashWeights()`, `mrashWeights()` | | SuSiE family | `susie`, `susieInf`, `susieAsh`, `mvsusie`, `fsusie` | `susieWeights()`, `mvsusieWeights()`, … | @@ -238,19 +247,42 @@ Every token is camelCase, matching the function names. Snake_case spellings are not accepted: `bayes_r`, `dpr_vb` and `susie_inf` all error with the list of known tokens. -Every family has an RSS counterpart taking summary statistics and an LD -matrix instead of `X`/`y` — `lassosumRssWeights()`, `mcpRssWeights()`, -`susieRssWeights()`, and so on. Those are what -`twasWeightsPipeline()` calls when the input is a `QtlSumStats`. - -`prsCs()`, `sdpr()` and `lassosumRss()` are exported alongside their -`*Weights()` adapters because they return more than the coefficient vector. -`sdpr()` also gives a heritability estimate (`h2`), `lassosumRss()` the whole -regularization path (`beta` is variants x lambda, plus the `lambda` grid and -per-fit `loss`), and `prsCs()` the posterior shrinkage parameters (`psiEst`, -`sigmaEst`, `phiEst`). The adapters reduce each of those to the weights the -pipeline consumes, so reach for the raw function when you want the -diagnostics rather than just the weights. +Most families have an RSS counterpart taking summary statistics and an LD +reference instead of `X`/`y` — `lassosumRssWeights()` for `lasso`, +`mcpRssWeights()`, `sdprWeights()` (SDPR) for `dprGibbs`, `susieRssWeights()`, +and so on; the Bayesian alphabet, `enet`, `dprVb` and `dprAdaptiveGibbs` have +none. Those are what `twasWeightsPipeline()` calls when the input is a +`QtlSumStats`. The LD +reference is the same `ldReference` the rest of the package takes: a +genotype panel from `readGenotypes()`, a `GenotypeMixture` or an +`LdMatrix`, matched to the statistics by their `variantNames`. lassosum, +the penalized methods, PRS-CS and SDPR use a genotype reference through its +standardized genotypes without forming the LD matrix; the mr.ash and +mr.mash engines take the matrix, which is formed over the statistics' +variants. + +Several of these engines estimate more than the weights, and +`fitRetention = "slim"` keeps it as the `"fit"` attribute of the weights they +return: SDPR's heritability estimate (`h2`), PRS-CS's posterior shrinkage +parameters (`psiEst`, `sigmaEst`, `phiEst`), and for lassosum and the +penalized methods the search itself --- `path` has one row per LD shrinkage +`s` and penalty `lambda`, with the objective (`fbeta`), `loss`, convergence +flag and number of non-zero weights, and marks the candidate returned. +`fitRetention = "full"` adds each candidate's coefficients. + +```{r rss-fit} +# An LdMatrix is keyed by chrom:pos:A2:A1 variant ids. +ids <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) +R <- cor(X) +dimnames(R) <- list(ids, ids) +stat <- list( + z = as.vector(cor(X, y)) * sqrt(n), + n = rep(n, p), + variantNames = ids +) +w <- lassosumRssWeights(stat, LdMatrix(R), fitRetention = "slim") +head(attr(w, "fit")$path) +``` The mr.mash methods need prior covariance matrices, built by `buildMrmashPriorMatrices()`. Pass `dataDrivenPriorMatrices` to add @@ -293,22 +325,22 @@ twasWeightsPipeline( traitId = "ENSG_example", region = "chr22:25000000-26000000", cisWindow = 5e5, - crossValidationArgs = CrossValidationParam( + crossValidationParam = CrossValidationParam( folds = 5, numThreads = 1, samplePartition = NULL, maxVariants = -1 ), # required for a fine-mapping method, and under folds > 1 it must carry - # the per-fold fits (fineMappingPipeline(..., crossValidationArgs = ...)) + # the per-fold fits (fineMappingPipeline(..., crossValidationParam = ...)) fineMappingResult = fmr, - ensembleArgs = EnsembleParam( + ensembleParam = EnsembleParam( enabled = TRUE, r2Threshold = 0.01, solver = "quadprog" ), estimatePi = TRUE, - residualizationArgs = ResidualizationParam( + residualizationParam = ResidualizationParam( phenotypeCovariates = NULL, genotypeCovariates = NULL ), @@ -396,10 +428,11 @@ exportToBed(tw, "weights.bed.gz") ``` Both export the **full-data fit only**, and refuse an object that has none — -`twasWeightsPipeline(fitFullData = FALSE)` produces rows holding nothing but -cross-validation results, and those cannot be published: they describe -held-out folds, and fold membership is sample-level information. For the same -reason neither exporter writes CV metrics. Those stay on the object: +`crossValidationParam = CrossValidationParam(fitFullData = FALSE)` produces rows +holding nothing but cross-validation results, and those cannot be published: +they describe held-out folds, and fold membership is sample-level information. +For the same reason neither exporter writes CV metrics. Those stay on the +object: ```{r tw-cv, eval=FALSE} cv <- cvResult(tw, studyName = "s1", context = "brain", trait = "g1", @@ -410,7 +443,7 @@ cv$performance # per-method metric matrix: corr, rsq, adj_rsq, pval, RMSE, MAE Fine-mapping-derived rows (`susie`, `susie_inf`, `susie_ash`, `mvsusie`, `fsusie`) are skipped with a message by **both** exporters, because their "weights" are the fine-mapping posterior re-expressed — export the -`FineMappingResult` instead, which carries the posterior, its standard error +fine-mapping result instead, which carries the posterior, its standard error and the credible sets. Selecting only such a method, as in `method = "susie"`, is therefore an error rather than an empty file. diff --git a/vignettes/twas-zscore.Rmd b/vignettes/twas-zscore.Rmd index e028dd2b6..16827ea89 100644 --- a/vignettes/twas-zscore.Rmd +++ b/vignettes/twas-zscore.Rmd @@ -53,7 +53,7 @@ fmr <- fineMappingPipeline( qtlDatasetExample, methods = "susie", cisWindow = 1e6, - crossValidationArgs = CrossValidationParam(folds = 3) + crossValidationParam = CrossValidationParam(folds = 3) ) tw <- twasWeightsPipeline( qtlDatasetExample, @@ -89,7 +89,7 @@ res2 <- causalInferencePipeline( gwasSumStats = gwasSumStatsS4Example, twasWeights = tw, fineMappingResult = fmr, - mrArgs = MrParam(method = "ivwPerVariant", pipCutoff = 0.5) + mrParam = MrParam(method = "ivwPerVariant", pipCutoff = 0.5) ) S4Vectors::mcols(res2)[, c( "twasZ", @@ -113,7 +113,7 @@ causalInferencePipeline( gwasSumStats = gwasSumStatsS4Example, twasWeights = tw, fineMappingResult = fmr, - mrArgs = MrParam(method = "csAware", cpipCutoff = 0.5) + mrParam = MrParam(method = "csAware", cpipCutoff = 0.5) ) ``` @@ -150,13 +150,13 @@ waldTestPval(beta = 2.5, se = 0.8, n = 10000) `n` sets the degrees of freedom, so a small study gives a more conservative p-value than the normal approximation would. -## LD-sketch consistency +## LD reference consistency -Both `twasWeights` and `fineMappingResult` carry an `ldSketch` slot. -When provided, they must reference the same LD panel as -`gwasSumStats`. The pipeline errors on mismatch. +Both `twasWeights` and `fineMappingResult` carry an `ldReference` slot. +When provided, they must be the same LD reference as `gwasSumStats` +carries. The pipeline errors on mismatch. -A QTL input with `ldSketch = NULL` (e.g. weights learned from +A QTL input with `ldReference = NULL` (e.g. weights learned from individual-level data without any RSS step) skips the panel check for that input — useful for analyses that mix individual-level QTL fits with sumstats GWAS. @@ -168,7 +168,7 @@ causalInferencePipeline( gwasSumStats = gwasSumStatsS4Example, twasWeights = tw, fineMappingResult = fmr, - mrArgs = MrParam( + mrParam = MrParam( method = "ivwPerVariant", pipCutoff = 0.5 # cpipCutoff instead, for method = "csAware" ), diff --git a/vignettes/xqtl-enrichment.Rmd b/vignettes/xqtl-enrichment.Rmd index 16f42b2a7..2609fd6c9 100644 --- a/vignettes/xqtl-enrichment.Rmd +++ b/vignettes/xqtl-enrichment.Rmd @@ -84,7 +84,7 @@ par(op) `qtlEnrichmentPipeline()` takes the two fine-mapping collections directly and estimates, for every `(gwasStudy, qtlStudy, qtlContext)` combination, how enriched the molecular QTLs are among the GWAS causal variants. The GWAS -collection must be RSS-derived (it carries an `ldSketch`); +collection must be RSS-derived (it carries an `ldReference`); `gwasFineMappingExample` already does. ```{r enrichment}